        subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status)
 
C       Ascii table data DEFinition
C       define the structure of the ASCII table data unit
C
C       ounit   i  Fortran I/O unit number
C       lenrow  i  length of a row, in characters
C       nfield  i  number of fields in the table
C       bcol    i  starting position of each column, (starting with 1)
C       tform   C  the data format of the column
C       nrows   i  number of rows in the table
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,lenrow,nfield,bcol(*),nrows,status
        character*(*) tform(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,j,clen,c2
        character ctemp*24, cnum*3,cbcol*10,caxis1*10
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
        if (dtstrt(ibuff) .lt. 0)then
C               freeze the header at its current size
                call fthdef(ounit,0,status)
                if (status .gt. 0)return
        end if
 
        hdutyp(ibuff)=1
        tfield(ibuff)=nfield
 
        if (nxtfld + nfield .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
                return
        end if
 
        tstart(ibuff)=nxtfld
        nxtfld=nxtfld+nfield
 
        if (nfield .eq. 0)then
C           no data; the next HDU begins in the next logical block
            hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff)
            heapsz(ibuff)=0
            theap(ibuff)=0
        else
C           initialize the table column parameters
            clen=len(tform(1))
            do 20 i=1,nfield
                tscale(i+tstart(ibuff))=1.
                tzero(i+tstart(ibuff))=0.
C               choose special value to indicate null values are not defined
                cnull(i+tstart(ibuff))=char(1)
                cform(i+tstart(ibuff))=tform(i)
                tbcol(i+tstart(ibuff))=bcol(i)-1
                tdtype(i+tstart(ibuff))=16
C               the repeat count is always one for ASCII tables
                trept(i+tstart(ibuff))=1
C               store the width of the field in TNULL
                c2=0
                do 10 j=2,clen
                        if (tform(i)(j:j) .ge. '0' .and.
     &                     tform(i)(j:j) .le. '9')then
                                c2=j
                        else
                                go to 15
                        end if
10              continue
15              continue
                if (c2 .eq. 0)then
C                       no explicit width, so assume width of 1 character
                        tnull(i+tstart(ibuff))=1
                else
                    call ftc2ii(tform(i)(2:c2),tnull(i+tstart(ibuff))
     &                          ,status)
                    if (status .gt. 0)then
C                        error parsing TFORM to determine field width
                         status=261
                         ctemp=tform(i)
                         call ftpmsg('Error parsing TFORM to get field'
     &                    //' width: '//ctemp)
                         return
                    end if
                end if
 
C               check that column fits within the table
                if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff))
     &            .gt. lenrow .and. lenrow .ne. 0)then
                    status=236
                    write(cnum,1000)i
                    write(cbcol,1001)bcol(i)
                    write(caxis1,1001)lenrow
1000                format(i3)
1001                format(i10)
                    call ftpmsg('Column '//cnum//' will not fit '//
     &             'within the specified width of the ASCII table.')
 
                    call ftpmsg('TFORM='//cform(i+tstart(ibuff))//
     &              '  TBCOL='//cbcol//'  NAXIS1='//caxis1)
                    return
                 end if
20           continue
 
C           calculate the start of the next header unit, based on the
C           size of the data unit
            rowlen(ibuff)=lenrow
            hdstrt(ibuff,chdu(ibuff)+1)=
     &          dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880
 
C       initialize the fictitious heap starting address (immediately following
C       the table data) and a zero length heap.  This is used to find the
C       end of the table data when checking the fill values in the last block.
C           ASCII tables have no special data area
            heapsz(ibuff)=0
            theap(ibuff)=rowlen(ibuff)*nrows
        end if
        end
        subroutine ftaini(iunit,status)
 
C       initialize the parameters defining the structure of an ASCII table
 
C       iunit   i  Fortran I/O unit number
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer nrows,tfld,nkey,ibuff,i,nblank
        character keynam*8,value*70,comm*72,rec*80
        character cnum*3,cbcol*10,caxis1*10
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       store the type of HDU (1 = ASCII table extension)
        hdutyp(ibuff)=1
 
C       temporarily set the location of the end of the header to a huge number
        hdend(ibuff)=2000000000
        hdstrt(ibuff,chdu(ibuff)+1)=2000000000
 
C       check that this is a valid ASCII table, and get parameters
        call ftgttb(iunit,rowlen(ibuff),nrows,tfld,status)
        if (status .gt. 0)go to 900
 
        if (tfld .gt. nf)then
C               arrays not dimensioned large enough for this many fields
                status=111
        call ftpmsg('This ASCII table has too many fields '//
     & 'to be read with FITSIO (FTAINI).')
                go to 900
         end if
 
C       store the number of fields in the common block
        tfield(ibuff)=tfld
 
        if (nxtfld + tfld .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
                return
        end if
 
        tstart(ibuff)=nxtfld
        nxtfld=nxtfld+tfld
 
C       initialize the table field parameters
        do 5 i=1,tfld
                tscale(i+tstart(ibuff))=1.
                tzero(i+tstart(ibuff))=0.
C               choose special value to indicate that null value is not defined
                cnull(i+tstart(ibuff))=char(1)
C               pre-set required keyword values to a null value
                tbcol(i+tstart(ibuff))=-1
                tdtype(i+tstart(ibuff))=-9999
5       continue
 
C       initialize the fictitious heap starting address (immediately following
C       the table data) and a zero length heap.  This is used to find the
C       end of the table data when checking the fill values in the last block.
C       there is no special data following an ASCII table
        heapsz(ibuff)=0
        theap(ibuff)=rowlen(ibuff)*nrows
 
C       now read through the rest of the header looking for table column
C       definition keywords, and the END keyword.
 
        nkey=8
8       nblank=0
10      nkey=nkey+1
        call ftgrec(iunit,nkey,rec,status)
        if (status .eq. 107)then
C               if we hit the end of file, then set status = no END card found
                status=210
        call ftpmsg('Required END keyword not found in ASCII table'//
     &  ' header (FTAINI).')
                go to 900
        else if (status .gt. 0)then
                go to 900
        end if
        keynam=rec(1:8)
        comm=rec(9:80)
 
        if (keynam(1:1) .eq. 'T')then
C               get the ASCII table parameter (if it is one)
                call ftpsvc(rec,value,comm,status)
                call ftgatp(ibuff,keynam,value,status)
        else if (keynam .eq. ' ' .and. comm .eq. ' ')then
                nblank=nblank+1
                go to 10
        else if (keynam .eq. 'END')then
                go to 20
        end if
        go to 8
 
20      continue
 
C       test that all the required keywords were found
        do 25 i=1,tfld
            if (tbcol(i+tstart(ibuff)) .eq. -1)then
                status=231
                call ftkeyn('TBCOL',i,keynam,status)
                call ftpmsg('Required '//keynam//
     &                      ' keyword not found (FTAINI).')
                return
            else if (tbcol(i+tstart(ibuff)) .lt. 0 .or.
     &               tbcol(i+tstart(ibuff)) .ge. rowlen(ibuff)
     &               .and. rowlen(ibuff) .ne. 0)then
                status=234
                call ftkeyn('TBCOL',i,keynam,status)
                call ftpmsg('Value of the '//keynam//
     &                      ' keyword is out of range (FTAINI).')
                return
 
C               check that column fits within the table
            else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) .gt.
     &               rowlen(ibuff) .and. rowlen(ibuff) .ne. 0)then
                    status=236
                    write(cnum,1000)i
                    write(cbcol,1001)tbcol(i+tstart(ibuff))+1
                    write(caxis1,1001)rowlen(ibuff)
1000                format(i3)
1001                format(i10)
                    call ftpmsg('Column '//cnum//' will not fit '//
     &             'within the specified width of the ASCII table.')
 
                    call ftpmsg('TFORM='//cform(i+tstart(ibuff))//
     &              '  TBCOL='//cbcol//'  NAXIS1='//caxis1)
                    return
            else if (tdtype(i+tstart(ibuff)) .eq. -9999)then
                status=232
                call ftkeyn('TFORM',i,keynam,status)
                call ftpmsg('Required '//keynam//
     &                      ' keyword not found (FTAINI).')
                return
            end if
25      continue
 
C       now we know everything about the table; just fill in the parameters:
C       the 'END' record begins 80 bytes before the current position,
C       ignoring any trailing blank keywords just before the END keyword
        hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1)
 
C       the data unit begins at the beginning of the next logical block
        dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880
 
C       reset header pointer to the first keyword
        nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))
 
C       the next HDU begins in the next logical block after the data
        hdstrt(ibuff,chdu(ibuff)+1)=
     &  dtstrt(ibuff)+(rowlen(ibuff)*nrows+2879)/2880*2880
 
900     continue
        end
        subroutine ftarch(iword,jword,compid)
 
C       This routine looks at how integers and reals are internally
C       stored, to figure out what kind of machine it is running on.
 
C              compid =  0  -  Big Endian (SUN, Mac, Next, SGI)
C                        1  -  Little Endian (Dec Ultrix, OSF/1, PC)
C                        2  -  Vax VMS
C                        3  -  Alpha VMS
C                        4  -  IBM mainframe
C                       -1  -  SUN F() compiler (maps I*2 variables into I*4)
C       (large neg number)  -  Cray supercomputer
 
        integer compid
        integer*2 iword(2)
        integer jword(2)
 
C       Look at the equivalent integer, to distinquish the machine type.
C       The machine type is needed when testing for NaNs.
 
        if (iword(1) .eq. 16270)then
C               looks like a SUN workstation (uses IEEE word format)
                compid=0
        else if (iword(1) .eq. 14564)then
C               looks like a Decstation, alpha OSF/1, or IBM PC (byte swapped)
                compid=1
        else if (iword(1) .eq. 16526)then
                if (jword(1) .eq. 954417294)then
C                   looks like a VAX VMS system
                    compid=2
                else
C                   looks like ALPHA VMS system
                    compid=3
                end if
        else if (iword(1) .eq. 16657)then
C               an IBM main frame (the test for NaNs is the same as on SUNs)
                compid=4
        else if (iword(1) .eq. 1066285284)then
C               SUN F90 compiler maps I*2 variables into I*4
                compid= (-1)
        else
C               unknown machine
                compid=0
        end if
        end
        subroutine ftasfm(form,dtype,width,decims,status)
 
C       'ASCII Format'
C       parse the ASCII table TFORM column format to determine the data
C       type, the field width, and number of decimal places (if relevant)
C
C       form    c  TFORM format string
C       OUTPUT PARAMETERS:
C       dattyp  i  datatype code
C       width   i  width of the field
C       decims  i  number of decimal places
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, November 1994
 
        character*(*) form
        integer dtype,width,decims,status
        character dattyp*1,cform*16
        integer nc,c1,i,nw
 
        if (status .gt. 0)return
 
        cform=form
 
C       find first non-blank character
        nc=len(form)
        do 5 i=1,nc
                if (form(i:i) .ne. ' ')then
                        c1=i
                        go to 10
                end if
5       continue
 
C       error: TFORM is a blank string
        status=261
        call ftpmsg('The TFORM keyword has a blank value.')
        return
 
10      continue
 
C       now the chararcter at position c1 should be the data type code
        dattyp=form(c1:c1)
 
C       set the numeric datatype code
        if (dattyp .eq. 'I')then
                dtype=41
        else if (dattyp .eq. 'E')then
                dtype=42
        else if (dattyp .eq. 'F')then
                dtype=42
        else if (dattyp .eq. 'D')then
                dtype=82
        else if (dattyp .eq. 'A')then
                dtype=16
        else
C               unknown tform datatype code
                status=262
                call ftpmsg('Unknown ASCII table TFORMn keyword '//
     &                      'datatype: '//cform)
                return
        end if
 
C       determine the field width
        c1=c1+1
        nw=0
        do 40 i=c1,nc
            if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then
                    nw=nw+1
            else
                    go to 50
            end if
40      continue
50      continue
        if (nw .eq. 0)then
C               error, no width specified
                go to 990
        else
                call ftc2ii(form(c1:c1+nw-1),width,status)
                if (status .gt. 0 .or. width .eq. 0)then
C                      unrecognized characters following the type code
                       go to 990
                end if
        end if
 
C       determine the number of decimal places (if any)
        decims=-1
        c1=c1+nw
        if (form(c1:c1) .eq. '.')then
            c1=c1+1
            nw=0
            do 60 i=c1,nc
                if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then
                    nw=nw+1
                else
                    go to 70
            end if
60          continue
70          continue
 
            if (nw .eq. 0)then
C               error, no decimals specified
                go to 990
            else
                call ftc2ii(form(c1:c1+nw-1),decims,status)
                if (status .gt. 0)then
C                   unrecognized characters
                    go to 990
                end if
            end if
        else if (form(c1:c1) .ne. ' ')then
            go to 990
        end if
 
C       consistency checks
        if (dattyp .eq. 'A' .or. dattyp .eq. 'I')then
            if (decims .eq. -1)then
                decims=0
            else
                go to 990
            end if
        else if (decims .eq. -1)then
C           number of decmal places must be specified for D, E, or F fields
            go to 990
        else if (decims .ge. width)then
C           number of decimals must be less than the width
            go to 990
        end if
 
        if (dattyp .eq. 'I')then
C           set datatype to SHORT integer if 4 digits or less
            if (width .le. 4)dtype=21
        else if (dattyp .eq. 'F')then
C           set datatype to DOUBLE if 8 digits or more
            if (width .ge. 8)dtype=82
        end if
 
        return
 
990     continue
        status=261
        call ftpmsg('Illegal ASCII table TFORMn keyword: '//cform)
        end
        subroutine ftbdef(ounit,nfield,tform,pcount,nrows,status)
 
C       Binary table data DEFinition
C       define the structure of the binary table data unit
C
C       ounit   i  Fortran I/O unit number
C       nfield  i  number of fields in the table
C       tform   C  the data format of the column
C       nrows   i  number of rows in the table
C       pcount  i  size in bytes of the special data block following the table
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,nfield,nrows,pcount,status
        character*(*) tform(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,j,width
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
        if (dtstrt(ibuff) .lt. 0)then
C               freeze the header at its current size
                call fthdef(ounit,0,status)
                if (status .gt. 0)return
        end if
 
        hdutyp(ibuff)=2
        tfield(ibuff)=nfield
 
        if (nxtfld + nfield .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
                return
        end if
 
        tstart(ibuff)=nxtfld
        nxtfld=nxtfld+nfield
 
        if (nfield .eq. 0)then
C           no data; the next HDU begins in the next logical block
            hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff)
            heapsz(ibuff)=0
            theap(ibuff)=0
        else
C           initialize the table column parameters
            do 5 i=1,nfield
                tscale(i+tstart(ibuff))=1.
                tzero(i+tstart(ibuff))=0.
C               choose special value to indicate that null value is not defined
                tnull(i+tstart(ibuff))=123454321
C               reset character NUL string, in case it has been
C               previously defined from an ASCII table extension
                cnull(i+tstart(ibuff))=char(0)
 
C               parse the tform strings to get the data type and repeat count
                call ftbnfm(tform(i),tdtype(i+tstart(ibuff)),
     &                      trept(i+tstart(ibuff)),width,status)
                if (tdtype(i+tstart(ibuff)) .eq. 1)then
C                  treat Bit datatype as if it were a Byte datatype
                   tdtype(i+tstart(ibuff))=11
                   trept(i+tstart(ibuff))=(trept(i+tstart(ibuff))+7)/8
                else if (tdtype(i+tstart(ibuff)) .eq. 16)then
C                       store ASCII unit string length in TNULL parameter
                        tnull(i+tstart(ibuff))=width
                end if
                if (status .gt. 0)return
5           continue
 
C           determine byte offset of the beginning of each field and row length
            call ftgtbc(nfield,tdtype(1+tstart(ibuff)),trept(1+
     &           tstart(ibuff)),tbcol(1+tstart(ibuff)),rowlen(ibuff),
     &                  status)
 
C           FITSIO deals with ASCII columns as arrays of strings, not
C           arrays of characters, so need to change the repeat count
C           to indicate the number of strings in the field, not the
C           total number of characters in the field.
            do 10 i=1,nfield
                if (tdtype(i+tstart(ibuff)) .eq. 16)then
                    j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff))
                    trept(i+tstart(ibuff))=max(j,1)
                end if
10          continue
 
C           initialize the heap offset (=nrows x ncolumns)
C           set initial size of the special data area = 0;
C           update keyword with the correct final value when the HDU is closed
            heapsz(ibuff)=0
            theap(ibuff)=nrows*rowlen(ibuff)
 
C           calculate the start of the next header unit, based on the
C           size of the data unit (table + special data)
            hdstrt(ibuff,chdu(ibuff)+1)=
     &       dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcount+2879)/2880*2880
        end if
        end
        subroutine ftbini(iunit,status)
 
C       initialize the parameters defining the structure of a binary table
 
C       iunit   i  Fortran I/O unit number
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer lenrow,nrows,pcnt,tfld,nkey,ibuff,i,j,nblank
        character keynam*8,value*70,comm*72,cnaxis*8,clen*8,rec*80
        character nulchr*16
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       store the type of HDU (2 = Binary table extension)
        hdutyp(ibuff)=2
 
C       temporarily set the location of the end of the header to a huge number
        hdend(ibuff)=2000000000
        hdstrt(ibuff,chdu(ibuff)+1)=2000000000
 
C       check that this is a valid binary table, and get parameters
        call ftgtbn(iunit,rowlen(ibuff),nrows,pcnt,tfld,status)
        if (status .gt. 0)go to 900
 
        if (tfld .gt. nf)then
C               arrays not dimensioned large enough for this many fields
                status=111
        call ftpmsg('This Binary table has too many fields '//
     & 'to be read with FITSIO (FTBINI).')
                go to 900
         end if
 
C       store the number of fields in the common block
        tfield(ibuff)=tfld
 
        if (nxtfld + tfld .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
                return
        end if
 
        tstart(ibuff)=nxtfld
        nxtfld=nxtfld+tfld
 
        do 3 i=1,16
                nulchr(i:i) = char(0)
3       continue
 
C       initialize the table field parameters
        do 5 i=1,tfld
                tscale(i+tstart(ibuff))=1.
                tzero(i+tstart(ibuff))=0.
                tnull(i+tstart(ibuff))=123454321
                tdtype(i+tstart(ibuff))=-9999
                trept(i+tstart(ibuff))=0
C               reset character NUL string, in case it has been previously
C               defined from an ASCII table extension
                cnull(i+tstart(ibuff))=nulchr
5       continue
 
C       initialize the default heap starting address (immediately following
C       the table data) and set the next empty heap address
C       PCOUNT specifies the amount of special data following the table
        heapsz(ibuff)=pcnt
        theap(ibuff)=rowlen(ibuff)*nrows
 
C       now read through the rest of the header looking for table column
C       definition keywords, and the END keyword.
 
        nkey=8
8       nblank=0
10      nkey=nkey+1
        call ftgrec(iunit,nkey,rec,status)
        if (status .eq. 107)then
C               if we hit the end of file, then set status = no END card found
                status=210
        call ftpmsg('Required END keyword not found in Binary table'//
     &  ' header (FTBINI).')
                go to 900
        else if (status .gt. 0)then
                go to 900
        end if
        keynam=rec(1:8)
        comm=rec(9:80)
 
        if (keynam(1:1) .eq. 'T')then
C               get the binary table parameter (if it is one)
                call ftpsvc(rec,value,comm,status)
                call ftgbtp(ibuff,keynam,value,status)
        else if (keynam .eq. ' ' .and. comm .eq. ' ')then
                nblank=nblank+1
                go to 10
        else if (keynam .eq. 'END')then
                go to 20
        end if
        go to 8
 
20      continue
 
C       test that all the required keywords were found
        do 25 i=1,tfld
            if (tdtype(i+tstart(ibuff)) .eq. -9999)then
                status=232
                call ftkeyn('TFORM',i,keynam,status)
                call ftpmsg('Required '//keynam//
     &                      ' keyword not found (FTAINI).')
                return
            end if
25      continue
 
C       now we know everything about the table; just fill in the parameters:
C       the 'END' record begins 80 bytes before the current position, ignoring
C       any trailing blank keywords just before the END keyword
        hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1)
 
C       the data unit begins at the beginning of the next logical block
        dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880
 
C       reset header pointer to the first keyword
        nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))
 
C       the next HDU begins in the next logical block after the data
        hdstrt(ibuff,chdu(ibuff)+1)=
     &  dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcnt+2879)/2880*2880
 
C       determine the byte offset of the beginning of each field and row length
        if (tfld .gt. 0)then
           call ftgtbc(tfld,tdtype(1+tstart(ibuff)),
     &     trept(1+tstart(ibuff)),tbcol(1+tstart(ibuff)),lenrow,status)
 
C          FITSIO deals with ASCII columns as arrays of strings, not
C          arrays of characters, so need to change the repeat count
C          to indicate the number of strings in the field, not the
C          total number of characters in the field.
           do 30 i=1,tfld
              if (tdtype(i+tstart(ibuff)) .eq. 16)then
C                avoid 'divide by zero' in case TFORMn = '0A'
                 if (tnull(i+tstart(ibuff)) .ne. 0)then
                    j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff))
                    trept(i+tstart(ibuff))=max(j,1)
                 end if
              end if
30         continue
           if (status .gt. 0)go to 900
 
C          check that the sum of the column widths = NAXIS2 value
           if (rowlen(ibuff) .ne. lenrow)then
                status=241
                write(cnaxis,1001)rowlen(ibuff)
                write(clen,1001)lenrow
1001            format(i8)
           call ftpmsg('NAXIS1 ='//cnaxis//' not equal'//
     &     ' to the sum of the column widths ='//clen//' (FTBINI).')
           end if
        end if
 
900     continue
        end
        subroutine ftbnfm(form,dtype,rcount,width,status)
 
C       'Binary Format'
C       parse the binary table column format to determine the data
C       type and the repeat count (and string width, if it is an ASCII field)
C
C       form    c  format string
C       OUTPUT PARAMETERS:
C       dattyp  i  datatype code
C       rcount  i  repeat count
C       width   i  if ASCII field, this is the width of the unit string
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) form
        integer dtype,rcount,width,status,tstat
        character dattyp*1,cform*16
        integer point,nc,c1,i,nw
 
        if (status .gt. 0)return
 
        cform=form
 
C       find first non-blank character
        nc=len(form)
        do 5 i=1,nc
                if (form(i:i) .ne. ' ')then
                        c1=i
                        go to 10
                end if
5       continue
 
C       error: TFORM is a blank string
        status=261
        call ftpmsg('The TFORM keyword has a blank value.')
        return
 
10      continue
 
C       find the size of the field repeat count, if present
        nw=0
        do 20 i=c1,nc
                if (form(i:i) .ge. '0' .and. form(i:i) .le. '9')then
                        nw=nw+1
                else
                        go to 30
                end if
20      continue
30      continue
        if (nw .eq. 0)then
C               no explicit repeat count, so assume a value of 1
                rcount=1
        else
                call ftc2ii(form(c1:c1+nw-1),rcount,status)
                if (status .gt. 0)then
                   call ftpmsg('Error in FTBNFM evaluating TFORM'
     &             //' repeat value: '//cform)
                   return
                 end if
        end if
 
        c1=c1+nw
 
C       see if this is a variable length pointer column (e.g., 'rPt'); if so,
C       then add 1 to the starting search position in the TFORM string
        if (form(c1:c1) .eq. 'P')then
                point=-1
                c1=c1+1
                rcount=1
        else
                point=1
        end if
 
C       now the chararcter at position c1 should be the data type code
        dattyp=form(c1:c1)
 
C       set the numeric datatype code
        if (dattyp .eq. 'I')then
                dtype=21
                width=2
        else if (dattyp .eq. 'J')then
                dtype=41
                width=4
        else if (dattyp .eq. 'E')then
                dtype=42
                width=4
        else if (dattyp .eq. 'D')then
                dtype=82
                width=8
        else if (dattyp .eq. 'A')then
                dtype=16
        else if (dattyp .eq. 'L')then
                dtype=14
                width=1
        else if (dattyp .eq. 'X')then
                dtype=1
                width=1
        else if (dattyp .eq. 'B')then
                dtype=11
                width=1
        else if (dattyp .eq. 'C')then
                dtype=83
                width=8
        else if (dattyp .eq. 'M')then
                dtype=163
                width=16
        else
C               unknown tform datatype code
                status=262
                call ftpmsg('Unknown Binary table TFORMn keyword '//
     &                      'datatype: '//cform)
                return
        end if
 
C       set dtype negative if this is a variable length field ('P')
        dtype=dtype*point
 
C       if this is an ASCII field, determine its width
        if (dtype .eq. 16)then
                c1=c1+1
                nw=0
                do 40 i=c1,nc
                    if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then
                        nw=nw+1
                else
                        go to 50
                end if
40              continue
50              continue
                if (nw .eq. 0)then
C                       no explicit width field, so assume that the
C                       width is the same as the repeat count
                        width=rcount
                else
                        tstat=status
                        call ftc2ii(form(c1:c1+nw-1),width,status)
                        if (status .gt. 0)then
C                       unrecognized characters following the 'A', so ignore it
                               width=rcount
                               status=tstat
                        end if
                end if
        end if
        end
        subroutine ftc2d(cval,dval,status)
C       convert a character string to a double precision value
C       perform datatype conversion, if required
 
        character*(*) cval
        integer ival,status
        character*1 dtype
        logical lval
        character*16 sval
        double precision dval
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')then
C               null value string
                status = 204
                return
        end if
 
C       convert string to its intrinsic data type
        call ftc2x(cval,dtype,ival,lval,sval,dval,status)
        if (status .gt. 0)return
 
        if (dtype .eq. 'F')then
C               no datatype conversion required, so just return
        else if (dtype .eq. 'I')then
C               convert from integer to double precision
                dval=ival
        else if (dtype .eq. 'L')then
C               need to convert from logical to double precision
                if (lval)then
                        dval=1.
                else
                        dval=0.
                end if
        else if (dtype .eq. 'C')then
C               can't convert a string to double precision, so return error
                dval=0
                status=406
                sval=cval
                call ftpmsg('Error in FTC2D evaluating this string '//
     &          'as a double value: '//sval)
        end if
        end
        subroutine ftc2dd(cval,val,status)
 
C       convert a character string to double prec.
C       (assumes that the input string is left justified)
C       cval    c  input character string to be converted
C       val     d  output value
C       status  i  output error status (0 = OK)
 
        character*(*) cval
        double precision val
        integer status,nleng
        character iform*8,sval*16
 
        if (status .gt. 0)return
 
C       find length of the input double character string
        nleng=index(cval,' ')-1
        if (nleng .eq. -1)nleng=len(cval)
 
C       construct the format statement to read the character string
        if (nleng .le. 9)then
                write(iform,1000)nleng
1000            format('(F',I1,'.0)')
        else
                write(iform,1001)nleng
1001            format('(F',I2,'.0)')
        end if
 
        read(cval,iform,err=900)val
        return
 
900     status=409
        sval=cval
        call ftpmsg('Error in FTC2DD evaluating this string '//
     &       'as a double: '//sval)
        end
        subroutine ftc2i(cval,ival,status)
C       convert a character string to an integer
C       perform datatype conversion, if required
 
        integer ival,status
        character*(*) cval
        character*1 dtype
        logical lval
        character sval*16
        double precision dval
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')then
C               null value string
                status = 204
                return
        end if
 
C       convert string to its intrinsic data type
        call ftc2x(cval,dtype,ival,lval,sval,dval,status)
        if (status .gt. 0)return
 
        if (dtype .eq. 'I')then
C               no datatype conversion required, so just return
        else if (dtype .eq. 'F')then
C               need to convert from floating point to integer
                ival=dval
        else if (dtype .eq. 'L')then
C               need to convert from logical to integer
                if (lval)then
                        ival=1
                else
                        ival=0
                end if
        else if (dtype .eq. 'C')then
C               can't convert a string to an integer, so return error
                ival=0
                status=403
                sval=cval
        call ftpmsg('Error in FTC2I evaluating this string as an '
     &  //'integer: '//sval)
        end if
        end
        subroutine ftc2ii(cval,ival,status)
C       convert a character string to an integer
C       (assumes that the input string is left justified)
 
        integer ival,status,nleng
        character*(*) cval
        character*8 iform
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')go to 900
 
C       find length of the input integer character string
        nleng=index(cval,' ')-1
        if (nleng .eq. -1)nleng=len(cval)
 
C       construct the format statement to read the character string
        if (nleng .le. 9)then
                write(iform,1000)nleng
1000            format('(I',I1,')')
        else
                write(iform,1001)nleng
1001            format('(I',I2,')')
        end if
 
        read(cval,iform,err=900)ival
        return
 
900     continue
C       work around for bug in the DEC Alpha VMS compiler
        if (cval(1:nleng) .eq. '-2147483648')then
                 ival=-2147483647 - 1
        else
                 status=407
        end if
        end
        subroutine ftc2l(cval,lval,status)
 
C       convert a character string to a logical value
C       perform datatype conversion, if required
 
        logical lval
        integer ival,status
        character*(*) cval
        character*1 dtype
        character sval*16
        double precision dval
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')then
C               null value string
                status = 204
                return
        end if
 
C       convert string to its intrinsic data type
        call ftc2x(cval,dtype,ival,lval,sval,dval,status)
        if (status .gt. 0)return
 
        if (dtype .ne. 'L')then
C              this is not a logical keyword, so return error
               status=404
               sval=cval
               call ftpmsg('Error in FTC2L evaluating this string '//
     &          'as a logical value: '//sval)
        end if
        end
        subroutine ftc2ll(cval,lval,status)
C       convert a character string to a logical value
C       (assumes that the input string is left justified)
        integer status
        logical lval
        character*(*) cval
 
        if (status .gt. 0)return
 
C       convert character string to logical
        if (cval(1:1) .eq.'T')then
                lval=.true.
        else
C               any other character is considered false
                lval=.false.
        end if
        end
        subroutine ftc2r(cval,rval,status)
C       convert a character string to a real value
C       perform datatype conversion, if required
 
        character*(*) cval
        real rval
        integer ival,status
        character*1 dtype
        logical lval
        character*16 sval
        double precision dval
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')then
C               null value string
                status = 204
                return
        end if
 
C       convert string to its intrinsic data type
        call ftc2x(cval,dtype,ival,lval,sval,dval,status)
        if (status .gt. 0)return
 
        if (dtype .eq. 'F')then
C               convert from double to single precision
                rval=dval
        else if (dtype .eq. 'I')then
C               convert from integer to real
                rval=ival
        else if (dtype .eq. 'L')then
C               need to convert from logical to real
                if (lval)then
                        rval=1.
                else
                        rval=0.
                end if
        else if (dtype .eq. 'C')then
C               can't convert a string to a real, so return error
                rval=0
                status=405
                sval=cval
                call ftpmsg('Error in FTC2R evaluating this string '//
     &          'as a real value: '//sval)
        end if
        end
        subroutine ftc2rr(cval,val,status)
 
C       convert a character string to a real value
C       (assumes that the input string is left justified)
C       cval    c  input character string to be converted
C       val     r  output value
C       status  i  output error status (0 = OK)
 
        character*(*) cval
        real val
        integer status,nleng
        character iform*8,sval*16
 
        if (status .gt. 0)return
 
        if (cval .eq. ' ')go to 900
 
C       find length of the input real character string
        nleng=index(cval,' ')-1
        if (nleng .eq. -1)nleng=len(cval)
 
C       construct the format statement to read the character string
        if (nleng .le. 9)then
                write(iform,1000)nleng
1000            format('(F',I1,'.0)')
        else
                write(iform,1001)nleng
1001            format('(F',I2,'.0)')
        end if
 
        read(cval,iform,err=900)val
        return
 
900     status=408
        sval=cval
        call ftpmsg('Error in FTC2RR evaluating this string '//
     &       'as a real: '//sval)
        end
        subroutine ftc2s(in,cval,status)
C       convert an input quoted string to an unquoted string
C
C       The first character of the input string must be a quote character (')
C       and at least one additional quote character must also be present in the
C       input string. This routine then simply outputs all the characters
C       between the first and last quote characters in the input string.
C
C       in      c  input quoted string
C       cval    c  output unquoted string
C       status  i  output error status (0=ok, 1=first quote missing,
C                  2=second quote character missing.
 
        character*(*) in,cval
        integer length,i,j,i2,status
        character*1 dtype
 
C       test for datatype
        call ftdtyp(in,dtype,status)
        if (status .gt. 0)return
        if (dtype .ne. 'C')then
C               do no conversion and just return the raw character string
                cval=in
        else
C               convert character string to unquoted string
 
C               find closing quote character
                length=len(in)
                i2=length-1
                do 10 i=length,2,-1
                        if (in(i:i) .eq. '''')go to 20
                        i2=i2-1
10              continue
20              continue
 
                if (i2 .eq. 0)then
C                       there was no closing quote character
                        status=205
            call ftpmsg('The following keyword value string has no '
     &      //'closing quote:')
            call ftpmsg(in)
                else if (i2 .eq. 1)then
C                       null string
                        cval=' '
                else
                        cval=in(2:i2)
 
C                       test for double single quote characters; if found,
C                       then  delete one of the quotes (FITS uses 2 single
C                       quote characters to represent a single quote)
                        i2=i2-2
                        do 30  i=1,i2
                            if (cval(i:i) .eq. '''')then
                                if (cval(i+1:i+1) .eq. '''')then
                                   do 40 j=i+1,i2
                                         cval(j:j)=cval(j+1:j+1)
40                                 continue
                                   cval(i2:i2)=' '
                                end if
                            end if
30                      continue
                end if
        end if
        end
        subroutine ftc2x(cval,dtype,ival,lval,sval,dval,status)
 
C       convert a character string into it intrinsic data type
 
C       cval  c  input character string to be converted
C       dtype c  returned intrinsic datatype of the string (I,L,C,F)
C
C       one of  the following values is returned, corresponding to the
C       value of dtype:
C               ival i integer value
C               lval l logical value
C               sval c string value
C               dval d double precision value
C       statue i returned error status
 
        character*(*) cval
        character*1 dtype
        integer ival,status
        logical lval
        character*(*) sval
        double precision dval
 
C       determine intrinsic datatype
        call ftdtyp(cval,dtype,status)
 
C       convert string into its intrinsic datatype
        if (dtype .eq. 'I')then
                call ftc2ii(cval,ival,status)
        else if (dtype .eq. 'F')then
                call ftc2dd(cval,dval,status)
        else if (dtype .eq. 'L')then
                call ftc2ll(cval,lval,status)
        else if (dtype .eq. 'C')then
                call ftc2s(cval,sval,status)
        end if
        end
        subroutine ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status)
 
C       delete a specified column by shifting the rows
 
C       iunit   i  Fortran I/O unit number
C       naxis1  i  width in bytes of existing table
C       naxis2  i  number of rows in the table
C       delbyt  i  how many bytes to delete in each row
C       fstbyt  i  byte position in the row to delete the bytes (0=row start)
C       status  i  returned error status (0=ok)
 
        integer iunit,naxis1,naxis2,delbyt,fstbyt,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,i1,i2,irow,newlen,nseg,nbytes,remain
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
        newlen=naxis1-delbyt
 
        if (newlen .le. 5760)then
C ***********************************************************************
C       CASE #1: optimal case where whole new row fits in the work buffer
C ***********************************************************************
            i1=fstbyt+1
            i2=i1+delbyt
            do 10 irow=1,naxis2-1
C               read the row to be shifted
                call ftgtbs(iunit,irow,i2,newlen,buff,status)
 
C               set row length to its new value
                rowlen(ibuff)=newlen
 
C               write the row in the new place
                call ftptbs(iunit,irow,i1,newlen,buff,status)
 
C               reset row length to its original value
                rowlen(ibuff)=naxis1
10          continue
 
C           now do the last row
            remain=naxis1-(fstbyt+delbyt)
            if (remain .gt. 0)then
C               read the row to be shifted
                call ftgtbs(iunit,naxis2,i2,remain,buff,status)
 
C               set row length to its new value
                rowlen(ibuff)=newlen
 
C               write the row in the new place
                call ftptbs(iunit,naxis2,i1,remain,buff,status)
 
C               reset row length to its original value
                rowlen(ibuff)=naxis1
            end if
        else
C ************************************************************************
C       CASE #2:  whole row doesn't fit in work buffer; move row in pieces
C ************************************************************************
            nseg=(newlen+5759)/5760
 
            do 40 irow=1,naxis2-1
                i1=fstbyt+1
                i2=i1+delbyt
                nbytes=newlen-(nseg-1)*5760
 
                do 30 i=1,nseg
C                   read the row to be shifted
                    call ftgtbs(iunit,irow,i2,nbytes,buff,status)
 
C                   set row length to its new value
                    rowlen(ibuff)=newlen
 
C                   write the row in the new place
                    call ftptbs(iunit,irow,i1,nbytes,buff,status)
 
C                   reset row length to its original value
                    rowlen(ibuff)=naxis1
 
                    i1=i1+nbytes
                    i2=i2+nbytes
                    nbytes=5760
30              continue
40          continue
 
C           now do the last row
            remain=naxis1-(fstbyt+delbyt)
            if (remain .gt. 0)then
                nseg=(remain+5759)/5760
                i1=fstbyt+1
                i2=i1+delbyt
                nbytes=remain-(nseg-1)*5760
 
                do 50 i=1,nseg
C                   read the row to be shifted
                    call ftgtbs(iunit,naxis2,i2,nbytes,buff,status)
 
C                   set row length to its new value
                    rowlen(ibuff)=newlen
 
C                   write the row in the new place
                    call ftptbs(iunit,naxis2,i1,nbytes,buff,status)
 
C                   reset row length to its original value
                    rowlen(ibuff)=naxis1
 
                    i1=i1+nbytes
                    i2=i2+nbytes
                    nbytes=5760
50              continue
            end if
        end if
        end
        subroutine ftcdfl(iunit,status)
 
C       Check Data Unit Fill values
C       Check that the data unit is correctly filled with zeros or blanks
C       from the end of the data to the end of the current FITS 2880 byte block
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1994
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nf = 3000)
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*2880 chbuff
        character*1 chfill,xdummy(29119)
        common/ftheap/chbuff,chfill,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,filpos,nfill,i
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check if the data unit is null
        if (theap(ibuff) .eq. 0)return
 
C       move to the beginning of the fill bytes
        filpos=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff)
        call ftmbyt(iunit,filpos,.true.,status)
 
C       get all the fill bytes
        nfill=(filpos+2879)/2880*2880-filpos
        if (nfill .eq. 0)return
 
        call ftgcbf(iunit,nfill,chbuff,status)
        if (status .gt. 0)then
           call ftpmsg('Error reading data unit fill bytes (FTCDFL).')
           return
        end if
 
C       set the correct fill value to be checked
        if (hdutyp(ibuff) .eq. 1)then
C              this is an ASCII table; should be filled with blanks
               chfill=char(32)
        else
               chfill=char(0)
        end if
 
C       check for all zeros or blanks
        do 10 i=1,nfill
            if (chbuff(i:i) .ne. chfill)then
                status=255
                if (hdutyp(ibuff) .eq. 1)then
                    call ftpmsg('Warning: remaining bytes following'//
     &              ' ASCII table data are not filled with blanks.')
                else
                    call ftpmsg('Warning: remaining bytes following'//
     &              ' data are not filled with zeros.')
                end if
                return
            end if
10      continue
        end
        subroutine ftchdu(iunit,status)
 
C       Close Header Data Unit
C       If we have write access to the file, then close the current HDU by:
C                 -padding remaining space in the header with blanks
C                 -writing the END keyword in the CHU
C                 -check the data fill values, and rewrite them if not correct
C                 -flushing the current buffer to disk
C                 -recover common block space containing column descriptors
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,pcount
        character*8 comm
 
C       ignore input status and close HDU regardless of input status value
 
        ibuff=bufnum(iunit)
C       check that unit number is valid (that file is actually opened)
        if (ibuff .eq. 0)then
           if (status .le. 0)status=101
           return
        end if
 
C       see if we have write access to this file
        if (wrmode(ibuff))then
 
C           if data has been written to heap, update the PCOUNT keyword
            if (heapsz(ibuff) .gt. 0)then
               call ftgkyj(iunit,'PCOUNT',pcount,comm,status)
               if (heapsz(ibuff) .gt. pcount)then
                 call ftmkyj(iunit,'PCOUNT',heapsz(ibuff),'&',status)
               end if
 
C              update the variable length TFORM values if necessary
               call ftuptf(iunit, status)
            end if
 
C           rewrite the header END card and the following blank fill, and
C           insure that the internal data structure matches the keywords
            call ftrdef(iunit,status)
 
C           write the correct data fill values, if they are not already correct
            call ftpdfl(iunit,status)
        end if
 
C       set current column name buffer as undefined
        call ftrsnm
 
C       flush the buffers holding data for this HDU
        call ftflsh(ibuff,status)
 
C       recover common block space containing column descriptors for this HDU
        call ftfrcl(iunit,status)
 
        if (status .gt. 0)then
            call ftpmsg('Error while closing current HDU (FTCHDU).')
        end if
        end
        subroutine ftchfl(iunit,status)
 
C       Check Header Fill values
C       Check that the header unit is correctly filled with blanks from the
C       END card to the end of the current FITS 2880-byte block
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1994
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,nblank,i,endpos
        character*80 rec
        logical gotend
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       calculate the number of blank keyword slots in the header
        endpos=hdend(ibuff)
        nblank=(dtstrt(ibuff)-endpos)/80
C       move the i/o pointer to the end of the header keywords
        call ftmbyt(iunit,endpos,.true.,status)
C       find the END card (there may be blank keywords perceeding it)
 
        gotend=.false.
        do 10 i=1,nblank
                call ftgcbf(iunit,80,rec,status)
                if (rec(1:8) .eq. 'END     ')then
                       if (gotend)then
C                          there is a duplicate END record
                           status=254
             call ftpmsg('Warning: Header fill area contains '//
     &       'duplicate END card:')
                       end if
                       gotend=.true.
                       if (rec(9:80) .ne. ' ')then
C                          END keyword has extra characters
                           status=253
            call ftpmsg('Warning: END keyword contains '//
     &      'extraneous non-blank characters:')
                       end if
                 else if (gotend)then
                       if (rec .ne. ' ')then
C                          The fill area contains extraneous characters
                           status=254
             call ftpmsg('Warning: Header fill area contains '//
     &       'extraneous non-blank characters:')
                        end if
                end if
 
                if (status .gt. 0)then
                           call ftpmsg(rec)
                           return
                end if
10      continue
        end
        subroutine ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status)
 
C       insert DELBYT bytes after byte fstbyt in every row of the table
 
C       iunit   i  Fortran I/O unit number
C       naxis1  i  width in bytes of existing table
C       naxis2  i  number of rows in the table
C       delbyt  i  how many bytes to insert in each row
C       fstbyt  i  byte position in the row to insert the bytes (0=row start)
C       status  i  returned error status (0=ok)
 
        integer iunit,naxis1,naxis2,delbyt,fstbyt,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,i1,irow,newlen,fbyte,nseg,nbytes
        character cfill*1
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       select appropriate fill value
        if (hdutyp(ibuff) .eq. 1)then
C           fill  header or ASCII table with space
            cfill=char(32)
        else
C           fill image or bintable data area with Null (0)
            cfill=char(0)
        end if
 
        newlen=naxis1+delbyt
 
        if (newlen .le. 5760)then
C ***********************************************************************
C       CASE #1: optimal case where whole new row fits in the work buffer
C ***********************************************************************
C           write the correct fill value into the buffer
            do 10 i=1,delbyt
                buff(i:i)=cfill
10          continue
            i1=delbyt+1
 
C           first move the trailing bytes (if any) in the last row
            fbyte=fstbyt+1
            nbytes=naxis1-fstbyt
            call ftgtbs(iunit,naxis2,fbyte,nbytes,buff(i1:),status)
 
C           set row length to its new value
            rowlen(ibuff)=newlen
 
C           write the row (with leading fill bytes) in the new place
            nbytes=nbytes+delbyt
            call ftptbs(iunit,naxis2,fbyte,nbytes,buff,status)
 
C           reset row length to its original value
            rowlen(ibuff)=naxis1
 
C           now move the rest of the rows
            do 20 irow=naxis2-1,1,-1
C               read the row to be shifted (work backwards through the table)
                call ftgtbs(iunit,irow,fbyte,naxis1,buff(i1:),status)
 
C               set row length to its new value
                rowlen(ibuff)=newlen
 
C               write the row (with the leading fill bytes) in the new place
                call ftptbs(iunit,irow,fbyte,newlen,buff,status)
 
C               reset row length to its original value
                rowlen(ibuff)=naxis1
20          continue
 
        else
C ************************************************************************
C       CASE #2:  whole row doesn't fit in work buffer; move row in pieces
C ************************************************************************
C           first copy the data, then go back and write fill into the new column
C           start by copying the trailing bytes (if any) in the last row
 
            nbytes=naxis1-fstbyt
            nseg=(nbytes+5759)/5760
            fbyte=(nseg-1)*5760+fstbyt+1
            nbytes=naxis1-fbyte+1
 
            do 25 i=1,nseg
                call ftgtbs(iunit,naxis2,fbyte,nbytes,buff,status)
 
C               set row length to its new value
                rowlen(ibuff)=newlen
 
C               write the row in the new place
                call ftptbs(iunit,naxis2,fbyte+delbyt,nbytes,
     &                      buff,status)
 
C               reset row length to its original value
                rowlen(ibuff)=naxis1
 
                fbyte=fbyte-5760
                nbytes=5760
25          continue
 
C           now move the rest of the rows
            nseg=(naxis1+5759)/5760
 
            do 40 irow=naxis2-1,1,-1
                fbyte=(nseg-1)*5760+fstbyt+1
                nbytes=naxis1-(nseg-1)*5760
                do 30 i=1,nseg
C                   read the row to be shifted (work backwards thru the table)
                    call ftgtbs(iunit,irow,fbyte,nbytes,buff,status)
 
C                   set row length to its new value
                    rowlen(ibuff)=newlen
 
C                   write the row in the new place
                    call ftptbs(iunit,irow,fbyte+delbyt,nbytes,
     &                          buff,status)
 
C                   reset row length to its original value
                    rowlen(ibuff)=naxis1
 
                    fbyte=fbyte-5760
                    nbytes=5760
30              continue
40          continue
 
C           now write the fill values into the new column
            nbytes=min(delbyt,5760)
            do 50 i=1,nbytes
                    buff(i:i)=cfill
50          continue
 
            nseg=(delbyt+5759)/5760
 
C           set row length to its new value
            rowlen(ibuff)=newlen
 
            do 70 irow=1,naxis2
                fbyte=fstbyt+1
                nbytes=delbyt-((nseg-1)*5760)
                do 60 i=1,nseg
C                   write the fill
                    call ftptbs(iunit,irow,fbyte,nbytes,buff,status)
                    fbyte=fbyte+nbytes
                    nbytes=5760
60              continue
70          continue
 
C           reset the rowlength
            rowlen(ibuff)=naxis1
        end if
        end
        subroutine ftclos(iunit,status)
 
C       close a FITS file that was previously opened with ftopen or ftinit
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, June 1991
 
        integer iunit,status
 
        logical keep
 
C       close the current HDU and pad the header with blanks
        call ftchdu(iunit,status)
 
C       don't attempt to close file if unit number is invalid
        if (status .ne. 101)then
C           close the file
            keep=.true.
            call ftclsx(iunit,keep,status)
        end if
        end
        subroutine ftclsx(iunit,keep,status)
 
C       low level routine to close a file
C
C       iunit   i  Fortran I/O unit number
C       keep    l  keep the file? (else delete it)
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, Aug 1992
 
        integer iunit,status
        logical keep
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        ibuff=bufnum(iunit)
 
        if (ibuff .eq. 0)return
 
C       reset file common block parameters
        bufnum(iunit)=0
        buflun(ibuff)=0
        wrmode(ibuff)=.false.
        currnt(ibuff)=0
        reclen(ibuff)=0
        bytnum(ibuff)=0
 
        if (keep)then
                close(iunit,err=900)
        else
                close(iunit,status='DELETE',err=900)
        end if
        return
 
900     continue
C       set error code, if it has not previous been set
        if (status .le. 0)status=110
        end
        subroutine ftcmps(templt,string,casesn,match,exact)
 
C       compare the template to the string and test if they match.
C       The strings are limited to 68 characters or less (the max. length
C       of a FITS string keyword value.  This routine reports whether
C       the two strings match and whether the match is exact or
C       involves wildcards.
 
C       this algorithm is very similar to the way unix filename wildcards
C       work except that this first treats a wild card as a literal character
C       when looking for a match.  If there is no literal match, then
C       it interpretes it as a wild card.  So the template 'AB*DE'
C       is considered to be an exact rather than a wild card match to
C       the string 'AB*DE'.  The '#' wild card in the template string will
C       match any consecutive string of decimal digits in the colname.
 
C       templt    C input template (may include ? or * wild cards)
C       string    C input string to be compared to template
C       casesn    L should comparison be case sensitive?
C       match     L (output) does the template match the string?
C       exact     L (output) are the strings an exact match (true) or
C                            is it a wildcard match (false)
 
C       written by Wm Pence, HEASARC/GSFC, December 1994
C       modified December 1995 to fix 2 bugs
C       modified Jan 1997 to support the # wild card
 
        character*(*) templt,string
        logical casesn,match,exact
        character*68 temp,str
        integer tlen,slen,t1,s1
 
        tlen=len(templt)
        slen=len(string)
        tlen=min(tlen,68)
        slen=min(slen,68)
 
        match=.false.
        exact=.true.
        temp=templt
        str=string
        if (.not. casesn)then
            call ftupch(temp)
            call ftupch(str)
        end if
 
C       check for exact match
        if (temp .eq. str)then
            match=.true.
            return
        end if
 
C       the strings are not identical, any match cannot be exact
        exact=.false.
 
        t1=1
        s1=1
10      continue
        if (t1 .gt. tlen .or. s1 .gt. slen)then
C           completely scanned one or both strings, so it must be a match
            match=.true.
            return
        end if
 
C       see if the characters in the 2 strings are an exact match
        if (temp(t1:t1) .eq. str(s1:s1) .or.
     &     (temp(t1:t1) .eq. '?' .and. str(s1:s1) .ne. ' ') )then
C           The '?' wild card matches anything except a blank
            s1=s1+1
            t1=t1+1
 
        else if (temp(t1:t1) .eq. '#' .and. (str(s1:s1) .le. '9'
     &      .and. str(s1:s1) .ge. '0' ))then
C           The '#' wild card matches any string of digits
            t1=t1+1
C           find the end of consecutive digits in the string
15          s1=s1+1
            if (str(s1:s1) .le. '9' .and. str(s1:s1) .ge. '0')go to 15
 
        else if (temp(t1:t1) .eq. '*')then
C           get next character from template and look for it in the string
            t1=t1+1
            if (t1 .gt. tlen .or. (temp(t1:t1) .eq. ' '))then
C               * is followed by a space, so a match is guaranteed
                match=.true.
                return
            end if
 
20          continue
            if (temp(t1:t1) .eq. str(s1:s1))then
C               found a matching character
                t1=t1+1
                s1=s1+1
            else
C               increment the string pointer and try again
                s1=s1+1
 
C               return if hit end of string and failed to find a match
                if (s1 .gt. slen)return
 
                go to 20
            end if
 
        else
C           match failed
            return
        end if
        go to 10
        end
        subroutine ftcmsg
 
C       clear the error message stack
        call ftxmsg(0,'dummy')
        end
        subroutine ftcopy (iunit,ounit,moreky,status)
 
C       copies the CHDU from IUNIT to the CHDU of OUNIT.
C       This will also reserve space in the header for MOREKY keywords
C       if MOREKY > 0.
 
C       iunit   i  fortran unit number of the input file to be copied
C       ounit   i  fortran unit number of the output file to be copied to
C       moreky  i  create space in header for this many more keywords
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Jan, 1992
 
        integer iunit,ounit,moreky,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,obuff,i,nkeys,nadd
        integer bitpix,naxis,naxes(99),pcount,gcount
        character hrec*80
        logical simple,extend
 
        if (status .gt. 0)return
 
        if (iunit .eq. ounit)then
                status=101
                return
        end if
 
        ibuff=bufnum(iunit)
        obuff=bufnum(ounit)
 
C       check that the output CHDU is empty
        call ftghsp(ounit,nkeys,nadd,status)
        if (nkeys .ne. 0)then
             call ftpmsg('Cannot copy HDU to a non-empty HDU')
             status = 201
             return
        end if
 
C       find out the number of keywords which exist in the input CHDU
        call ftghsp(iunit,nkeys,nadd,status)
 
C       copy the keywords one at a time to the output CHDU
        if ( (chdu(ibuff) .eq. 1 .and. chdu(obuff) .ne. 1) .or.
     &     (chdu(ibuff) .ne. 1 .and. chdu(obuff) .eq. 1) )then
C               copy primary array to image extension, or vise versa
 
C               copy the required keywords:
                simple=.true.
                call ftghpr(iunit,99,simple,bitpix,naxis,
     &          naxes,pcount,gcount,extend,status)
                if (status .gt. 0)return
                extend=.true.
                call ftphpr(ounit,simple,bitpix,naxis,
     &          naxes,pcount,gcount,extend,status)
                if (status .gt. 0)return
 
C               copy remaining keywords, excluding pcount, gcount and extend
                do 10 i=naxis+4,nkeys
                    call ftgrec(iunit,i,hrec,status)
                    if (hrec(1:8) .ne. 'PCOUNT  ' .and.
     &                  hrec(1:8) .ne. 'GCOUNT  ' .and.
     &                  hrec(1:8) .ne. 'EXTEND  ')then
                           call ftprec(ounit,hrec,status)
                    end if
10              continue
        else
C               just copy all the keys exactly from the input file to the output
                do 20 i=1,nkeys
                    call ftgrec(iunit,i,hrec,status)
                    call ftprec(ounit,hrec,status)
20              continue
        end if
 
C       reserve space for more keywords (if moreky > 0)
        call fthdef(ounit,moreky,status)
 
C       now ccopy the data from the input CHDU to the output CHDU
        call ftcpdt(iunit,ounit,status)
 
        end
        subroutine ftcpdt(iunit,ounit,status)
 
C       copies the data from the IUNIT CHDU to the data of the OUNIT CHDU.
C       This will overwrite any data already in the OUNIT CHDU.
 
C       iunit   i  fortran unit number of the input file to be copied
C       ounit   i  fortran unit number of the output file to be copied to
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Aug 1993
 
        integer iunit,ounit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        character*2880 cbuff
        character*1 xdummy(29120)
        common/ftheap/cbuff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,obuff,nblock,i
 
        if (status .gt. 0)return
 
        if (iunit .eq. ounit)then
                status=101
                return
        end if
 
        ibuff=bufnum(iunit)
        obuff=bufnum(ounit)
 
C       determine HDU structure as defined by keywords in output file
        call ftrdef(ounit,status)
 
C       Calculate the number of bytes to be copied.  By definition there
C       will be an integral number of 2880-byte logical blocks to be copied
        nblock=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880
 
        if (nblock .gt. 0)then
C           move to the beginning of the data in the input and output files
            call ftmbyt(iunit,dtstrt(ibuff),.false.,status)
            call ftmbyt(ounit,dtstrt(obuff),.true.,status)
 
C           now copy the data one block at a time
            do 30 i=1,nblock
                call ftgcbf(iunit,2880,cbuff,status)
                call ftpcbf(ounit,2880,cbuff,status)
30          continue
        end if
        end
        subroutine ftcrep(comm,comm1,repeat)
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
 
C       comm    c  input comment string
C       OUTPUT PARAMETERS:
C       comm1   c  output comment string, = COMM minus the last '&' character
C       repeat  l  true if the last character of COMM was the '&" character
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) comm,comm1
        logical repeat
        integer i,j
 
        repeat=.false.
        j=len(comm)
        do 10 i=j,1,-1
                if (comm(i:i) .ne. ' ')then
                        if (comm(i:i) .eq. '&')then
                                comm1=comm(1:i-1)
                                repeat=.true.
                        end if
                        return
                end if
10      continue
        end
        subroutine ftcrhd(iunit,status)
 
C       'CReate Header Data unit'
C       create, initialize, and move the i/o pointer to a new extension at
C       the end of the FITS file.
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
C       close the current HDU
        call ftchdu(iunit,status)
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check that we haven't exceeded the maximum allowed number of extensions
        if (maxhdu(ibuff)+1 .ge. ne)then
                status=301
                return
        end if
 
C       move to the end of the highest known extension
        call ftmbyt(iunit,hdstrt(ibuff,maxhdu(ibuff)+1),.true.,status)
 
C       initialize various parameters about the CHDU
        maxhdu(ibuff)=maxhdu(ibuff)+1
        chdu(ibuff)=maxhdu(ibuff)
        nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))
C       the logical location of the END record at the start of the header
        hdend(ibuff)=nxthdr(ibuff)
C       the data start location is undefined
        dtstrt(ibuff)=-2000000000
        end
        subroutine ftcsum(iunit,nrec,sum,status)
 
C       Calculate a 32-bit 1's complement checksum of the FITS 2880-byte blocks.
C       This Fortran algorithm is based on the C algorithm developed by Rob
C       Seaman at NOAO that was presented at the 1994 ADASS conference, to be
C       published in the Astronomical Society of the Pacific Conference Series.
 
C       This uses a 32-bit 1's complement checksum in which the overflow bits
C       are permuted back into the sum and therefore all bit positions are
C       sampled evenly.  In this Fortran version of the original C algorithm,
C       a double precision value (which has at least 48 bits of precision)
C       is used to accumulate the checksum because standard Fortran does not
C       support an unsigned integer datatype.
 
C       iunit   i  fortran unit number
C       nrec    i  number of FITS 2880-byte blocks to be summed
C       sum     d  check sum value (initialize to zero before first call)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Sept, 1994
 
        integer iunit,nrec,status,i,j,hibits,i4vals(720)
        double precision sum,word32
        parameter (word32=4.294967296D+09)
C       word32 is equal to 2**32
 
        if (status .gt. 0)return
 
C       Sum the specified number of FITS 2880-byte records.  This assumes that
C       the FITSIO file pointer points to the start of the records to be summed.
        do 30 j=1,nrec
 
C           read the record as 720 pixel I*4 vector (do byte swapping if needed)
            call ftgi4b(iunit,720,4,i4vals,status)
 
            do 10 i=1,720
                if (i4vals(i) .ge. 0)then
                        sum=sum+i4vals(i)
                else
C                       sign bit is set, so add the equalvalent unsigned value
                        sum=sum+(word32+i4vals(i))
                end if
10          continue
 
C           fold any overflow bits beyond 32 back into the word
20          hibits=sum/word32
            if (hibits .gt. 0)then
                sum=sum-(hibits*word32)+hibits
                go to 20
            end if
30      continue
        end
        subroutine ftd2e(val,dec,cval,vlen,status)
 
C       convert a double precision value to an E format character string
C       If it will fit, the value field will be 20 characters wide;
C       otherwise it will be expanded to up to 35 characters, left
C       justified.
C
C       val     d  input value to be converted
C       dec     i  number of decimal places to display in output string
C       cval    c  output character string
C       vlen    i  length of output string
C       status  i  output error status (0 = OK)
 
        double precision val
        integer dec,vlen,status
        character*35 cval,form*10
 
        vlen = 1
        if (status .gt. 0)return
 
        if (dec .ge. 1 .and. dec .le. 9)then
                vlen=20
                write(form,2000)dec
2000            format('(1pe20.',i1,')')
        else if (dec .ge. 10 .and. dec .le. 28)then
                if (val .lt. 0.)then
                    vlen=max(20,dec+7)
                else
                    vlen=max(20,dec+6)
                end if
                write(form,2001)vlen,dec
2001            format('(1pe',i2,'.',i2,')')
        else
C               illegal number of decimal places were specified
                status=411
                call ftpmsg('Error in FTR2E: number of decimal places '
     &                      //'is less than 1 or greater than 28.')
                return
        endif
 
        write(cval,form,err=900)val
        if (cval(1:1) .eq. '*')go to 900
        return
 
900     status=402
        call ftpmsg('Error in FTD2E converting double to En.m string.')
        end
        subroutine ftd2f(val,dec,cval,status)
 
C       convert double precision value to F20.* format character string
C       NOTE: some precision may be lost
C       val     d  input value to be converted
C       dec     i  number of decimal places to display in output string
C       cval    c  output character string
C       status  i  output error status (0 = OK)
 
        double precision val
        integer dec,status
        character*20 cval,form*8
 
        if (status .gt. 0)return
 
        if (dec .ge. 0 .and. dec .le. 9)then
                write(form,2000)dec
2000            format('(f20.',i1,')')
        else if (dec .ge. 10 .and. dec .lt.18)then
                write(form,2001)dec
2001            format('(f20.',i2,')')
        else
C               illegal number of decimal places were specified
                status=411
                call ftpmsg('Error in FTD2F: number of decimal places '
     &                      //'is less than 0 or greater than 18.')
                return
        endif
 
        write(cval,form,err=900)val
        if (cval(1:1) .eq. '*')go to 900
        return
900     status=402
        call ftpmsg('Error in FTD2F converting double to F20. string.')
        end
        subroutine ftdblk(ounit,nblock,hdrdat,status)
 
C       delete  2880-byte FITS blocks at the end of the current header or data
 
C       ounit   i  fortran output unit number
C       nblock  i  number of 2880-byte blocks to be deleted
C       hdrdat  i  delete space at end of header (0) or data (1)
C       status  i  returned error status (0=ok)
 
        integer ounit,nblock,hdrdat,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        character*2880 buff
        character*1 xdummy(29120)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,jpoint,i,tstat
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
C       get address of first block to be deleted/overwritten
        if (hdrdat .eq. 0)then
            jpoint=dtstrt(ibuff)-2880*nblock
        else
            jpoint=hdstrt(ibuff,chdu(ibuff)+1)-2880*nblock
        end if
 
C       move each block up, until we reach the end of file
10      continue
C           move to the read start position
            tstat=status
            call ftmbyt(ounit,jpoint+nblock*2880,.false.,status)
 
C           read one 2880-byte FITS logical record
            call ftgcbf(ounit,2880,buff,status)
 
C           check for end of file
            if (status .eq. 107)then
                status=tstat
                go to 20
            end if
 
C           move back to the write start postion
            call ftmbyt(ounit,jpoint,.false.,status)
 
C           write the 2880-byte FITS logical record
            call ftpcbf(ounit,2880,buff,status)
 
C           check for error
            if (status .gt. 0)then
                call ftpmsg('Error deleting FITS blocks (FTDBLK)')
                return
            end if
 
C           increment pointer to next block and loop back
            jpoint=jpoint+2880
            go to 10
20      continue
 
C       now fill the last nblock blocks with zeros;  initialize the  buffer
        do 30 i=1,2880
            buff(i:i)=char(0)
30      continue
 
C       move back to the write start postion
        call ftmbyt(ounit,jpoint,.false.,status)
 
C       write the 2880-byte block NBLOCK times.
        do 40 i=1,nblock
            call ftpcbf(ounit,2880,buff,status)
40      continue
 
        if (hdrdat .eq. 0)then
C           recalculate the starting location of the current data unit, if moved
            dtstrt(ibuff)=dtstrt(ibuff)-2880*nblock
        end if
 
C       recalculate the starting location of all subsequent HDUs
        do 50 i=chdu(ibuff)+1,maxhdu(ibuff)+1
            hdstrt(ibuff,i)=hdstrt(ibuff,i)-2880*nblock
50      continue
 
        if (status .gt. 0)then
            call ftpmsg('Error deleting FITS block(s) (FTDBLK)')
        end if
        end
        subroutine ftdcol(iunit,colnum,status)
 
C       delete a column from a table
 
C       iunit   i  Fortran I/O unit number
C       colnum  i  number of of the column to be deleted
C       status  i  returned error status (0=ok)
 
        integer iunit,colnum,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,typhdu,delbyt,fstbyt,sp,tflds,i
        integer naxis1,naxis2,size,freesp,nblock,tbc
        character comm*70,keynam*8
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       test that the CHDU is an ASCII table or BINTABLE
        typhdu=hdutyp(ibuff)
        if (typhdu .ne. 1 .and. typhdu .ne. 2)then
                status=235
                call ftpmsg('Can only delete column from TABLE '//
     &          'or BINTABLE extension (FTDCOL)')
                return
        end if
 
C       check if column number exists in the table
        tflds=tfield(ibuff)
        if (colnum .lt. 1 .or. colnum .gt. tflds)then
            status=302
            return
        end if
 
C       get the starting byte position of the column (=zero for first column)
        fstbyt=tbcol(colnum+tstart(ibuff))
 
C       find the width of the column
        if (typhdu .eq. 1)then
C           tnull is used to store the width of the ASCII column field
C           NOTE: ASCII columns may not be in physical order, or may overlap.
 
            delbyt=tnull(colnum+tstart(ibuff))
 
C           delete the space(s) between the columns, if there are any.
            if (colnum .lt. tflds)then
C               check for spaces between following column
                sp=tbcol(colnum+1+tstart(ibuff))-tbcol(colnum+
     &             tstart(ibuff))-delbyt
                if (sp .gt. 0)then
                    delbyt=delbyt+1
                end if
            else if (colnum .gt. 1)then
C               check for space between the last and next to last columns
                sp=tbcol(colnum+tstart(ibuff))-tbcol(colnum-1+
     &             tstart(ibuff))-tnull(colnum-1+tstart(ibuff))
                if (sp .gt. 0)then
                   delbyt=delbyt+1
                   fstbyt=fstbyt-1
                end if
            end if
        else
            if (colnum .lt. tflds)then
                delbyt=tbcol(colnum+1+tstart(ibuff))-
     &                 tbcol(colnum+tstart(ibuff))
            else
                delbyt=rowlen(ibuff)-tbcol(colnum+tstart(ibuff))
            end if
        end if
 
C       get current size of the table
        naxis1=rowlen(ibuff)
        call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
 
C       Calculate how many FITS blocks (2880 bytes) need to be deleted
        size=theap(ibuff)+heapsz(ibuff)
        freesp=(delbyt*naxis2) + ((size+2879)/2880)*2880 - size
        nblock=freesp/2880
 
C       shift each row up, deleting the desired column
        call ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status)
 
C       shift the heap up and update pointer to start of heap
        size=delbyt*naxis2
        call fthpup(iunit,size,status)
 
C       delete the needed number of new FITS blocks at the end of the HDU
        if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status)
 
        if (typhdu .eq. 1)then
C           adjust the TBCOL values of the remaining columns
            do 10 i=1,tflds
                call ftkeyn('TBCOL',i,keynam,status)
                call ftgkyj(iunit,keynam,tbc,comm,status)
                if (tbc .gt. fstbyt)then
                     tbc=tbc-delbyt
                     call ftmkyj(iunit,keynam,tbc,'&',status)
                end if
10          continue
        end if
 
C       update the mandatory keywords
        call ftmkyj(iunit,'TFIELDS',tflds-1,'&',status)
        call ftmkyj(iunit,'NAXIS1',naxis1-delbyt,'&',status)
 
C       delete the index keywords starting with 'T' associated with the
C       deleted column and subtract 1 from index of all higher keywords
        call ftkshf(iunit,colnum,tflds,-1,status)
 
C       parse the header to initialize the new table structure
        call ftrdef(iunit,status)
        end
        subroutine ftddef(ounit,bytlen,status)
 
C       Data DEFinition
C       re-define the length of the data unit
C       this simply redefines the start of the next HDU
C
C       ounit   i  Fortran I/O unit number
C       bytlen  i  new length of the data unit, in bytes
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,bytlen,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nf = 3000)
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
        if (dtstrt(ibuff) .lt. 0)then
C               freeze the header at its current size
                call fthdef(ounit,0,status)
        end if
 
        hdstrt(ibuff,chdu(ibuff)+1)=
     &          dtstrt(ibuff)+(bytlen+2879)/2880*2880
 
C       initialize the fictitious heap starting address (immediately following
C       the array data) and a zero length heap.  This is used to find the
C       end of the data when checking the fill values in the last block.
        heapsz(ibuff)=0
        theap(ibuff)=bytlen
        end
        subroutine ftdelt(iunit,status)
 
C       delete a FITS file that was previously opened with ftopen or ftinit
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, July 1994
 
        integer iunit,status,ibuff
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
C       ignore input status, and delete file regardless of status value
 
        ibuff=bufnum(iunit)
 
C       set current column name buffer as undefined
        call ftrsnm
 
C       flush the buffers holding data for this HDU
        call ftflsh(ibuff,status)
 
C       recover common block space containing column descriptors for this HDU
        call ftfrcl(iunit,status)
 
C       delete the file
        call ftclsx(iunit,.false.,status)
        end
        subroutine ftdhdu(ounit,typhdu,status)
 
C       delete the current HDU (as long as it is not the primary array)
 
C       ounit   i  fortran output unit number
C       typhdu  i  type of the new CHDU, after deleting the old CHDU
C       status  i  returned error status (0=ok)
 
        integer ounit,typhdu,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer i,ibuff,nhdu,nblock
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        nhdu=chdu(ibuff)
        if (nhdu .eq. 1)then
C            cannot delete the primary array
             status=301
             return
        end if
 
C       close the CHDU first, to flush buffers and free memory
        call ftchdu(ounit,status)
 
C       how many blocks to delete?
        nblock=(hdstrt(ibuff,nhdu+1)-hdstrt(ibuff,nhdu))/2880
        if (nblock .lt. 1)return
 
C       delete the blocks
        call ftdblk(ounit,nblock,1,status)
        if (status .gt. 0)return
 
C       decrement the number of HDUs in the file and their starting address
        do 10 i=nhdu+1,maxhdu(ibuff)
                hdstrt(ibuff,i)=hdstrt(ibuff,i+1)
10      continue
        maxhdu(ibuff)=maxhdu(ibuff)-1
 
C       try reinitializing the CHDU, if there is one
        call ftrhdu(ounit,typhdu,status)
        if (status .gt. 0)then
C            there is no HDU after the one we just deleted so move back one HDU
             status=0
             call ftcmsg
             call ftgext(ounit,nhdu-1,typhdu,status)
        end if
        end
        subroutine ftdkey(iunit,keynam,status)
 
C       delete a header keyword
C
C       iunit   i  fortran output unit number
C       keynam  c  keyword name    ( 8 characters, cols.  1- 8)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        character*(*) keynam
        integer iunit,status,tstat,i,lenval,nkeys,keypos
        character keybuf*80,strval*70,comm*8,value*70,bslash*1,kname*8
 
        if (status .gt. 0)return
 
C       have to use 2 \\'s because the SUN compiler treats 1 \ as an escape
        bslash='\\'
 
C       find the keyword to be deleted
        call ftgcrd(iunit,keynam,keybuf,status)
        if (status .eq. 202)then
            kname=keynam
            call ftpmsg('FTDKEY could not find the '//kname//
     &      ' keyword to be deleted.')
            return
        end if
 
C       get the position of the keyword in the header
        call ftghps(iunit,nkeys,keypos,status)
        keypos=keypos-1
 
C       get position of last character in value string to see if it is a \ or &
        if (status .gt. 0)return
        tstat=status
        call ftpsvc(keybuf,strval,comm,status)
        call ftc2s(strval,value,status)
        if (status .gt. 0)status=tstat
 
        lenval=1
        do 10 i=70,1,-1
                if (value(i:i) .ne. ' ')then
                        lenval=i
                        go to 20
                end if
10      continue
 
C       now delete this keyword
20      call ftdrec(iunit,keypos,status)
        if (status .gt. 0)return
 
C       test if this keyword was also continued
        if (value(lenval:lenval) .eq. bslash .or.
     &          value(lenval:lenval) .eq. '&')then
                call ftgnst(iunit,value,lenval,comm,status)
                if (lenval .gt. 0)go to 20
        end if
        end
        subroutine ftdrec(ounit,pos,status)
 
C       delete keyword record at position POS from header
C
C       ounit   i  fortran output unit number
C       pos     i  position of keyword to be deleted (1 = first keyword)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Jan 1995
 
        integer ounit,pos,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        character*80 keybuf,keytmp
        integer ibuff,i,j,nshift
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        if (pos .lt. 1 .or. pos .gt.
     &     (hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80)then
                status=203
                return
        end if
 
        nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80
 
C       calculate number of header records following the deleted record
        nshift=(hdend(ibuff)-nxthdr(ibuff))/80
 
C       go through header shifting each 80 byte record up one place to
C       fill in the gap created by the deleted keyword
        j=hdend(ibuff)
        keybuf=' '
        do 10 i=1,nshift
                j=j-80
C               read current record contents
                call ftmbyt(ounit,j,.false.,status)
                call ftgcbf(ounit,80,keytmp,status)
C               overwrite with new contents
                call ftmbyt(ounit,j,.false.,status)
                call ftpcbf(ounit,80,keybuf,status)
                keybuf=keytmp
10      continue
 
C       update end-of-header pointer
        hdend(ibuff)=hdend(ibuff)-80
 
100     continue
        end
        subroutine ftdrow(iunit,frow,nrows,status)
 
C       delete NROWS rows from a table, beginning with row FROW
 
C       iunit   i  Fortran I/O unit number
C       frow    i  first row number to be delete
C       nrows   i  number of rows to be deleted
C       status  i  returned error status (0=ok)
 
        integer iunit,frow,nrows,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,naxis1,naxis2,size,freesp,nblock,row
        character comm*8
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       test that the CHDU is an ASCII table or BINTABLE
        if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then
                status=235
                call ftpmsg('Can only delete rows from TABLE or '//
     &          'BINTABLE extension (FTDROW)')
                return
        end if
 
C       get current size of the table
        call ftgkyj(iunit,'NAXIS1',naxis1,comm,status)
        call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
 
        if (nrows .lt. 0)then
                 status=306
                 call ftpmsg('Cannot delete negative number of ' //
     &           'rows in the table (FTDROW)')
                 return
        else if (frow+nrows-1 .gt. naxis2)then
                 status=307
                 call ftpmsg('Specified number of rows to delete '
     &           //'exceeds number of rows in table (FTDROW)')
                 return
        else if (nrows .eq. 0)then
                 return
        else if (frow .gt. naxis2)then
                status=307
                call ftpmsg('First row to delete is greater'//
     &            ' than the number of rows in the table (FTDROW)')
                return
        else if (frow .le. 0)then
                status=307
                call ftpmsg('Delete starting row number is less '
     &          //'than 1 (FTDROW)')
                return
        end if
 
C       Calculate how many FITS blocks (2880 bytes) need to be deleted
        size=theap(ibuff)+heapsz(ibuff)
        freesp=((size+2879)/2880)*2880 - size + naxis1*nrows
        nblock=freesp/2880
 
C       shift the rows up
        row=frow+nrows
        call ftrwup(iunit,row,naxis2,nrows,status)
 
C       shift the heap up
        size=naxis1*nrows
        call fthpup(iunit,size,status)
 
        if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status)
 
C       update the NAXIS2 keyword
        naxis2=naxis2-nrows
        call ftmkyj(iunit,'NAXIS2',naxis2,'&',status)
        end
        subroutine ftdsum(string,complm,sum)
 
C       decode the 32 bit checksum
 
C       If complm=.true., then the complement of the sum will be decoded.
 
C       This Fortran algorithm is based on the C algorithm developed by Rob
C       Seaman at NOAO that was presented at the 1994 ADASS conference, to be
C       published in the Astronomical Society of the Pacific Conference Series.
C
C       sum     d  checksum value
C       complm  l  encode the complement of the sum?
C       string  c  output ASCII encoded check sum
C       sum     d  checksum value
C
C       written by Wm Pence, HEASARC/GSFC, May, 1995
 
        double precision sum,all32,word32,factor(4)
        character*16 string,tmpstr
        integer offset,i,j,k,temp,hibits
        logical complm
 
C       all32 equals a 32 bit unsigned integer with all bits set
C       word32 is equal to 2**32
        parameter (all32=4.294967295D+09)
        parameter (word32=4.294967296D+09)
 
C       ASCII 0 is the offset value
        parameter (offset=48)
 
        data factor/16777216.0D+00,65536.0D+00,256.0D+00,1.0D+00/
 
        sum=0
 
C       shift the characters 1 place to the left, since the FITS character
C       string value starts in column 12, which is not word aligned
        tmpstr(1:15)=string(2:16)
        tmpstr(16:16)=string(1:1)
 
C       convert characters from machine's native character coding sequence
C       to ASCII codes.   This only affects IBM mainframe computers
C       that do not use ASCII for the internal character representation.
C        call ftc2as(tmpstr,16)
 
C       substract the offset from each byte and interpret each 4 character
C       string as a 4-byte unsigned integer; sum the 4 integers
        k=0
        do 10 i=1,4
          do 20 j=1,4
            k=k+1
            temp=ichar(tmpstr(k:k))-offset
            sum=sum+temp*factor(j)
20        continue
10      continue
 
C       fold any overflow bits beyond 32 back into the word
30      hibits=sum/word32
        if (hibits .gt. 0)then
                sum=sum-(hibits*word32)+hibits
                go to 30
         end if
 
        if (complm)then
C           complement the 32-bit unsigned integer equivalent (flip every bit)
            sum=all32-sum
        end if
        end
        subroutine ftdtyp(value,dtype,status)
 
C       determine datatype of a FITS value field
C       This assumes value field conforms to FITS standards and may not
C          detect all invalid formats.
C       value   c  input value field from FITS header record only,
C                  (usually the value field is in columns 11-30 of record)
C                  The value string is left justified.
C       dtype   c  output type (C,L,I,F) for Character string, Logical,
C                    Integer, Floating point, respectively
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        character*(*)value,dtype
        integer status
 
        if (status .gt. 0)return
 
        dtype=' '
 
        if (value(1:1) .eq. '''')then
C               character string
                dtype='C'
        else if (value(1:1).eq.'T' .or. value(1:1).eq.'F')then
C               logical
                dtype='L'
        else if (index(value,'.') .gt. 0)then
C               floating point
                dtype='F'
        else
C               assume it must be an integer, since it isn't anything else
                dtype='I'
        end if
        end
        subroutine ftesum(sum,complm,string)
 
C       encode the 32 bit checksum by converting every
C       2 bits of each byte into an ASCII character (32 bit word encoded
C       as 16 character string).   Only ASCII letters and digits are used
C       to encode the values (no ASCII punctuation characters).
 
C       If complm=.true., then the complement of the sum will be encoded.
 
C       This Fortran algorithm is based on the C algorithm developed by Rob
C       Seaman at NOAO that was presented at the 1994 ADASS conference, to be
C       published in the Astronomical Society of the Pacific Conference Series.
C
C       sum     d  checksum value
C       complm  l  encode the complement of the sum?
C       string  c  output ASCII encoded check sum
C
C       written by Wm Pence, HEASARC/GSFC, Sept, 1994
 
        double precision sum,tmpsum,all32
        character*(*) string
        character tmpstr*16
        integer offset,exclud(13),nbyte(4),ch(4),i,j,k
        integer quot,remain,check,nc
        logical complm
 
C       all32 equals a 32 bit unsigned integer with all bits set
        parameter (all32=4.294967295D+09)
 
C       ASCII 0 is the offset value
        parameter (offset=48)
 
C       this is the list of ASCII punctutation characters to be excluded
        data exclud/58,59,60,61,62,63,64,91,92,93,94,95,96/
 
C       initialize input string (in case it is greater than 16 chars long)
        string = ' '
 
        if (complm)then
C           complement the 32-bit unsigned integer equivalent (flip every bit)
            tmpsum=all32-sum
        else
            tmpsum=sum
        end if
 
C       separate each 8-bit byte into separate integers
        nbyte(1)=tmpsum/16777216.
        tmpsum=tmpsum-nbyte(1)*16777216.
        nbyte(2)=tmpsum/65536.
        tmpsum=tmpsum-nbyte(2)*65536.
        nbyte(3)=tmpsum/256.
        nbyte(4)=tmpsum-nbyte(3)*256.
 
C       encode each 8-bit integer as 4-characters
        do 100 i=1,4
                quot=nbyte(i)/4+offset
                remain=nbyte(i) - (nbyte(i)/4*4)
                ch(1)=quot+remain
                ch(2)=quot
                ch(3)=quot
                ch(4)=quot
 
C               avoid ASCII punctuation characters by incrementing and
C               decrementing adjacent characters thus preserving checksum value
10              check=0
                    do 30 k=1,13
                        do 20 j=1,4,2
                           if (ch(j)   .eq. exclud(k) .or.
     &                         ch(j+1) .eq. exclud(k))then
                               ch(j)=ch(j)+1
                               ch(j+1)=ch(j+1)-1
                               check=1
                           end if
20                      continue
30                  continue
 
C               keep repeating, until all punctuation character are removed
                if (check .ne. 0)go to 10
 
C               convert the byte values to the equivalent ASCII characters
                do 40 j=0,3
                    nc=4*j+i
                    tmpstr(nc:nc)=char(ch(j+1))
40              continue
100     continue
 
C       shift the characters 1 place to the right, since the FITS character
C       string value starts in column 12, which is not word aligned
        string(1:1) =tmpstr(16:16)
        string(2:16)=tmpstr(1:15)
 
C       convert characters from ASCII codes to machine's native character
C       coding sequence.  (The string gets converted back to ASCII when it
C       is written to the FITS file). This only affects IBM mainframe computers
C       that do not use ASCII for the internal character representation.
C        call ftas2c(string,16)
        end
        subroutine ftfiou(iounit,status)
 
C       free specified logical unit number; if iounit=-1, then free all units
 
        integer iounit,status
 
        if (status .gt. 0)return
 
        call ftxiou(iounit,status)
        end
        subroutine ftflbl(pbuff)
 
C       initalize the common block buffer as efficiently as possible
C       with blanks (ASCII 32)
 
C       pbuff  i  number of the physical buffer to initialize
 
        integer pbuff
        integer pb
        parameter (pb = 20)
        character*2880 cbuff
        common /ftbuff/cbuff(pb)
 
        cbuff(pbuff) = ' '
 
        end
        subroutine ftflsh(lbuff,status)
 
C       flush any modified buffers associated with lbuff to disk.
C       Make the contents of the buffers undefined.
 
C       lbuff   i  logical buffer assocaiated with this file
C       status  i  output error status
 
        integer lbuff,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,pb
        parameter (nb = 20)
        parameter (pb = 20)
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ounit,rlen,i
 
C       ignore input status and flush buffers regardless of status value
 
        ounit=buflun(lbuff)
        rlen=reclen(lbuff)
 
C       find any buffer associated with this file
        do 10 i=1,maxbuf
            if (logbuf(i) .eq. lbuff)then
                if (modify(i))then
C                   write the modified buffer to disk
                    call ftwrit(ounit,recnum(i),rlen,i,status)
                    modify(i)=.false.
                end if
 
C               erase the association of this buffer with the file
                logbuf(i)=0
                recnum(i)=0
            end if
10      continue
        end
        subroutine ftflus(iunit,status)
 
C       Flush all the data in the current FITS file to disk
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, March, 1996
 
        integer iunit,extno,xtend,status
 
        if (status .gt. 0)return
 
C       get the current HDU number
        call ftghdn(iunit, extno)
 
C       close out the current HDU
        call ftchdu(iunit,status)
        if (status .gt. 0)then
            call ftpmsg('FTFLUS could not close the current HDU.')
            return
        end if
 
C       reopen the same HDU
        call ftgext(iunit,extno,xtend,status)
        if (status .gt. 0)then
            call ftpmsg('FTFLUS could not reopen the current HDU.')
            return
        end if
        end
        subroutine ftflzr(pbuff)
 
C       initalize the common block buffer as efficiently as possible
C       with zeros.  This routine should not be used on Cray computers.
 
C       pbuff  i  number of the physical buffer to initialize
 
        integer pbuff,i
        integer pb
        parameter (pb = 20)
        double precision buff
        common /ftbuff/buff(360,pb)
 
        do 10 i=1,360
                buff(i,pbuff)=0.
10      continue
        end
        subroutine ftfrcl(iunit,status)
 
C       free up space in the common blocks that contain descriptors to
C       the columns in the HDU that is being closed.  The various parameters
C       describing each table column (e.g., starting byte address, datatype,
C       tscale, tzero, etc.) are stored in 1-D arrays, and the tstart
C       parameter gives the starting element number in the arrays
C       for each unit number.  If a table is closed, then all the
C       descriptors for that table columns must be overwritten by
C       shifting any descriptors that follow it in the 1-D arrays to the left.
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC,May, 1995
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,n2shft,i,j1,j2
 
C       ignore input status and flush columns regardless of input status value
 
        ibuff=bufnum(iunit)
 
        if (status .eq. -999)then
C           just initialize the descriptors as undefined
            tstart(ibuff)=-1
        else if (tstart(ibuff) .lt. 0)then
C           descriptors are already undefined; just return
        else if (tfield(ibuff) .eq. 0)then
C           table had no columns so just reset pointers as undefined
            tstart(ibuff)=-1
            dtstrt(ibuff)=-2000000000
        else
C           calc number of descriptors to be shifted over the recovered space
            n2shft=nxtfld-(tstart(ibuff)+tfield(ibuff))
 
            if (n2shft .gt. 0)then
                j1=tstart(ibuff)
                j2=j1+tfield(ibuff)
                do 10 i=1,n2shft
C                   shift the descriptors
                    j1=j1+1
                    j2=j2+1
                    tbcol(j1)=tbcol(j2)
                    tdtype(j1)=tdtype(j2)
                    trept(j1)=trept(j2)
                    tscale(j1)=tscale(j2)
                    tzero(j1)=tzero(j2)
                    tnull(j1)=tnull(j2)
                    cnull(j1)=cnull(j2)
                    cform(j1)=cform(j2)
10              continue
            end if
 
C           update pointer to next vacant column discriptor location
            nxtfld=nxtfld-tfield(ibuff)
 
C           update starting pointer for other opened files
            do 20 i=1,nb
                if (tstart(i) .gt. tstart(ibuff))then
                    tstart(i)=tstart(i)-tfield(ibuff)
                end if
20          continue
 
C           set pointers for this unit as undefined
            tstart(ibuff)=-1
            dtstrt(ibuff)=-2000000000
        end if
        end
        subroutine ftg2db(ounit,group,nulval,dim1,nx,ny,
     &                    array,anyflg,status)
 
C       Read a 2-d image of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  c*1  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   c*1  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        character*1 array(dim1,*),nulval
        logical anyflg,ltemp
        integer fpixel,row
 
        anyflg=.false.
        fpixel=1
        do 10 row = 1,ny
                call ftgpvb(ounit,group,fpixel,nx,nulval,
     &              array(1,row),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftg2dd(ounit,group,nulval,dim1,nx,ny,
     &                    array,anyflg,status)
 
C       Read a 2-d image of r*8 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  d  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   d  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        double precision array(dim1,*),nulval
        logical anyflg,ltemp
        integer fpixel,row
 
        anyflg=.false.
        fpixel=1
        do 10 row = 1,ny
                call ftgpvd(ounit,group,fpixel,nx,nulval,
     &              array(1,row),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftg2de(ounit,group,nulval,dim1,nx,ny,
     &                    array,anyflg,status)
 
C       Read a 2-d image of real values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  r  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   r  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        real array(dim1,*),nulval
        logical anyflg,ltemp
        integer fpixel,row
 
        anyflg=.false.
        fpixel=1
        do 10 row = 1,ny
                call ftgpve(ounit,group,fpixel,nx,nulval,
     &              array(1,row),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftg2di(ounit,group,nulval,dim1,nx,ny,
     &                    array,anyflg,status)
 
C       Read a 2-d image of i*2 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  i*2  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   i*2  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        integer*2 array(dim1,*),nulval
        logical anyflg,ltemp
        integer fpixel,row
 
        anyflg=.false.
        fpixel=1
        do 10 row = 1,ny
                call ftgpvi(ounit,group,fpixel,nx,nulval,
     &              array(1,row),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftg2dj(ounit,group,nulval,dim1,nx,ny,
     &                    array,anyflg,status)
 
C       Read a 2-d image of i*4 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  i  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   i  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        integer array(dim1,*),nulval
        logical anyflg,ltemp
        integer fpixel,row
 
        anyflg=.false.
        fpixel=1
        do 10 row = 1,ny
                call ftgpvj(ounit,group,fpixel,nx,nulval,
     &              array(1,row),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz,
     &                    array,anyflg,status)
 
C       Read a 3-d cube of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  c*1  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   c*1  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        character*1 array(dim1,dim2,*),nulval
        logical anyflg,ltemp
        integer fpixel,row,band
 
        anyflg=.false.
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
                call ftgpvb(ounit,group,fpixel,nx,nulval,
     &              array(1,row,band),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
20      continue
        end
        subroutine ftg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz,
     &                    array,anyflg,status)
 
C       Read a 3-d cube of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  d  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   d  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        double precision array(dim1,dim2,*),nulval
        logical anyflg,ltemp
        integer fpixel,row,band
 
        anyflg=.false.
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
                call ftgpvd(ounit,group,fpixel,nx,nulval,
     &              array(1,row,band),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
20      continue
        end
        subroutine ftg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz,
     &                    array,anyflg,status)
 
C       Read a 3-d cube of real values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  r  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   r  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        real array(dim1,dim2,*),nulval
        logical anyflg,ltemp
        integer fpixel,row,band
 
        anyflg=.false.
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
                call ftgpve(ounit,group,fpixel,nx,nulval,
     &              array(1,row,band),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
20      continue
        end
        subroutine ftg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz,
     &                    array,anyflg,status)
 
C       Read a 3-d cube of i*2 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  i*2  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   i*2  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        integer*2 array(dim1,dim2,*),nulval
        logical anyflg,ltemp
        integer fpixel,row,band
 
        anyflg=.false.
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
                call ftgpvi(ounit,group,fpixel,nx,nulval,
     &              array(1,row,band),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
20      continue
        end
        subroutine ftg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz,
     &                    array,anyflg,status)
 
C       Read a 3-d cube of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       nulval  i  undefined pixels will be set to this value (unless = 0)
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   i  the array of values to be read
C       anyflg  l  set to true if any of the image pixels were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        integer array(dim1,dim2,*),nulval
        logical anyflg,ltemp
        integer fpixel,row,band
 
        anyflg=.false.
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
                call ftgpvj(ounit,group,fpixel,nx,nulval,
     &              array(1,row,band),ltemp,status)
                if (ltemp)anyflg=.true.
                fpixel=fpixel+nx
10      continue
20      continue
        end
        subroutine ftgabc(nfield,tform,space, rowlen,tbcol,status)
 
C       Get ASCII table Beginning Columns
C       determine the byte offset of the beginning of each field of a
C       ASCII table, and the total width of the table
 
C       nfield i  number of fields in the binary table
C       tform  c  array of FITS datatype codes of each column.
C                 must be left justified in the string variable
C       space  i  number of blank spaces to insert between each column
C       OUTPUT PARAMETERS:
C       rowlen i  total width of the table, in bytes
C       tbcol  i  beginning position of each column (first column begins at 1)
C       status i  returned error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1992
 
        integer nfield,space,rowlen,tbcol(*),status
        character*(*) tform(*)
        integer i,j,ival
 
        if (status .gt. 0)return
 
        rowlen=0
        do 100 i=1,nfield
                if (tform(i)(2:2) .eq. ' ')then
C                       no explicit width; assume width=1
                        ival=1
                else
C                       find the field width characters
                        j=2
10                      j=j+1
                        if (tform(i)(j:j) .eq. ' ' .or.
     &                      tform(i)(j:j) .eq. '.')then
C                           read the width
                            call ftc2ii(tform(i)(2:j-1),ival,status)
                        else
C                           keep looking for the end of the width field
                            go to 10
                        end if
                        tbcol(i)=rowlen+1
                        rowlen=rowlen+ival+space
                end if
100     continue
 
C       don't add space after the last field
        rowlen=rowlen-space
        end
        subroutine ftgacl(iunit,colnum,xtype,xbcol,xunit,xform,
     &        xscal,xzero,xnull,xdisp,status)
 
C       Get information about an Ascii CoLumn
C       returns the parameters which define the column
 
C       iunit   i  Fortran i/o unit number
C       colnum  i  number of the column (first column = 1)
C       xtype   c  name of the column
C       xbcol   i  starting character in the row of the column
C       xunit   c  physical units of the column
C       xform   c  Fortran-77 format of the column
C       xscal   d  scaling factor for the column values
C       xzero   d  scaling zero point for the column values
C       xnull   c  value used to represent undefined values in the column
C       xdisp   c  display format for the column (if different from xform
C       status  i  returned error status
 
        integer iunit,colnum,xbcol,status
        double precision xscal,xzero
        character*(*) xtype,xunit,xform,xnull,xdisp
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C       END OF COMMON BLOCK DEFINITIONS------------------------------------
 
        integer ibuff,nfound
 
        if (status .gt. 0)return
 
        if (colnum .lt. 1 .or. colnum .gt. 999)then
C               illegal column number
                status=302
                return
        end if
 
        ibuff=bufnum(iunit)
 
C       get the parameters which are stored in the common block
        xbcol=tbcol(colnum+tstart(ibuff))+1
        xform=cform(colnum+tstart(ibuff))
        xscal=tscale(colnum+tstart(ibuff))
        xzero=tzero(colnum+tstart(ibuff))
        xnull=cnull(colnum+tstart(ibuff))
 
C       read remaining values from the header keywords
        xtype=' '
        call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status)
        xunit=' '
        call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status)
        xdisp=' '
        call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status)
        end
        subroutine ftgatp(ibuff,keyin,valin,status)
 
C       Get ASCII Table Parameter
C       test if the keyword is one of the table column definition keywords
C       of an ASCII table. If so, decode it and update the value in the common
C       block
 
C       ibuff   i sequence number of the data buffer
C       keynam  c name of the keyword
C       valin   c value of the keyword
C       status  i returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ibuff,status
        character*(*) keyin,valin
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
C       nb = number of file buffers = max. number of FITS file opened at once
C       nf = maximum number of fields allowed in a table
        integer nf,nb
        parameter (nb = 20)
        parameter (nf = 3000)
 
C       tfield = number of fields in the table
C       tbcol = byte offset in the row of the beginning of the column
C       rowlen = length of one row of the table, in bytes
C       tdtype = integer code representing the datatype of the column
C       trept = the repeat count = number of data values/element in the column
C       tnull = the value used to represent an undefined value in the column
C       tscale = the scale factor for the column
C       tzero = the scaling zero point for the column
C       heapsz = the total size of the binary table heap (+ gap if any)
C       theap = the starting byte offset for the binary table heap, relative
C               to the start of the binary table data
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
 
C       cnull = character string representing nulls in character columns
C       cform = the Fortran format of the column
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer nfield,i,c2,bcol,tstat
        character tform*16,keynam*8,value*70
 
        if (status .gt. 0)return
 
        keynam=keyin
        value=valin
        tstat=status
 
        if (keynam(1:5) .eq. 'TFORM')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TFORMn keyword
                    status=tstat
                else
C                   get the TFORM character string, without quotes
                    call ftc2s(value,tform,status)
                    if (status .gt. 0)return
                    if  (tform(1:1) .ne. 'A' .and. tform(1:1) .ne. 'I'
     &              .and. tform(1:1) .ne. 'F' .and. tform(1:1) .ne. 'E'
     &              .and. tform(1:1) .ne. 'D')then
                        status=311
                     call ftpmsg('Illegal '//keynam//' format code: '
     &                           //tform)
                        return
                    end if
 
                    cform(nfield+tstart(ibuff))=tform
C                   set numeric data type code to indicate an ASCII table field
                    tdtype(nfield+tstart(ibuff))=16
C                   set the repeat count to 1
                    trept(nfield+tstart(ibuff))=1
C                   set the TNULL parameter to the width of the field:
                    c2=0
                    do 10 i=2,8
                        if (tform(i:i) .ge. '0' .and. tform(i:i)
     &                     .le. '9')then
                                c2=i
                        else
                                go to 20
                        end if
10                  continue
20                  continue
 
                    if (status .gt. 0)return
                    if (c2 .eq. 0)then
C                       no explicit field width, so assume width=1 character
                        tnull(nfield+tstart(ibuff))=1
                    else
                        call ftc2ii(tform(2:c2),tnull(nfield+
     &                              tstart(ibuff)),status)
                        if (status .gt. 0)then
C                               error parsing the TFORM value string
                                status=261
           call ftpmsg('Error parsing '//keynam//' field width: '
     &                  //tform)
                        end if
                    end if
                end if
        else if (keynam(1:5) .eq. 'TBCOL')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TBCOLn keyword
                    status=tstat
                else
C                   get the beginning column number
                    call ftc2ii(value,bcol,status)
                     if (status .gt. 0)then
                        call ftpmsg('Error reading value of '//keynam
     &                  //' as an integer: '//value)
                     else
                        tbcol(nfield+tstart(ibuff))=bcol-1
                     end if
                end if
        else if (keynam(1:5) .eq. 'TSCAL')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TSCALn keyword
                    status=tstat
                else
C                   get the scale factor
                    call ftc2dd(value,tscale(nfield+tstart(ibuff)),
     &                          status)
                    if (status .gt. 0)then
                         call ftpmsg('Error reading value of'//keynam
     &                //' as a Double: '//value)
                    end if
                end if
        else if (keynam(1:5) .eq. 'TZERO')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TZEROn keyword
                    status=tstat
                else
C                   get the scaling zero point
                    call ftc2dd(value,tzero(nfield+tstart(ibuff)),
     &                          status)
                    if (status .gt. 0)then
                         call ftpmsg('Error reading value of'//keynam
     &                //' as a Double: '//value)
                    end if
                end if
        else if (keynam(1:5) .eq. 'TNULL')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TNULLn keyword
                    status=tstat
                else
C                   get the Null value flag (character)
                    call ftc2s(value,cnull(nfield+tstart(ibuff)),status)
                    if (status .gt. 0)then
                         call ftpmsg('Error reading value of'//keynam
     &                //' as a character string: '//value)
                    end if
                end if
        end if
        end
        subroutine ftgbcl(iunit,colnum,xtype,xunit,dtype,rcount,
     &        xscal,xzero,xnull,xdisp,status)
 
C       Get information about a Binary table CoLumn
C       returns the parameters which define the column
 
C       iunit   i  Fortran i/o unit number
C       colnum  i  number of the column (first column = 1)
C       xtype   c  name of the column
C       xunit   c  physical units of the column
C       dtype   c  datatype of the column
C       rcount  i  repeat count of the column
C       xscal   d  scaling factor for the column values
C       xzero   d  scaling zero point for the column values
C       xnull   i  value used to represent undefined values in integer column
C       xdisp   c  display format for the column
C       status  i  returned error status
 
        integer iunit,colnum,rcount,xnull,status
        double precision xscal,xzero
        character*(*) xtype,xunit,dtype,xdisp
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS------------------------------------
 
        integer ibuff,nfound,tcode
        logical descrp
        character ctemp*2,fwide*4
 
        if (status .gt. 0)return
 
        if (colnum .lt. 1 .or. colnum .gt. 999)then
C               illegal column number
                status=302
                return
        end if
 
        ibuff=bufnum(iunit)
 
C       get the parameters which are stored in the common block
        rcount=trept(colnum+tstart(ibuff))
        xscal=tscale(colnum+tstart(ibuff))
        xzero=tzero(colnum+tstart(ibuff))
        xnull=tnull(colnum+tstart(ibuff))
 
C       translate the numeric data type code
        dtype=' '
        tcode=tdtype(colnum+tstart(ibuff))
        if (tcode .lt. 0)then
                descrp=.true.
                tcode=-tcode
        else
                descrp=.false.
        end if
 
        if (tcode .eq. 21)then
                dtype='I'
        else if (tcode .eq. 41)then
                dtype='J'
        else if (tcode .eq. 42)then
                dtype='E'
        else if (tcode .eq. 82)then
                dtype='D'
        else if (tcode .eq. 16)then
C               this is an ASCII field; width of field is stored in TNULL
                write(fwide,1000)tnull(colnum+tstart(ibuff))
1000            format(i4)
                if (tnull(colnum+tstart(ibuff)) .gt. 999)then
                    dtype='A'//fwide
                else if (tnull(colnum+tstart(ibuff)) .gt. 99)then
                    dtype='A'//fwide(2:4)
                else if (tnull(colnum+tstart(ibuff)) .gt. 9)then
                    dtype='A'//fwide(3:4)
                else if (tnull(colnum+tstart(ibuff)) .gt. 0)then
                    dtype='A'//fwide(4:4)
                else
                    dtype='A'
                end if
C               ASCII column don't have an integer null value
                xnull=0
        else if (tcode .eq. 14)then
                dtype='L'
        else if (tcode .eq. 1)then
                dtype='X'
        else if (tcode .eq. 11)then
                dtype='B'
        else if (tcode .eq. 83)then
                dtype='C'
        else if (tcode .eq. 163)then
                dtype='M'
        end if
 
        if (descrp)then
                ctemp='P'//dtype(1:1)
                dtype=ctemp
        end if
 
C       read remaining values from the header keywords
        xtype=' '
        call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status)
        xunit=' '
        call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status)
        xdisp=' '
        call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status)
        end
        subroutine ftgbit(buffer,log8)
 
C       decode the individual bits within the byte into an array of
C       logical values.  The corresponding logical value is set to
C       true if the bit is set to 1.
 
C       buffer  i  input integer containing the byte to be decoded
C       log8    l  output array of logical data values corresponding
C                  to the bits in the input buffer
C
C       written by Wm Pence, HEASARC/GSFC, May 1992
 
        integer buffer,tbuff
        logical log8(8)
 
        log8(1)=.false.
        log8(2)=.false.
        log8(3)=.false.
        log8(4)=.false.
        log8(5)=.false.
        log8(6)=.false.
        log8(7)=.false.
        log8(8)=.false.
 
C       test for special case: no bits are set
        if (buffer .eq. 0)return
 
C       This algorithm tests to see if each bit is set by testing
C       the numerical value of the byte, starting with the most significant
C       bit.  If the bit is set, then it is reset to zero before testing
C       the next most significant bit, and so on.
 
        tbuff=buffer
 
C       now decode the least significant byte
        if (tbuff .gt. 127)then
                log8(1)=.true.
                tbuff=tbuff-128
        end if
        if (tbuff .gt. 63)then
                log8(2)=.true.
                tbuff=tbuff-64
        end if
        if (tbuff .gt. 31)then
                log8(3)=.true.
                tbuff=tbuff-32
        end if
        if (tbuff .gt. 15)then
                log8(4)=.true.
                tbuff=tbuff-16
        end if
        if (tbuff .gt. 7)then
                log8(5)=.true.
                tbuff=tbuff-8
        end if
        if (tbuff .gt. 3)then
                log8(6)=.true.
                tbuff=tbuff-4
        end if
        if (tbuff .gt. 1)then
                log8(7)=.true.
                tbuff=tbuff-2
        end if
        if (tbuff .eq. 1)then
                log8(8)=.true.
        end if
        end
        subroutine ftgbnh(iunit,nrows,nfield,ttype,tform,tunit,
     &                    extnam,pcount,status)
 
C       OBSOLETE routine: should call ftghbn instead
 
        integer iunit,nrows,nfield,pcount,status
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
        call ftghbn(iunit,-1,nrows,nfield,ttype,tform,
     &                    tunit,extnam,pcount,status)
        end
        subroutine ftgbtp(ibuff,keyin,valin,status)
 
C       Get Binary Table Parameter
C       test if the keyword is one of the table column definition keywords
C       of a binary table. If so, decode it and update the values in the common
C       block
 
C       ibuff   i sequence number of the data buffer
C       keynam  c name of the keyword
C       valout  c value of the keyword
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ibuff,status,width
        character*(*) keyin,valin
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
C       nb = number of file buffers = max. number of FITS file opened at once
C       nf = maximum number of fields allowed in a table
        integer nf,nb
        parameter (nb = 20)
        parameter (nf = 3000)
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer nfield,tstat
        character tform*16,keynam*8,value*70
 
        if (status .gt. 0)return
        keynam=keyin
        value=valin
        tstat=status
 
        if (keynam(1:5) .eq. 'TFORM')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TFORMn keyword
                    status=tstat
                else
C                   get the TFORM character string, without quotes
                    call ftc2s(value,tform,status)
C                   get the datatype code and repeat count
                    call ftbnfm(tform,tdtype(nfield+tstart(ibuff)),
     &                 trept(nfield+tstart(ibuff)),width,status)
                    if (tdtype(nfield+tstart(ibuff)) .eq. 1)then
C                       treat Bit datatype as if it were a Byte datatype
                        tdtype(nfield+tstart(ibuff))=11
                        trept(nfield+tstart(ibuff))=(trept(nfield+
     &                  tstart(ibuff))+7)/8
                    else if (tdtype(nfield+tstart(ibuff)) .eq. 16)then
C                      store the width of the ASCII field in the TNULL parameter
                        tnull(nfield+tstart(ibuff))=width
                   end if
                end if
        else if (keynam(1:5) .eq. 'TSCAL')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TSCALn keyword
                    status=tstat
                else
C                   get the scale factor
                    call ftc2dd(value,tscale(nfield+tstart(ibuff)),
     &                          status)
                    if (status .gt. 0)then
                         call ftpmsg('Error reading value of'//keynam
     &                //' as a Double: '//value)
                    end if
                end if
        else if (keynam(1:5) .eq. 'TZERO')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TZEROn keyword
                    status=tstat
                else
C                   get the scaling zero point
                    call ftc2dd(value,tzero(nfield+tstart(ibuff)),
     &                          status)
                    if (status .gt. 0)then
                         call ftpmsg('Error reading value of'//keynam
     &                //' as a Double: '//value)
                    end if
                end if
        else if (keynam(1:5) .eq. 'TNULL')then
C               get the field number
                call ftc2ii(keynam(6:8),nfield,status)
                if (status .gt. 0)then
C                   this must not have been a TNULLn keyword
                    status=tstat
                else
C                   make sure this is not an ASCII column (the tnull
C                   variable is use to store the ASCII column width)
                    if (tdtype(nfield+tstart(ibuff)) .ne. 16)then
C                       get the Null value flag (Integer)
                        call ftc2ii(value,tnull(nfield+tstart(ibuff)),
     &                              status)
                        if (status .gt. 0)then
                            call ftpmsg('Error reading value of '//
     &                      keynam//' as an integer: '//value)
                        end if
                    end if
                end if
        else if (keynam(1:8) .eq. 'THEAP   ')then
C               get the heap offset value
                call ftc2ii(value,theap(ibuff),status)
                if (status .gt. 0)then
                        call ftpmsg('Error reading value of '//keynam
     &                  //' as an integer: '//value)
                end if
        end if
        end
        subroutine ftgcbf(iunit,nchar,array,status)
 
C       "Get Character BuFfer"
C       read NCHAR characters from the character buffer.
 
C       iunit   i  Fortran unit number for reading from disk
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
C       modified Feb 1995
 
        integer iunit,nchar,status
        character*(*) array
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer nleft,nbyt,lastb,in1,lbuff,pbuff,buflen,nrec,ios,i
 
        if (status .gt. 0)return
 
        if (nchar .lt. 0)then
C               error: negative number of bytes to read
                status=306
                return
        end if
 
        lbuff=bufnum(iunit)
        buflen=reclen(lbuff)
 
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
 
        nleft=nchar
        in1=1
 
C       find the number of remaining bytes that can be read from buffer
200     pbuff=currnt(lbuff)
        lastb=bytnum(lbuff)
        nbyt=min(nleft,buflen-lastb)
 
C       get characters from the physical buffer to the output string
        if (nbyt .gt. 0)then
 
            go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &      19,20)pbuff
 
C               if got here, then pbuff is out of range
                status=101
                return
 
1               array(in1:in1+nbyt-1)=b1(lastb+1:lastb+nbyt)
                go to 100
2               array(in1:in1+nbyt-1)=b2(lastb+1:lastb+nbyt)
                go to 100
3               array(in1:in1+nbyt-1)=b3(lastb+1:lastb+nbyt)
                go to 100
4               array(in1:in1+nbyt-1)=b4(lastb+1:lastb+nbyt)
                go to 100
 
C  The SUN F90 compiler gives a segmentation fault on the following
C  statement when executing testprog, while reading a complex (C) column
C  when using the Linux F90 routines (fitsf90_nag.f).
5               array(in1:in1+nbyt-1)=b5(lastb+1:lastb+nbyt)
                go to 100
6               array(in1:in1+nbyt-1)=b6(lastb+1:lastb+nbyt)
                go to 100
7               array(in1:in1+nbyt-1)=b7(lastb+1:lastb+nbyt)
                go to 100
8               array(in1:in1+nbyt-1)=b8(lastb+1:lastb+nbyt)
                go to 100
9               array(in1:in1+nbyt-1)=b9(lastb+1:lastb+nbyt)
                go to 100
10              array(in1:in1+nbyt-1)=b10(lastb+1:lastb+nbyt)
                go to 100
11              array(in1:in1+nbyt-1)=b11(lastb+1:lastb+nbyt)
                go to 100
12              array(in1:in1+nbyt-1)=b12(lastb+1:lastb+nbyt)
                go to 100
13              array(in1:in1+nbyt-1)=b13(lastb+1:lastb+nbyt)
                go to 100
14              array(in1:in1+nbyt-1)=b14(lastb+1:lastb+nbyt)
                go to 100
15              array(in1:in1+nbyt-1)=b15(lastb+1:lastb+nbyt)
                go to 100
16              array(in1:in1+nbyt-1)=b16(lastb+1:lastb+nbyt)
                go to 100
17              array(in1:in1+nbyt-1)=b17(lastb+1:lastb+nbyt)
                go to 100
18              array(in1:in1+nbyt-1)=b18(lastb+1:lastb+nbyt)
                go to 100
19              array(in1:in1+nbyt-1)=b19(lastb+1:lastb+nbyt)
                go to 100
20              array(in1:in1+nbyt-1)=b20(lastb+1:lastb+nbyt)
 
100         bytnum(lbuff)=bytnum(lbuff)+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if
 
C       process more bytes, if any
        if (nleft .gt. 0)then
          nrec=recnum(pbuff)+1
 
150       continue
 
          if (nleft .gt. buflen)then
C           read whole blocks directly from the FITS file by-passing buffers
 
C           test if desired record exists before trying to read it
            if (nrec + nleft/buflen - 1 .gt. maxrec(lbuff)) then
C               record doesn't exist, so return EOF error
                status=107
                return
            end if
 
C           check if record is already loaded in one of the physical buffers
C           must read it from buffer since it may have been modified
            do 120 i=1,maxbuf
               if (logbuf(i) .eq. lbuff .and. recnum(i) .eq. nrec)then
C                 found the desired record; don't have to read it
                  go to 170
               end if
120         continue
 
C           record not already loaded in buffer, so read it from disk
            read(iunit,rec=nrec,iostat=ios)array(in1:in1+buflen-1)
 
            if (ios .ne. 0)then
C               assume that this error indicates an end of file condition
                status=107
                return
            end if
 
            bytnum(lbuff)=bytnum(lbuff)+buflen
            in1=in1+buflen
            nleft=nleft-buflen
            nrec=nrec+1
            go to 150
          end if
 
C         load the next file record into a physical buffer
170       call ftldrc(iunit,nrec,.false.,status)
          if (status .gt. 0)return
          go to 200
        end if
        end
        subroutine ftgcbo(iunit,gsize,ngroup,offset,array,status)
 
C       "Get Character BuFfer with Offsets"
C       read characters from the character buffer.
 
C       iunit   i  Fortran output unit number
C       gsize   i  size of each group of bytes
C       ngroup  i  number of groups to read
C       offset  i  size of gap between groups
C       array   c  output character string
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996
 
        integer iunit,gsize,ngroup,offset,status
        character*(*) array
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer lbuff,pbuff,buflen,lastb,nleft,in1,nbyt
        integer i,bytno,record,oldrec,incre
 
        if (status .gt. 0)return
 
        lbuff =bufnum(iunit)
        buflen=reclen(lbuff)
        pbuff =currnt(lbuff)
        oldrec=recnum(pbuff)
C       lastb = position of last byte read from input buffer
        lastb =bytnum(lbuff)
        bytno =(oldrec-1) * buflen + lastb
C       in1   = position of first byte remaining in the input buffer
        in1   =1
        nbyt  =0
        incre =gsize+offset
 
        do 500 i=1,ngroup
 
C           nleft   = number of bytes left in the input buffer
            nleft=gsize
C           nbyt    = number of bytes to transfer from input to output
            nbyt=min(nleft,buflen-lastb)
            if (nbyt .eq. 0)go to 300
 
200         continue
C           get characters from the physical buffer to the output string
            go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &         19,20)pbuff
 
C               if got here, then pbuff is out of range
                status=101
                return
 
1               array(in1:in1+nbyt-1)=b1(lastb+1:lastb+nbyt)
                go to 100
2               array(in1:in1+nbyt-1)=b2(lastb+1:lastb+nbyt)
                go to 100
3               array(in1:in1+nbyt-1)=b3(lastb+1:lastb+nbyt)
                go to 100
4               array(in1:in1+nbyt-1)=b4(lastb+1:lastb+nbyt)
                go to 100
5               array(in1:in1+nbyt-1)=b5(lastb+1:lastb+nbyt)
                go to 100
6               array(in1:in1+nbyt-1)=b6(lastb+1:lastb+nbyt)
                go to 100
7               array(in1:in1+nbyt-1)=b7(lastb+1:lastb+nbyt)
                go to 100
8               array(in1:in1+nbyt-1)=b8(lastb+1:lastb+nbyt)
                go to 100
9               array(in1:in1+nbyt-1)=b9(lastb+1:lastb+nbyt)
                go to 100
10              array(in1:in1+nbyt-1)=b10(lastb+1:lastb+nbyt)
                go to 100
11              array(in1:in1+nbyt-1)=b11(lastb+1:lastb+nbyt)
                go to 100
12              array(in1:in1+nbyt-1)=b12(lastb+1:lastb+nbyt)
                go to 100
13              array(in1:in1+nbyt-1)=b13(lastb+1:lastb+nbyt)
                go to 100
14              array(in1:in1+nbyt-1)=b14(lastb+1:lastb+nbyt)
                go to 100
15              array(in1:in1+nbyt-1)=b15(lastb+1:lastb+nbyt)
                go to 100
16              array(in1:in1+nbyt-1)=b16(lastb+1:lastb+nbyt)
                go to 100
17              array(in1:in1+nbyt-1)=b17(lastb+1:lastb+nbyt)
                go to 100
18              array(in1:in1+nbyt-1)=b18(lastb+1:lastb+nbyt)
                go to 100
19              array(in1:in1+nbyt-1)=b19(lastb+1:lastb+nbyt)
                go to 100
20              array(in1:in1+nbyt-1)=b20(lastb+1:lastb+nbyt)
 
100         in1=in1+nbyt
            nleft=nleft-nbyt
 
C           process more bytes, if any
300         continue
            if (nleft .gt. 0)then
C               load the next file record into a physical buffer
                oldrec=oldrec+1
                call ftldrc(iunit,oldrec,.false.,status)
                if (status .gt. 0)return
                pbuff=currnt(lbuff)
                lastb=0
                nbyt=nleft
                go to 200
            end if
 
            if (i .ne. ngroup)then
C               move to the position of the next group
                bytno=bytno+incre
                record=bytno/buflen+1
                lastb=mod(bytno,buflen)
 
                if (record .ne. oldrec)then
C                   not the current record, so load the new record;
                    call ftldrc(iunit,record,.false.,status)
                    if (status .gt. 0)return
                    oldrec=record
                    pbuff=currnt(lbuff)
                end if
            end if
500     continue
 
        bytnum(lbuff)=lastb+nbyt
        end
        subroutine ftgcfb(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of byte values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   b  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        character*1 array(*),dummy
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgclb(iunit,colnum,frow,felem,nelem,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfc(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of complex values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   cmp  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        real array(*),dummy
        integer i
        integer felemx, nelemx
 
C       a complex value is interpreted as a pair of float values, thus
C       need to multiply the first element and number of elements by 2
 
        felemx = (felem - 1) * 2 + 1
        nelemx = nelem * 2
 
        do 10 i=1,nelemx
                flgval(i)=.false.
10      continue
 
        call ftgcle(iunit,colnum,frow,felemx,nelemx,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfd(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of r*8 values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   d  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        double precision array(*),dummy
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgcld(iunit,colnum,frow,felem,nelem,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfe(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of R*4 values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   r  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        real array(*),dummy
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgcle(iunit,colnum,frow,felem,nelem,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfi(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of I*2 values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   i*2 returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        integer*2 array(*),dummy
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgcli(iunit,colnum,frow,felem,nelem,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfj(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of I*4 values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   i  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        integer array(*),dummy,i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgclj(iunit,colnum,frow,felem,nelem,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfl(iunit,colnum,frow,felem,nelem,lray,
     &          flgval,anynul,status)
 
C       read an array of logical values from a specified column of the table.
C       The binary table column being read from must have datatype 'L'
C       and no datatype conversion will be perform if it is not.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       lray    l  returned array of data values that is read
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical lray(*),flgval(*),anynul
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,maxpix,tcode,offset
        integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart
        character*1 buffer(80)
        logical descrp
        character messge*80
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        tcode=tdtype(colnum+tstart(ibuff))
 
C       Do sanity check of input parameters
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        else if (nelem .eq. 0)then
          return
        end if
 
C       initialize the null flag array
        do 5 i=1,nelem
                flgval(i)=.false.
5       continue
        anynul=.false.
 
        i1=0
        ntodo=nelem
        rstart=frow-1
        estart=felem-1
        maxpix=80
 
        if (tcode .eq. 14)then
                repeat=trept(colnum+tstart(ibuff))
                if (felem .gt. repeat)then
C                   illegal element number
                    write(messge,1005)felem
1005                format(
     &       'Starting element number is greater than repeat: ',i10)
                    call ftpmsg(messge)
                    status = 308
                    return
                end if
                descrp=.false.
        else if (tcode .eq. -14)then
C               this is a variable length descriptor column
                descrp=.true.
C               read the number of elements and the starting offset:
                call ftgdes(iunit,colnum,frow,repeat,
     &                              offset,status)
                if (repeat .eq. 0)then
C                       error: null length vector
                        status=318
                        return
                else if (estart+ntodo .gt. repeat)then
C                       error: trying to read beyond end of record
                        status=319
                        return
                end if
C               move the i/o pointer to the start of the pixel sequence
                bstart=dtstrt(ibuff)+offset+
     &                          theap(ibuff)+estart
                call ftmbyt(iunit,bstart,.true.,status)
        else
C               column must be logical data type
                status=312
                return
        end if
 
C       process as many contiguous pixels as possible
20      itodo=min(ntodo,repeat-estart,maxpix)
 
        if (.not. descrp)then
C           move the i/o pointer to the start of the sequence of pixels
            bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &             tbcol(colnum+tstart(ibuff))+estart
            call ftmbyt(iunit,bstart,.false.,status)
        end if
 
C       get the array of logical bytes
        call ftgcbf(iunit,itodo,buffer,status)
        if (status .gt. 0)return
 
C       decode the 'T' and 'F' characters, and look for nulls (0)
        do 10 i=1,itodo
                if (buffer(i) .eq. 'T')then
                        lray(i1+i)=.true.
                else if (buffer(i) .eq. 'F')then
                        lray(i1+i)=.false.
                else if (ichar(buffer(i)) .eq. 0)then
                        flgval(i1+i)=.true.
                        anynul=.true.
                else
                        status=316
                        return
                end if
10      continue
 
        if (status .gt. 0)then
            write(messge,1006)i1+1,i1+itodo
1006        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCFL).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                        estart=0
                        rstart=rstart+1
                end if
                go to 20
        end if
        end
        subroutine ftgcfm(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of double precision complex values from a specified
C       column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       array   dcmp  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        double precision array(*),dummy
        integer i
        integer felemx, nelemx
 
C       a complex value is interpreted as a pair of float values, thus
C       need to multiply the first element and number of elements by 2
 
        felemx = (felem - 1) * 2 + 1
        nelemx = nelem * 2
 
        do 10 i=1,nelemx
                flgval(i)=.false.
10      continue
 
        call ftgcld(iunit,colnum,frow,felemx,nelemx,1,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcfs(iunit,colnum,frow,felem,nelem,array,
     &          flgval,anynul,status)
 
C       read an array of string values from a specified column of the table.
C       Any undefined pixels will be have the corresponding value of FLGVAL
C       set equal to .true., and ANYNUL will be set equal to .true. if
C       any pixels are undefined.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element in the row to read
C       nelem   i  number of elements to read
C       array   c  returned array of data values that was read from FITS file
C       flgval  l  set .true. if corresponding element undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval(*),anynul
        character*(*) array(*)
        character*8 dummy
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
        call ftgcls(iunit,colnum,frow,felem,nelem,2,dummy,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcks(iunit,datsum,chksum,status)
 
C       calculate and encode the checksums of the data unit and the total HDU
 
C       iunit   i  fortran unit number
C       datsum  d  output  checksum for the data
C       chksum  d  output  checksum for the entire HDU
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Sept, 1994
 
        integer iunit,status
        double precision datsum,chksum
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,nrec
 
        if (status .gt. 0)return
 
C       calculate number of data records
        ibuff=bufnum(iunit)
        nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880
 
        datsum=0.
        if (nrec .gt. 0)then
 
C           move to the start of the data
            call ftmbyt(iunit,dtstrt(ibuff),.true.,status)
 
C           accumulate the 32-bit 1's complement checksum
            call ftcsum(iunit,nrec,datsum,status)
        end if
 
C       move to the start of the header
        call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status)
 
C       calculate number of FITS blocks in the header
        nrec=(dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880
 
C       accumulate the header into the checksum
        chksum=datsum
        call ftcsum(iunit,nrec,chksum,status)
        end
        subroutine ftgcl(iunit,colnum,frow,felem,nelem,lray,status)
 
C       read an array of logical values from a specified column of the table.
C       The binary table column being read from must have datatype 'L'
C       and no datatype conversion will be perform if it is not.
C       This routine ignores any undefined values in the logical array.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       lray    l  returned array of data values that is read
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical lray(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*1 buffer(32000)
        common/ftheap/buffer
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,maxpix,offset,tcode
        integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart
        logical descrp
        character messge*80
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        tcode=tdtype(colnum+tstart(ibuff))
 
C       Do sanity check of input parameters
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        else if (nelem .eq. 0)then
          return
        end if
 
        i1=0
        ntodo=nelem
        rstart=frow-1
        estart=felem-1
        maxpix=32000
 
        if (tcode .eq. 14)then
                repeat=trept(colnum+tstart(ibuff))
                if (felem .gt. repeat)then
C                   illegal element number
                    write(messge,1005)felem
1005                format(
     &       'Starting element number is greater than repeat: ',i10)
                    call ftpmsg(messge)
                    status = 308
                    return
                end if
                descrp=.false.
        else if (tcode .eq. -14)then
C               this is a variable length descriptor column
                descrp=.true.
C               read the number of elements and the starting offset:
                call ftgdes(iunit,colnum,frow,repeat,
     &                              offset,status)
                if (repeat .eq. 0)then
C                       error: null length vector
                        status=318
                        return
                else if (estart+ntodo .gt. repeat)then
C                       error: trying to read beyond end of record
                        status=319
                        return
                end if
C               move the i/o pointer to the start of the pixel sequence
                bstart=dtstrt(ibuff)+offset+
     &                          theap(ibuff)+estart
                call ftmbyt(iunit,bstart,.true.,status)
        else
C               column must be logical data type
                status=312
                return
        end if
 
C       process as many contiguous pixels as possible
20      itodo=min(ntodo,repeat-estart,maxpix)
 
        if (.not. descrp)then
C           move the i/o pointer to the start of the sequence of pixels
            bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &      tbcol(colnum+tstart(ibuff))+estart
            call ftmbyt(iunit,bstart,.false.,status)
        end if
 
C       get the array of logical bytes
        call ftgcbf(iunit,itodo,buffer,status)
 
C       decode the 'T' and 'F' characters,
        do 10 i=1,itodo
                if (buffer(i) .eq. 'T')then
                        lray(i1+i)=.true.
                else if (buffer(i) .eq. 'F')then
                        lray(i1+i)=.false.
                else if (ichar(buffer(i)) .eq. 0)then
C                       ignore null values; leave input logical value unchanged
                else
C                       illegal logical value
                        status=316
                        return
                end if
10      continue
 
        if (status .gt. 0)then
            write(messge,1006)i1+1,i1+itodo
1006        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCL).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                        estart=0
                        rstart=rstart+1
                end if
                go to 20
        end if
        end
        subroutine ftgclb(iunit,colnum,frow,felem,nelem,eincr,
     &   nultyp,nulval,array,flgval,anynul,status)
 
C       read an array of byte data values from the specified column of
C       the table.
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       eincr   i  element increment
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  b  value that undefined pixels will be set to (if nultyp=1)
C       array   b  array of data values that are read from the FITS file
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status
        character*1 array(*),nulval
        logical flgval(*),anynul
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer nulchk,i4null,rskip
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        logical tofits,trans
        integer*2 i2null
        character sval*30,sform*13,snull*16,i1null*1,messge*80
        integer buffer(8000)
        common/fttemp/buffer
 
        if (status .gt. 0)return
 
        call ftgcpr(iunit,colnum,frow,felem,nelem,0,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,i4null,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
C       multiply incre to just get every nth pixel
        incre = incre * eincr
 
C       determine if we have to check for null values
        nulchk = nultyp
        if (nultyp .eq. 1 .and. ichar(nulval) .eq. 0)then
C           user doesn't want to check for nulls
            nulchk=0
        else
C           user does want to check for null values
            if (tcode .le. 41)then
C               check if null value is defined for integer column
                if (i4null .eq. 123454321)then
                    nulchk=0
                else
                    if (tcode .eq. 11)then
                        i1null=char(i4null)
                    else if (tcode .eq. 21)then
                        i2null=i4null
                    end if
                end if
            end if
        end if
 
C       check for important special case: no datatype conversion required
        if (tcode .eq. 11 .and. nulchk .eq. 0 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
              trans=.false.
        else
              trans=.true.
        end if
 
        sval=' '
        i1=1
        ntodo=nelem
        rstart=0
        anynul=.false.
C       the data are being scaled from FITS to internal format
        tofits=.false.
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp+(rstart * lenrow) + (estart * incre / eincr)
        call ftmbyt(iunit,bstart,.false.,status)
 
C       read the data from FITS file, doing datatype conversion and scaling
        if (tcode .eq. 21)then
C               column data type is I (I*2)
C               read the data and do any machine dependent data conversion
                call ftgi2b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti2i1(buffer,itodo,scale,zero,tofits,
     &          nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
C               read the data and do any machine dependent data conversion
                call ftgi4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti4i1(buffer,itodo,scale,zero,tofits,
     &          nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
C               read the data and do any machine dependent data conversion
                call ftgr4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr4i1(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
C               read the data and do any machine dependent data conversion
                call ftgr8b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr8i1(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
C               read the data and do any machine dependent data conversion
C               note that we can use the input array directly
                call ftgi1b(iunit,itodo,incre,array(i1),status)
C               check for null values, and do scaling and datatype conversion
                if (trans)then
                  call fti1i1(array(i1),itodo,scale,zero,tofits,nulchk,
     &            i1null,nulval,flgval(i1),anynul,array(i1),status)
                end if
        else
C               this is an ASCII table column; get the character string
                call ftgcbf(iunit,twidth,sval,status)
                if (status .gt. 0)return
 
C               check for null value
                if (sval(1:16) .eq. snull)then
                    anynul=.true.
                    if (nultyp .eq. 1)then
                        array(i1)=nulval
                    else if (nultyp .eq. 2)then
                        flgval(i1)=.true.
                    end if
                else
C                   read the value, then do scaling and datatype conversion
                    if (sform(5:5) .eq. 'I')then
                        read(sval,sform,err=900)ival
                        dval=ival*scale+zero
                    else
                        read(sval,sform,err=900)dval
                        dval=dval*scale+zero
                    end if
 
C                   trap any values that overflow the I*1 range
                    if (dval .lt. 255.49 .and. dval .gt. -.49)then
                        array(i1)=char(int(dval))
                    else if (dval .ge. 255.49)then
                        status=-11
                        array(i1)=char(255)
                    else
                        status=-11
                        array(i1)=char(0)
                    end if
                end if
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCLB).')
            call ftpmsg(messge)
            return
        end if
 
        if (ntodo .gt. 0)then
C           increment the pointers
            i1=i1+itodo
            estart=estart+itodo*eincr
            if (estart .ge. repeat)then
                rskip=estart/repeat
                rstart=rstart+rskip
                estart=estart-rskip*repeat
            end if
            go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while reading FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error reading formatted data value from ASCII table
        write(messge,1002)colnum,rstart+frow
1002    format('Error reading column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to read value with format '//sform)
        status=315
        end
        subroutine ftgcld(iunit,colnum,frow,felem,nelem,eincr,
     &   nultyp,nulval,array,flgval,anynul,status)
 
C       read an array of real*8 data values from the specified column of
C       the table.
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       eincr   i  element increment
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  d  value that undefined pixels will be set to (if nultyp=1)
C       array   d  array of data values that are read from the FITS file
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status
        double precision array(*),nulval
        logical flgval(*),anynul
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer nulchk,i4null,rskip
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        logical tofits,trans
        integer*2 i2null
        character sval*30,sform*13,snull*16,i1null*1,messge*80
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
 
        if (status .gt. 0)return
 
        call ftgcpr(iunit,colnum,frow,felem,nelem,0,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,i4null,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
C       multiply incre to just get every nth pixel
        incre = incre * eincr
 
C       determine if we have to check for null values
        nulchk = nultyp
        if (nultyp .eq. 1 .and. nulval .eq. 0)then
C           user doesn't want to check for nulls
            nulchk=0
        else
C           user does want to check for null values
            if (tcode .le. 41)then
C               check if null value is defined for integer column
                if (i4null .eq. 123454321)then
                    nulchk=0
                else
                    if (tcode .eq. 11)then
                        i1null=char(i4null)
                    else if (tcode .eq. 21)then
                        i2null=i4null
                    end if
                end if
            end if
        end if
 
C       check for important special case: no datatype conversion required
        if (tcode .eq. 82 .and. nulchk .eq. 0 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
              trans=.false.
        else
              trans=.true.
        end if
 
        sval=' '
        i1=1
        ntodo=nelem
        rstart=0
        anynul=.false.
C       the data are being scaled from FITS to internal format
        tofits=.false.
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp+(rstart * lenrow) + (estart * incre / eincr)
        call ftmbyt(iunit,bstart,.false.,status)
 
C       read the data from FITS file, doing datatype conversion and scaling
        if (tcode .eq. 21)then
C               column data type is I (I*2)
C               read the data and do any machine dependent data conversion
                call ftgi2b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti2r8(buffer,itodo,scale,zero,tofits,
     &          nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
C               read the data and do any machine dependent data conversion
                call ftgi4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti4r8(buffer,itodo,scale,zero,tofits,
     &          nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
C               read the data and do any machine dependent data conversion
                call ftgr4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr4r8(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
C               read the data and do any machine dependent data conversion
C               note that we can use the input array directly
                call ftgr8b(iunit,itodo,incre,array(i1),status)
C               check for null values, and do scaling and datatype conversion
                if (trans)then
                  call ftr8r8(array(i1),itodo,scale,zero,tofits,
     &            nulchk,nulval,flgval(i1),anynul,array(i1),status)
                end if
        else if (tcode .eq. 11)then
C               column data type is B (byte)
C               read the data and do any machine dependent data conversion
                call ftgi1b(iunit,itodo,incre,chbuff,status)
C               check for null values, and do scaling and datatype conversion
                call fti1r8(chbuff,itodo,scale,zero,tofits,
     &          nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status)
        else
C               this is an ASCII table column; get the character string
                call ftgcbf(iunit,twidth,sval,status)
                if (status .gt. 0)return
 
C               check for null
                if (sval(1:16) .eq. snull)then
                        anynul=.true.
                        if (nultyp .eq. 1)then
                                array(i1)=nulval
                        else if (nultyp .eq. 2)then
                                flgval(i1)=.true.
                        end if
 
C               now read the value, then do scaling and datatype conversion
                else if (sform(5:5) .eq. 'I')then
                        read(sval,sform,err=900)ival
                        array(i1)=ival*scale+zero
                else
                        read(sval,sform,err=900)dval
                        array(i1)=dval*scale+zero
                end if
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCLD).')
            call ftpmsg(messge)
            return
        end if
 
        if (ntodo .gt. 0)then
C           increment the pointers
            i1=i1+itodo
            estart=estart+itodo*eincr
            if (estart .ge. repeat)then
                rskip=estart/repeat
                rstart=rstart+rskip
                estart=estart-rskip*repeat
            end if
            go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while reading FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error reading formatted data value from ASCII table
        write(messge,1002)colnum,rstart+frow
1002    format('Error reading column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to read value with format '//sform)
        status=315
        end
        subroutine ftgcle(iunit,colnum,frow,felem,nelem,eincr,
     &   nultyp,nulval,array,flgval,anynul,status)
 
C       read an array of real*4 data values from the specified column of
C       the table.
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       eincr   i  element increment
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  r  value that undefined pixels will be set to (if nultyp=1)
C       array   r  array of data values that are read from the FITS file
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status
        real array(*),nulval
        logical flgval(*),anynul
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer nulchk,i4null,rskip
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        logical tofits,trans
        integer*2 i2null
        character sval*30,sform*13,snull*16,i1null*1,messge*80
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
 
        if (status .gt. 0)return
 
        call ftgcpr(iunit,colnum,frow,felem,nelem,0,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,i4null,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
C       multiply incre to just get every nth pixel
        incre = incre * eincr
 
C       determine if we have to check for null values
        nulchk = nultyp
        if (nultyp .eq. 1 .and. nulval .eq. 0)then
C           user doesn't want to check for nulls
            nulchk=0
        else
C           user does want to check for null values
            if (tcode .le. 41)then
C               check if null value is defined for integer column
                if (i4null .eq. 123454321)then
                    nulchk=0
                else
                    if (tcode .eq. 11)then
                        i1null=char(i4null)
                    else if (tcode .eq. 21)then
                        i2null=i4null
                    end if
                end if
            end if
        end if
 
C       check for important special case: no datatype conversion required
        if (tcode .eq. 42 .and. nulchk .eq. 0 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
              trans=.false.
        else
              trans=.true.
        end if
 
        sval=' '
        i1=1
        ntodo=nelem
        rstart=0
        anynul=.false.
C       the data are being scaled from FITS to internal format
        tofits=.false.
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp+(rstart * lenrow) + (estart * incre / eincr)
        call ftmbyt(iunit,bstart,.false.,status)
 
C       read the data from FITS file, doing datatype conversion and scaling
        if (tcode .eq. 42)then
C               column data type is E (R*4)
C               read the data and do any machine dependent data conversion
C               note that we can use the input array directly
                call ftgr4b(iunit,itodo,incre,array(i1),status)
C               check for null values, and do scaling and datatype conversion
                if (trans)then
                  call ftr4r4(array(i1),itodo,scale,zero,tofits,nulchk,
     &            nulval,flgval(i1),anynul,array(i1),status)
                end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
C               read the data and do any machine dependent data conversion
                call ftgi2b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti2r4(buffer,itodo,scale,zero,tofits,
     &          nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
C               read the data and do any machine dependent data conversion
                call ftgi4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti4r4(buffer,itodo,scale,zero,tofits,
     &          nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
C               read the data and do any machine dependent data conversion
                call ftgr8b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr8r4(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
C               read the data and do any machine dependent data conversion
                call ftgi1b(iunit,itodo,incre,chbuff,status)
C               check for null values, and do scaling and datatype conversion
                call fti1r4(chbuff,itodo,scale,zero,tofits,
     &          nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status)
        else
C               this is an ASCII table column; get the character string
                call ftgcbf(iunit,twidth,sval,status)
                if (status .gt. 0)return
 
C               check for null
                if (sval(1:16) .eq. snull)then
                        anynul=.true.
                        if (nultyp .eq. 1)then
                                array(i1)=nulval
                        else if (nultyp .eq. 2)then
                                flgval(i1)=.true.
                        end if
 
C               now read the value, then do scaling and datatype conversion
                else if (sform(5:5) .eq. 'I')then
                        read(sval,sform,err=900)ival
                        array(i1)=ival*scale+zero
                else
                        read(sval,sform,err=900)dval
                        array(i1)=dval*scale+zero
                end if
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCLE).')
            call ftpmsg(messge)
            return
        end if
 
        if (ntodo .gt. 0)then
C           increment the pointers
            i1=i1+itodo
            estart=estart+itodo*eincr
            if (estart .ge. repeat)then
                rskip=estart/repeat
                rstart=rstart+rskip
                estart=estart-rskip*repeat
            end if
            go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while reading FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error reading formatted data value from ASCII table
        write(messge,1002)colnum,rstart+frow
1002    format('Error reading column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to read value with format '//sform)
        status=315
        end
        subroutine ftgcli(iunit,colnum,frow,felem,nelem,eincr,
     &   nultyp,nulval,array,flgval,anynul,status)
 
C       read an array of integer*2 data values from the specified column of
C       the table.
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       eincr   i  element increment
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  i*2  value that undefined pixels will be set to (if nultyp=1)
C       array   i*2  array of data values that are read from the FITS file
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status
        integer*2 array(*),nulval
        logical flgval(*),anynul
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer nulchk,i4null,rskip
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        logical tofits,trans
        integer*2 i2null
        character sval*30,sform*13,snull*16,i1null*1,messge*80
        integer maxi2,mini2
        double precision i2max,i2min
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
        parameter (maxi2=32767)
        parameter (mini2=-32768)
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
 
        if (status .gt. 0)return
 
        call ftgcpr(iunit,colnum,frow,felem,nelem,0,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,i4null,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
C       multiply incre to just get every nth pixel
        incre = incre * eincr
 
C       determine if we have to check for null values
        nulchk = nultyp
        if (nultyp .eq. 1 .and. nulval .eq. 0)then
C           user doesn't want to check for nulls
            nulchk=0
        else
C           user does want to check for null values
            if (tcode .le. 41)then
C               check if null value is defined for integer column
                if (i4null .eq. 123454321)then
                    nulchk=0
                else
                    if (tcode .eq. 11)then
                        i1null=char(i4null)
                    else if (tcode .eq. 21)then
                        i2null=i4null
                    end if
                end if
            end if
        end if
 
C       check for important special case: no datatype conversion required
        if (tcode .eq. 21 .and. nulchk .eq. 0 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
              trans=.false.
        else
              trans=.true.
        end if
 
        sval=' '
        i1=1
        ntodo=nelem
        rstart=0
        anynul=.false.
C       the data are being scaled from FITS to internal format
        tofits=.false.
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp+(rstart * lenrow) + (estart * incre / eincr)
        call ftmbyt(iunit,bstart,.false.,status)
 
C       read the data from FITS file, doing datatype conversion and scaling
        if (tcode .eq. 21)then
C               column data type is I (I*2)
C               read the data and do any machine dependent data conversion
C               note that we can use the input array directly
                call ftgi2b(iunit,itodo,incre,array(i1),status)
C               check for null values, and do scaling and datatype conversion
                if (trans)then
                  call fti2i2(array(i1),itodo,scale,zero,tofits,nulchk,
     &            i2null,nulval,flgval(i1),anynul,array(i1),status)
                end if
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
C               read the data and do any machine dependent data conversion
                call ftgi4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti4i2(buffer,itodo,scale,zero,tofits,
     &          nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
C               read the data and do any machine dependent data conversion
                call ftgr4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr4i2(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
C               read the data and do any machine dependent data conversion
                call ftgr8b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr8i2(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
C               read the data and do any machine dependent data conversion
                call ftgi1b(iunit,itodo,incre,chbuff,status)
C               check for null values, and do scaling and datatype conversion
                call fti1i2(chbuff,itodo,scale,zero,tofits,
     &          nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status)
        else
C               this is an ASCII table column; get the character string
                call ftgcbf(iunit,twidth,sval,status)
                if (status .gt. 0)return
 
C               check for null value
                if (sval(1:16) .eq. snull)then
                    anynul=.true.
                    if (nultyp .eq. 1)then
                        array(i1)=nulval
                    else if (nultyp .eq. 2)then
                        flgval(i1)=.true.
                    end if
                else
C                   read the value, then do scaling and datatype conversion
                    if (sform(5:5) .eq. 'I')then
                        read(sval,sform,err=900)ival
                        dval=ival*scale+zero
                    else
                        read(sval,sform,err=900)dval
                        dval=dval*scale+zero
                    end if
 
C                   trap any values that overflow the I*2 range
                    if (dval .lt. i2max .and. dval .gt. i2min)then
                        array(i1)=dval
                    else if (dval .ge. i2max)then
                        status=-11
                        array(i1)=maxi2
                    else
                        status=-11
                        array(i1)=mini2
                    end if
                end if
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCLI).')
            call ftpmsg(messge)
            return
        end if
 
        if (ntodo .gt. 0)then
C           increment the pointers
            i1=i1+itodo
            estart=estart+itodo*eincr
            if (estart .ge. repeat)then
                rskip=estart/repeat
                rstart=rstart+rskip
                estart=estart-rskip*repeat
            end if
            go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while reading FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error reading formatted data value from ASCII table
        write(messge,1002)colnum,rstart+frow
1002    format('Error reading column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to read value with format '//sform)
        status=315
        end
        subroutine ftgclj(iunit,colnum,frow,felem,nelem,eincr,
     &   nultyp,nulval,array,flgval,anynul,status)
 
C       read an array of integer*4 data values from the specified column of
C       the table.
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       eincr   i  element increment
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  i  value that undefined pixels will be set to (if nultyp=1)
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status
        integer array(*),nulval
        logical flgval(*),anynul
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer nulchk,i4null,rskip
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        logical tofits,trans
        integer*2 i2null
        character sval*30,sform*13,snull*16,i1null*1,messge*80
        character*1 chbuff(32000)
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(iunit,colnum,frow,felem,nelem,0,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,i4null,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
C       multiply incre to just get every nth pixel
        incre = incre * eincr
 
C       determine if we have to check for null values
        nulchk = nultyp
        if (nultyp .eq. 1 .and. nulval .eq. 0)then
C           user doesn't want to check for nulls
            nulchk=0
        else
C           user does want to check for null values
            if (tcode .le. 41)then
C               check if null value is defined for integer column
                if (i4null .eq. 123454321)then
                    nulchk=0
                else
                    if (tcode .eq. 11)then
                        i1null=char(i4null)
                    else if (tcode .eq. 21)then
                        i2null=i4null
                    end if
                end if
            end if
        end if
 
C       check for important special case: no datatype conversion required
        if (tcode .eq. 41 .and. nulchk .eq. 0 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
              trans=.false.
        else
              trans=.true.
        end if
 
        sval=' '
        i1=1
        ntodo=nelem
        rstart=0
        anynul=.false.
C       the data are being scaled from FITS to internal format
        tofits=.false.
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp+(rstart * lenrow) + (estart * incre / eincr)
        call ftmbyt(iunit,bstart,.false.,status)
 
C       read the data from FITS file, doing datatype conversion and scaling
        if (tcode .eq. 41)then
C               column data type is J (I*4)
C               read the data and do any machine dependent data conversion
C               note that we can use the input array directly
                call ftgi4b(iunit,itodo,incre,array(i1),status)
C               check for null values, and do scaling and datatype conversion
                if (trans)then
                  call fti4i4(array(i1),itodo,scale,zero,tofits,nulchk,
     &            i4null,nulval,flgval(i1),anynul,array(i1),status)
                end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
C               read the data and do any machine dependent data conversion
                call ftgi2b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call fti2i4(buffer,itodo,scale,zero,tofits,
     &          nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
C               read the data and do any machine dependent data conversion
                call ftgr4b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr4i4(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
C               read the data and do any machine dependent data conversion
                call ftgr8b(iunit,itodo,incre,buffer,status)
C               check for null values, and do scaling and datatype conversion
                call ftr8i4(buffer,itodo,scale,zero,tofits,
     &          nulchk,nulval,flgval(i1),anynul,array(i1),status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
C               read the data and do any machine dependent data conversion
                call ftgi1b(iunit,itodo,incre,chbuff,status)
C               check for null values, and do scaling and datatype conversion
                call fti1i4(chbuff,itodo,scale,zero,tofits,
     &          nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status)
        else
C               this is an ASCII table column; get the character string
                call ftgcbf(iunit,twidth,sval,status)
                if (status .gt. 0)return
 
C               check for null value
                if (sval(1:16) .eq. snull)then
                    anynul=.true.
                    if (nultyp .eq. 1)then
                        array(i1)=nulval
                    else if (nultyp .eq. 2)then
                        flgval(i1)=.true.
                    end if
                else
C                   read the value, then do scaling and datatype conversion
                    if (sform(5:5) .eq. 'I')then
                        read(sval,sform,err=900)ival
                        dval=ival*scale+zero
                    else
                        read(sval,sform,err=900)dval
                        dval=dval*scale+zero
                    end if
 
C                   trap any values that overflow the I*4 range
                    if (dval .lt. i4max .and. dval .gt. i4min)then
                        array(i1)=dval
                    else if (dval .ge. i4max)then
                        status=-11
                        array(i1)=maxi4
                    else
                        status=-11
                        array(i1)=mini4
                    end if
                end if
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error reading elements',i9,' thru',i9,
     &         ' of data array (FTGCLJ).')
            call ftpmsg(messge)
            return
        end if
 
        if (ntodo .gt. 0)then
C           increment the pointers
            i1=i1+itodo
            estart=estart+itodo*eincr
            if (estart .ge. repeat)then
                rskip=estart/repeat
                rstart=rstart+rskip
                estart=estart-rskip*repeat
            end if
            go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while reading FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error reading formatted data value from ASCII table
        write(messge,1002)colnum,rstart+frow
1002    format('Error reading column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to read value with format '//sform)
        status=315
        end
        subroutine ftgcls(iunit,colnum,frow,felem,nelem,nultyp,nulval,
     &    sray,flgval,anynul,status)
 
C       read an array of character string values from the specified column of
C       the table.
C       The binary or ASCII table column being read must have datatype 'A'
C       This general purpose routine will handle null values in one
C       of two ways: if nultyp=1, then undefined array elements will be
C       set equal to the input value of NULVAL.  Else if nultyp=2, then
C       undefined array elements will have the corresponding FLGVAL element
C       set equal to .TRUE.  If NULTYP=1 and NULVAL=0, then no checks for
C       undefined values will be made, for maximum efficiency.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       frow    i  first row to read
C       felem   i  first element within row to read
C       nelem   i  number of elements to read
C       nultyp  i  input code indicating how to handle undefined values
C       nulval  c  value that undefined pixels will be set to (if nultyp=1)
C       sray    c  array of data values to be read
C       flgval  l  set .true. if corresponding element undefined (if nultyp=2)
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,nultyp,status
        logical flgval(*),anynul
        character*(*) sray(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,nulchk,twidth,tread,tcode,offset,repeat
        integer ibuff,i1,ntodo,rstart,estart,lennul,strlen,nulfil
        character snull*16, messge*80
 
        if (status .gt. 0)return
        ibuff=bufnum(iunit)
 
C       Do sanity check of input parameters
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (hdutyp(ibuff) .ne. 1 .and. felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        else if (nelem .eq. 0)then
          return
        end if
 
        anynul=.false.
        i1=1
 
C       column must be character string data type
 
        tcode=tdtype(colnum+tstart(ibuff))
        if (tcode .eq. 16)then
C               for ASCII columns, TNULL actually stores the field width
                twidth=tnull(colnum+tstart(ibuff))
                ntodo=nelem
                rstart=frow-1
                repeat=trept(colnum+tstart(ibuff))
                if (felem .gt. repeat)then
C                   illegal element number
                    write(messge,1005)felem
1005                format(
     &       'Starting element number is greater than repeat: ',i10)
                    call ftpmsg(messge)
                    status = 308
                    return
                end if
                estart=felem-1
                bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
     &                 +tbcol(colnum+tstart(ibuff))+estart*twidth
        else if (tcode .eq. -16)then
C               this is a variable length descriptor field
                ntodo=1
C               read the string length and the starting offset:
                call ftgdes(iunit,colnum,frow,twidth,offset,status)
C               calc the i/o pointer position for the start of the string
                bstart=dtstrt(ibuff)+offset+theap(ibuff)
        else
C               error: not a character string column
                status=309
                call ftpmsg('Cannot to read character string'//
     &          ' from a non-character column of a table (FTGCLS).')
                return
        end if
 
C       define the max. number of charcters to be read: either
C       the length of the variable length field, or the length
C       of the character string variable, which ever is smaller
        strlen=len(sray(1))
        tread=min(twidth,strlen)
 
C       move the i/o pointer to the start of the sequence of pixels
        call ftmbyt(iunit,bstart,.false.,status)
 
        lennul=0
C       determine if we have to check for null values
        if (nultyp .eq. 1 .and. nulval .eq. ' ')then
C               user doesn't want to check for nulls
                nulchk=0
        else
                nulchk=nultyp
                snull=cnull(colnum+tstart(ibuff))
C               lennul = length of the string to check for null values
                lennul=min(len(sray(1)),8)
        end if
 
C       process one string at a time
20      continue
C       get the string of characters
        sray(i1)=' '
        call ftgcbf(iunit,tread,sray(i1),status)
        if (status .gt. 0)return
 
C       check for null value, if required
        if (nulchk .ne. 0)then
                if (ichar(sray(i1)(1:1)) .eq. 0 .or.
     &              sray(i1)(1:lennul) .eq. snull(1:lennul))then
                        if (nulchk .eq. 1)then
                                sray(i1)=nulval
                                anynul=.true.
                        else
                                flgval(i1)=.true.
                                anynul=.true.
                        end if
                end if
        end if
 
C       check for null terminated string; pad out with blanks if found
        nulfil=index(sray(i1),char(0))
        if (nulfil .gt. 1)then
                sray(i1)(nulfil:len(sray(1)))=' '
        end if
 
        if (status .gt. 0)then
            write(messge,1006)i1
1006        format('Error reading string for element',i9,
     &         ' of data array (FTGCLS).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-1
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+1
                estart=estart+1
                if (estart .eq. repeat)then
                        rstart=rstart+1
                        estart=0
                end if
C               move to the start of the next string; need to do
C               this every time in case we didn't read all the characters
C               from the previous string.
                bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
     &                 +tbcol(colnum+tstart(ibuff))+estart*twidth
C               move the i/o pointer
                call ftmbyt(iunit,bstart,.false.,status)
                go to 20
        end if
        end
        subroutine ftgcnn(iunit,casesn,templt,colnam,colnum,status)
 
C       determine the column name and number corresponding to an input
C       column name template string.  The template may contain the * and ?
C       wildcards.  Status = 237 is returned if match is not unique.
C       One may call this routine again with input status=237  to
C       get the next match.
 
C       iunit   i  Fortran i/o unit number
C       casesn  l  true if an exact case match of the names is required
C       templt  c  templt for column name
C       colnam  c  name of (first) column that matchs the template
C       colnum  i  number of the column (first column = 1)
C                       (a value of 0 is returned if the column is not found)
C       status  i  returned error status
 
C       written by Wm Pence, HEASARC/GSFC, December 1994
 
        integer iunit,colnum,status
        character*(*) templt,colnam
        logical casesn
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        integer colpnt,untpnt
        common/ftname/colpnt,untpnt
C       END OF COMMON BLOCK DEFINITIONS------------------------------------
 
        integer ibuff,i,nfound,tstat,ival
        logical match,exact,founde,foundw,unique
        character*80 errmsg
        character*68 tname(999)
        save tname
 
        ibuff=bufnum(iunit)
 
C       load the common block with names, if not already defined
        if (colpnt .eq. -999 .or. iunit .ne. untpnt)then
            do 10 i=1,tfield(ibuff)
                tname(i)=' '
10          continue
            call ftgkns(iunit,'TTYPE',1,nf,tname,nfound,status)
            if (status .gt. 0)return
            untpnt=iunit
            colpnt=1
        end if
 
        if (status .le. 0)then
            tstat=0
            colpnt=1
        else if (status .eq. 237)then
C           search for next non-unique match, starting from the previous match
            tstat=237
            status=0
        else
            return
        end if
 
        colnam=' '
        colnum=0
 
C       set the 'found exact' and 'found wildcard' flags to false
        founde=.false.
        foundw=.false.
 
        do 100 i=colpnt,tfield(ibuff)
C               test for match between template and column name
                call ftcmps(templt,tname(i),casesn,match,exact)
 
                if (match)then
                    if (founde .and. exact)then
C                       warning: this is the second exact match we've found
C                       reset pointer to first match so next search starts there
                        colpnt=colnum+1
                        status=237
                        return
                    else if (founde)then
C                       already found exact match so ignore this non-exact match
                    else if (exact)then
C                       this is the first exact match we have found, so save it.
                        colnam=tname(i)
                        colnum=i
                        founde=.true.
                    else if (foundw)then
C                       we have already found a wild card match, so not unique
C                       continue searching for other matches
                        unique=.false.
                    else
C                       this is the first wild card match we've found. save it
                        colnam=tname(i)
                        colnum=i
                        foundw=.true.
                        unique=.true.
                    end if
                end if
100     continue
 
C       OK, we've checked all the names now see if we got any matches
        if (founde)then
C           we did find 1 exact match
            if (tstat .eq. 237)status=237
        else if (foundw)then
C           we found one or more wildcard matches
C           report error if not unique
            if (.not. unique .or. tstat .eq. 237)status=237
        else
C           didn't find a match; check if template is a simple positive integer
            call ftc2ii(templt,ival,tstat)
            if (tstat .eq. 0 .and. ival .le. tfield(ibuff)
     &          .and. ival .gt. 0)then
                colnum=ival
                colnam=tname(ival)
            else
                status=219
                if (tstat .ne. 237)then
                  errmsg='FTGCNN: Could not find column: '//templt
                  call ftpmsg(errmsg)
                end if
            end if
        end if
 
C       reset pointer so next search starts here if input status=237
        colpnt=colnum+1
        end
        subroutine ftgcno(iunit,casesn,templt,colnum,status)
 
C       determine the column number corresponding to an input column name.
C       This supports the * and ? wild cards in the input template.
 
C       iunit   i  Fortran i/o unit number
C       casesn  l  true if an exact case match of the names is required
C       templt  c  name of column as specified in a TTYPE keyword
C       colnum  i  number of the column (first column = 1)
C                       (a value of 0 is returned if the column is not found)
C       status  i  returned error status
 
C       modified by Wm Pence, HEASARC/GSFC, December 1994
 
        integer iunit,colnum,status
        character*(*) templt
        logical casesn
        character*8 dummy
 
        call ftgcnn(iunit,casesn,templt,dummy,colnum,status)
        end
        subroutine ftgcpr(iunit,colnum,frow,felem,nelem,rwmode,
     & ibuff,scale,zero,tform,twidth,tcode,maxelm,startp,
     & elnum,incre,repeat,lenrow,hdtype,inull,snull,status)
 
C  Get Column PaRameters, and test starting row and element numbers for
C  validity.
 
C       iunit   I - fortran unit number
C       colnum  I - column number (1 = 1st column of table)
C       frow    I - first row (1 = 1st row of table)
C       felem   I - first element within vector (1 = 1st)
C       nelem   I - number of elements to read or write
C       rwmode  I - = 1 if writing data, = 0 if reading data
C       ibuff   O - buffer associated with this file
C       scale   O - FITS scaling factor (TSCALn keyword value)
C       zero    O - FITS scaling zero pt (TZEROn keyword value)
C       tform   O - ASCII column format: value of TFORMn keyword
C       twidth  O - width of ASCII column (characters)
C       tcode   O - column datatype code: I*4=41, R*4=42, etc
C       maxelm  O - max number of elements that fit in buffer
C       startp  O - offset in file to starting row & column
C       elnum   O - starting element number ( 0 = 1st element)
C       incre   O - byte offset between elements within a row
C       repeat  O - number of elements in a row (vector column)
C       lenrow  O - length of a row, in bytes
C       hdtype  O - HDU type: 0, 1, 2 = primary, table, bintable
C       inull   O - null value for integer columns
C       snull   O - null value for ASCII table columns
C       status IO - error status
 
C       written by Wm Pence, HEASARC/GSFC, November 1996
 
        integer iunit,colnum,frow,felem,nelem
        integer rwmode,ibuff,twidth,tcode,maxelm,startp
        integer elnum,incre,repeat,lenrow,hdtype,inull
        integer status
        character*(*) snull, tform
        double precision scale,zero
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
        integer compid
        common/ftcpid/compid
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer datast, xtbcol,acode
        character*80 messge
        integer bufdim
        parameter (bufdim = 32000)
 
        ibuff=bufnum(iunit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status)
 
C       Do sanity check of input parameters
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (hdutyp(ibuff) .ne. 1 .and. felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        else if (nelem .eq. 0)then
C         not reading or writing any pixels, so just return
          return
        end if
 
C       copy relevant parameters from the common block
        hdtype = hdutyp(ibuff)
        lenrow = rowlen(ibuff)
        datast = dtstrt(ibuff)
        tcode  = tdtype(colnum+tstart(ibuff))
        tform  ='(           )'
        tform(5:12)=cform(colnum+tstart(ibuff))
 
        acode = abs(tcode)
        if ((hdtype .eq. 1 .and. tform(5:5) .eq. 'A') .or.
     &    (hdtype .eq. 2 .and. acode .eq. 16) .or.
     &     acode .eq. 14)then
C          error: illegal table format code
           status=311
           write(messge,1005)colnum,cform(colnum+tstart(ibuff))
1005       format('Cannot read or write numerical values in column',
     &     i4,' with TFORM = ',a8)
           call ftpmsg(messge)
           return
        end if
 
        if (hdtype .eq. 1 .and. rwmode .eq. 1)then
           if (tform(5:5) .eq. 'E')then
               tform(2:4)='1P,'
           else if (tform(5:5) .eq. 'D')then
               tform(2:5)='1P,E'
           end if
        else if (hdtype .eq. 1)then
           tform(2:4)='BN,'
        end if
 
        snull =  cnull(colnum+tstart(ibuff))
        scale=  tscale(colnum+tstart(ibuff))
        zero=    tzero(colnum+tstart(ibuff))
        inull=   tnull(colnum+tstart(ibuff))
        xtbcol=  tbcol(colnum+tstart(ibuff))
        repeat=  trept(colnum+tstart(ibuff))
 
        if (tcode .ne. 16)then
          twidth=max(acode/10,1)
        else
          twidth = tnull(colnum+tstart(ibuff))
        end if
 
C       Special case: interprete 'X' column as 'B'
        if (acode .eq. 1)then
           tcode  = tcode * 11
           repeat = (repeat + 7) / 8
        end if
 
C       Special case: support the 'rAw' format in BINTABLEs
        if (hdtype .eq. 2 .and. tcode .eq. 16)then
          repeat =  repeat /  twidth
        end if
 
        if (hdtype .eq. 1)then
C         ASCII tables don't have vector elements
          elnum = 0
        else
          elnum = felem - 1
        end if
 
C       interprete complex and double complex as pairs of floats or doubles
        if (abs(tcode) .gt. 82)then
          if (tcode .gt. 0)then
             tcode = (tcode + 1) / 2
          else
             tcode = (tcode - 1) / 2
          end if
 
          repeat  = repeat * 2
          twidth  = twidth / 2
        end if
 
        incre= twidth
 
C       calculate no. of pixels that fit in buffer
        if (hdtype .eq. 1)then
C           in ASCII tables, can only process 1 value at a time
            maxelm = 1
        else
            maxelm = bufdim / twidth
        end if
 
C       special case for the SUN F90 compiler where integer*2
C       variables are stored in 4-byte integers
        if (compid .eq. -1 .and. abs(tcode) .eq. 21)then
            maxelm = bufdim / 4
        end if
 
C       calc starting byte position to 1st element of col
C       (this does not apply to variable length columns)
        startp = datast + ((frow - 1) * lenrow) + xtbcol
 
        if (hdtype .eq. 0 .and. rwmode .eq. 1)then
 
C       When writing primary arrays, set the repeat count greater than the
C       total number of pixels to be written.  This prevents an out-of-range
C       error message in cases where the final image array size is not
C       yet known or defined.
 
          repeat = elnum + nelem
 
        else if (tcode .gt. 0)then
C         Fixed length table column
 
          if (elnum .ge. repeat)then
C                       illegal element number
             write(messge,1006)felem
1006         format(
     &       'Starting element number is greater than repeat: ',i10)
             call ftpmsg(messge)
             status = 308
          else if (repeat .eq. 1 .and. nelem .gt. 1)then
 
C            When accessing a scalar column, fool the calling routine into
C            thinking that this is a vector column with very big elements.
C            This allows multiple values (up to the maxelem number of elements
C            that will fit in the buffer) to be read or written with a single
C            routine call, which increases the efficiency.
 
             incre = lenrow
             repeat = nelem
          end if
        else
C         Variable length Binary Table column
 
          tcode = tcode * (-1)
 
          if (rwmode .eq.  1)then
C           return next empty heap address for writing
 
C           total no. of elements in the field
            repeat = nelem + elnum
 
C           calculate starting position (for writing new data) in the heap
            startp = datast + heapsz(ibuff)+theap(ibuff)
 
C           write the descriptor into the fixed length part of table
            call ftpdes(iunit, colnum, frow, repeat, heapsz(ibuff),
     &                  status)
 
C           increment the address to the next empty heap position
            heapsz(ibuff) = heapsz(ibuff) + (repeat * incre)
          else
C           get the read start position in the heap
 
            call ftgdes(iunit, colnum, frow, repeat, startp, status)
 
            if (tdtype(colnum+tstart(ibuff)) .eq. -1)then
C               Special case: interprete 'X' column as 'B'
                repeat = (repeat + 7) / 8
            end if
 
            if (elnum .ge. repeat)then
C                       illegal element number
               write(messge,1006)felem
               call ftpmsg(messge)
               status = 308
            end if
 
            startp=datast + startp + theap(ibuff)
          end if
        end if
        end
        subroutine ftgcrd(iunit,keynam,card,status)
 
C    Read the 80 character card image of a specified header keyword record
C    If the input name contains wild cards ('?' matches any single char
C    and '*' matches any sequence of chars, # matches any string of decimal
C    digits) then the search ends once the end of header is reached and does
C    not automatically resume from the top of the header.
 
C       iunit   i  Fortran I/O unit number
C       keynam  c  name of keyword to be read
C       OUTPUT PARAMETERS:
C       card    c  80 character card image that was read
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
C       modified January 1997 to support wildcards
 
        integer iunit,status
        character*(*) keynam,card
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer i,j,ibuff,maxkey,start
        character kname*9
        character*80 keybuf
        logical wild,casesn,match,exact
 
        card=' '
        if (status .gt. 0)go to 100
        casesn=.true.
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(iunit)
 
C       make sure keyword name is in uppercase
        kname=keynam
        call ftupch(kname)
 
C       test if input name contains wild card characters
        wild=.false.
        do 5 i=1,9
          if (kname(i:i) .eq. '?' .or. kname(i:i) .eq. '*'
     &   .or. kname(i:i) .eq. '#')wild=.true.
5       continue
 
C       Start by searching for keyword from current pointer position to the end.
C       Calculate the maximum number of keywords to be searched:
        start=nxthdr(ibuff)
        maxkey=(hdend(ibuff)-start)/80
 
        do 20 j=1,2
C           position I/O pointer to the next header keyword
            if (maxkey .gt. 0)then
                call ftmbyt(iunit,start,.false.,status)
            end if
 
            do 10 i=1,maxkey
                call ftgcbf(iunit,80,keybuf,status)
                if (status .gt. 0)go to 100
                if (wild)then
                  call ftcmps(kname(1:8),keybuf(1:8),casesn,match,exact)
                  if (match)then
C                     setheader pointer to the following keyword
                      nxthdr(ibuff)=start+i*80
                      card=keybuf
                      return
                  end if
                else if (keybuf(1:8) .eq. kname(1:8))then
C                       setheader pointer to the following keyword
                        nxthdr(ibuff)=start+i*80
                        card=keybuf
                        return
                end if
10          continue
 
C           end search at end of header if input name contains wildcards
            if (wild .or. (j .eq. 2))go to 30
 
C           didn't find keyword yet, so now search from top down to starting pt.
C           calculate max number of keywords to be searched and reset nxthdr
            maxkey=(start-hdstrt(ibuff,chdu(ibuff)))/80
            start=hdstrt(ibuff,chdu(ibuff))
20      continue
 
C       keyword was not found
30      status=202
 
C       don't write to error stack because this innoculous error happens a lot
C       call ftpmsg('Could not find the '//kname//' keyword to read.')
 
100     continue
        end
        subroutine ftgcvb(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of byte values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  b  value that undefined pixels will be set to
C       array   b  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
 
        character*1 array(*),nulval
 
        call ftgclb(iunit,colnum,frow,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvc(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of complex values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  cmp  value that undefined pixels will be set to
C       array   cmp  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        real array(*),nulval(2)
        integer felemx, nelemx
 
C       a complex value is interpreted as a pair of float values, thus
C       need to multiply the first element and number of elements by 2
 
        felemx = (felem - 1) * 2 + 1
        nelemx = nelem * 2
 
        call ftgcle(iunit,colnum,frow,felemx,nelemx,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvd(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of r*8 values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  d  value that undefined pixels will be set to
C       array   d  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        double precision array(*),nulval
 
        call ftgcld(iunit,colnum,frow,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcve(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of R*4 values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  r  value that undefined pixels will be set to
C       array   r  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        real array(*),nulval
 
        call ftgcle(iunit,colnum,frow,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvi(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of I*2 values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  i*2  value that undefined pixels will be set to
C       array   i*2 returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        integer*2 array(*),nulval
 
        call ftgcli(iunit,colnum,frow,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvj(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of I*4 values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  i  value that undefined pixels will be set to
C       array   i  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        integer array(*),nulval
 
        call ftgclj(iunit,colnum,frow,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvm(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of double precision complex values from a specified
C       column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=0, in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element within the row to read
C       nelem   i  number of elements to read
C       nulval  dcmp  value that undefined pixels will be set to
C       array   dcmp  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        double precision array(*),nulval(2)
        integer felemx, nelemx
 
C       a complex value is interpreted as a pair of float values, thus
C       need to multiply the first element and number of elements by 2
 
        felemx = (felem - 1) * 2 + 1
        nelemx = nelem * 2
 
        call ftgcld(iunit,colnum,frow,felemx,nelemx,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcvs(iunit,colnum,frow,felem,nelem,nulval,array,
     &          anynul,status)
 
C       read an array of string values from a specified column of the table.
C       Any undefined pixels will be set equal to the value of NULVAL,
C       unless NULVAL=' ', in which case no checks for undefined pixels
C       will be made.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       felem   i  first element in the row to read
C       nelem   i  number of elements to read
C       nulval  c  value that undefined pixels will be set to
C       array   c  returned array of data values that was read from FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,colnum,frow,felem,nelem,status
        logical flgval,anynul
        character*(*) array(*),nulval
 
        call ftgcls(iunit,colnum,frow,felem,nelem,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgcx(iunit,colnum,frow,fbit,nbit,lray,status)
 
C       read an array of logical values from a specified bit or byte
C       column of the binary table.  A logical .true. value is returned
C       if the corresponding bit is 1, and a logical .false. value is
C       returned if the bit is 0.
C       The binary table column being read from must have datatype 'B'
C       or 'X'. This routine ignores any undefined values in the 'B' array.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       fbit    i  first bit within the row to read
C       nbit    i  number of bits to read
C       lray    l  returned array of logical data values that is read
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Mar 1992
 
        integer iunit,colnum,frow,fbit,nbit,status
        logical lray(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,offset,tcode,fbyte,bitloc,ndone
        integer ibuff,i,ntodo,repeat,rstart,estart,buffer
        logical descrp,log8(8)
        character*1 cbuff
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        tcode=tdtype(colnum+tstart(ibuff))
 
C       check input parameters
        if (nbit .le. 0)then
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                return
        else if (fbit .lt. 1)then
C               illegal element number
                status=308
                return
        end if
 
        fbyte=(fbit+7)/8
        bitloc=fbit-(fbit-1)/8*8
        ndone=0
        ntodo=nbit
        rstart=frow-1
        estart=fbyte-1
 
        if (tcode .eq. 11)then
                repeat=trept(colnum+tstart(ibuff))
                if (fbyte .gt. repeat)then
C                       illegal element number
                        status=308
                        return
                end if
                descrp=.false.
C               move the i/o pointer to the start of the sequence of pixels
                bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &          tbcol(colnum+tstart(ibuff))+estart
        else if (tcode .eq. -11)then
C               this is a variable length descriptor column
                descrp=.true.
C               read the number of elements and the starting offset:
                call ftgdes(iunit,colnum,frow,repeat,
     &                              offset,status)
                repeat=(repeat+7)/8
                if (repeat .eq. 0)then
C                       error: null length vector
                        status=318
                        return
                else if ((fbit+nbit+6)/8 .gt. repeat)then
C                       error: trying to read beyond end of record
                        status=319
                        return
                end if
                bstart=dtstrt(ibuff)+offset+
     &                          theap(ibuff)+estart
        else
C               column must be byte or bit data type
                status=312
                return
        end if
 
C       move the i/o pointer to the start of the pixel sequence
        call ftmbyt(iunit,bstart,.false.,status)
 
C       get the next byte
20      call ftgcbf(iunit,1,cbuff,status)
        buffer=ichar(cbuff)
        if (buffer .lt. 0)buffer=buffer+256
 
C       decode the bits within the byte into an array of logical values
        call ftgbit(buffer,log8)
 
        do 10 i=bitloc,8
                ndone=ndone+1
                lray(ndone)=log8(i)
                if (ndone .eq. ntodo)go to 100
10      continue
 
C       not done, so get the next byte
        if (.not. descrp)then
                estart=estart+1
                if (estart .eq. repeat)then
C                       move the i/o pointer to the next row of pixels
                        estart=0
                        rstart=rstart+1
                        bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &                         tbcol(colnum+tstart(ibuff))+estart
                        call ftmbyt(iunit,bstart,.false.,status)
                end if
        end if
        bitloc=1
        go to 20
 
100     continue
        end
        subroutine ftgcxd(iunit,colnum,frow,nrow,fbit,nbit,
     &             dvalue,status)
 
C       read any consecutive bits from an 'X' or 'B' column as an unsigned
C       n-bit integer
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       nrow    i  number of rows to read
C       fbit    i  first bit within the row to read
C       nbit    i  number of bits to read
C       dvalue  d  returned value(s)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1994
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer iunit,colnum,fbit,nbit,frow,nrow,status
        integer i,k,istart,itodo,ntodo,row,ibuff
        double precision dvalue(*),power,dval
        logical lray(64)
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then
            call ftpmsg('Asked to read more bits than exist in'//
     &      ' the column (ftgcxd)')
            status=308
            return
        end if
 
        row=frow-1
        do 30 k=1,nrow
            row=row+1
            dval=0.
            power=1.0D+00
            istart=fbit+nbit
            ntodo=nbit
 
10          itodo=min(ntodo,64)
            istart=istart-itodo
 
C           read up to 64 bits at a time
C           get the individual bits
            call ftgcx(iunit,colnum,row,istart,itodo,lray,status)
            if (status .gt. 0)return
 
C           reconstruct the positive integer value
            do 20 i=itodo,1,-1
                if (lray(i))dval=dval+power
                power=power*2.0D+00
20          continue
 
            ntodo=ntodo-itodo
            if (itodo .gt. 0)go to 10
            dvalue(k)=dval
30      continue
        end
        subroutine ftgcxi(iunit,colnum,frow,nrow,fbit,nbit,
     &                    ivalue,status)
 
C       read any consecutive bits from an 'X' or 'B' column as an unsigned
C       n-bit integer, unless nbits=16 in which case the 16 bits
C       are interpreted as a 16-bit signed 2s complement word
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       nrow    i  number of rows to read
C       fbit    i  first bit within the row to read
C       nbit    i  number of bits to read
C       ivalue  i*2  returned integer value(s)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1994
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,ibuff
        integer*2 ivalue(*),ival,power2(16)
        logical lray(16)
        save power2
        data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,
     &  16384,0/
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
        if (nbit .gt. 16)then
            call ftpmsg('Cannot read more than 16 bits (ftgcxi)')
            status=308
            return
        else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then
            call ftpmsg('Asked to read more bits than exist in'//
     &      ' the column (ftgcxi)')
            status=308
            return
        end if
 
 
        row=frow-1
        do 30 k=1,nrow
            row=row+1
C           get the individual bits
            call ftgcx(iunit,colnum,row,fbit,nbit,lray,status)
            if (status .gt. 0)return
            ival=0
            j=0
            if (nbit .eq. 16 .and. lray(1))then
C               interprete this as a 16 bit negative integer
                do 10 i=16,2,-1
                    j=j+1
                    if (.not. lray(i))ival=ival+power2(j)
10              continue
C               make 2's complement
                ivalue(k)=-ival-1
            else
C               reconstruct the positive integer value
                do 20 i=nbit,1,-1
                    j=j+1
                    if (lray(i))ival=ival+power2(j)
20              continue
                ivalue(k)=ival
            end if
30      continue
        end
        subroutine ftgcxj(iunit,colnum,frow,nrow,fbit,nbit,
     &             jvalue,status)
 
C       read any consecutive bits from an 'X' or 'B' column as an unsigned
C       n-bit integer, unless nbits=32 in which case the 32 bits
C       are interpreted as a 32-bit signed 2s complement word
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       nrow    i  number of rows to read
C       fbit    i  first bit within the row to read
C       nbit    i  number of bits to read
C       jvalue  i  returned integer value(s)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1994
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,jval
        integer jvalue(*),power2(32),ibuff
        logical lray(32)
        save power2
        data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,
     &  16384,32768,65536,131072,262144,524288,1048576,2097152,4194304,
     &  8388608,16777216,33554432,67108864,134217728,268435456,536870912
     &  ,1073741824,0/
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
        if (nbit .gt. 32)then
            call ftpmsg('Cannot read more than 32 bits (ftgcxj)')
            status=308
            return
        else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then
            call ftpmsg('Asked to read more bits than exist in'//
     &      ' the column (ftgcxj)')
            status=308
            return
        end if
 
        row=frow-1
        do 30 k=1,nrow
            row=row+1
C           get the individual bits
            call ftgcx(iunit,colnum,row,fbit,nbit,lray,status)
            if (status .gt. 0)return
 
            jval=0
            j=0
            if (nbit .eq. 32 .and. lray(1))then
C               interprete this as a 32 bit negative integer
                do 10 i=32,2,-1
                    j=j+1
                    if (.not. lray(i))jval=jval+power2(j)
10              continue
C               make 2's complement
                jvalue(k)=-jval-1
            else
C               reconstruct the positive integer value
                do 20 i=nbit,1,-1
                    j=j+1
                    if (lray(i))jval=jval+power2(j)
20              continue
                jvalue(k)=jval
            end if
30      continue
        end
        subroutine ftgdes(iunit,colnum,rownum,nelem,offset,status)
 
C       read the descriptor values from a binary table.  This is only
C       used for column which have TFORMn = 'P', i.e., for variable
C       length arrays.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       rownum  i  number of the row to read
C       nelem   i  output number of elements
C       offset  i  output byte offset of the first element
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1991
 
        integer iunit,colnum,rownum,nelem,offset,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart,iray(2)
 
        if (status .gt. 0)return
        if (rownum .lt. 1)then
C               error: illegal row number
                status=307
                return
        end if
 
        ibuff=bufnum(iunit)
 
C       check that this is really a 'P' type column
        if (tdtype(colnum+tstart(ibuff)) .ge. 0)then
                status=317
                return
        end if
 
C       move to the specified column and row:
        bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff)
     &         +tbcol(colnum+tstart(ibuff))
        call ftmbyt(iunit,bstart,.true.,status)
 
C       now read the number of elements and the offset to the table:
        call ftgi4b(iunit,2,0,iray,status)
        nelem=iray(1)
        offset=iray(2)
        end
        subroutine ftgerr(errnum,text)
 
C       Return a descriptive error message corresponding to the error number
 
C       errnum i  input symbolic error code presumably returned by another
C                 FITSIO subroutine
C       text   C*30  Descriptive error message
 
        integer errnum
        character*(*) text
 
C       nerror specifies the maxinum number of different error messages
        integer nerror
        parameter (nerror=100)
        character*30 errors(nerror)
        character*30 er1(10),er2(10),er3(10),er4(10),er5(10),er6(10)
        character*30 er7(10),er8(10),er9(10),er10(10)
        integer i,errcod(nerror)
        save errors
 
C       we equivalence the big array to several smaller ones, so that
C       the DATA statements will not have too many continuation lines.
        equivalence (errors(1), er1(1))
        equivalence (errors(11),er2(1))
        equivalence (errors(21),er3(1))
        equivalence (errors(31),er4(1))
        equivalence (errors(41),er5(1))
        equivalence (errors(51),er6(1))
        equivalence (errors(61),er7(1))
        equivalence (errors(71),er8(1))
        equivalence (errors(81),er9(1))
        equivalence (errors(91),er10(1))
 
        data errcod/0,101,102,103,104,105,106,107,108,109,110,111,
     &  201,202,203,204,205,206,207,208,209,211,212,213,214,215,216,
     &  217,218,221,222,223,224,225,226,227,228,229,230,231,232,
     &  241,251,252,261,262,
     &  302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,
     &  317,318,319,    401,402,403,404,405,406,407,408,409,411,112,
     &  210,233,220,219,301,320,321,322,263,323,113,114,234,253,254,
     &  255,412,235,236,501,502,503,504,505,237/
 
        data er1/
     & 'OK, no error',
     & 'Bad logical unit number',
     & 'Too many FITS files opened',
     & 'File not found; not opened',
     & 'Error opening existing file',
     & 'Error creating new FITS file',
     & 'Error writing to FITS file',
     & 'EOF while reading FITS file',
     & 'Error reading FITS file',
     & 'Bad blocking factor (1-28800)'/
 
        data er2/
     & 'Error closing FITS file',
     & 'Too many columns in table',
     & 'Header is not empty',
     & 'Specified keyword not found',
     & 'Bad keyword record number',
     & 'Keyword value is undefined',
     & 'Missing quote in string value',
     & 'Could not construct NAMEnnn',
     & 'Bad character in header record',
     & 'Keywords out of order?'/
 
        data er3/
     & 'Bad nnn value in NAMEnnn',
     & 'Illegal BITPIX keyword value',
     & 'Illegal NAXIS keyword value',
     & 'Illegal NAXISnnn keyword value',
     & 'Illegal PCOUNT keyword value',
     & 'Illegal GCOUNT keyword value',
     & 'Illegal TFIELDS keyword value',
     & 'Illegal NAXIS1 keyword value',
     & 'Illegal NAXIS2 keyword value',
     & 'SIMPLE keyword not found'/
 
        data er4/
     & 'BITPIX keyword not found',
     & 'NAXIS  keyword not found',
     & 'NAXISnnn keyword(s) not found',
     & 'XTENSION keyword not found',
     & 'CHDU is not an ASCII table',
     & 'CHDU is not a binary table',
     & 'PCOUNT keyword not found',
     & 'GCOUNT keyword not found',
     & 'TFIELDS keyword not found',
     & 'TBCOLnnn keywords not found'/
 
        data er5/
     & 'TFORMnnn keywords not found',
     & 'Row width not = field widths',
     & 'Unknown extension type',
     & 'Unknown FITS record type',
     & 'Cannot parse TFORM keyword',
     & 'Unknown TFORM datatype code',
     & 'Column number out of range',
     & 'Data structure not defined',
     & 'Negative file record number',
     & 'HDU start location is unknown'/
 
        data er6/
     & 'Requested no. of bytes < 0',
     & 'Illegal first row number',
     & 'Illegal first element number',
     & 'Bad TFORM for Character I/O',
     & 'Bad TFORM for Logical I/O',
     & 'Invalid ASCII table TFORM code',
     & 'Invalid BINTABLE TFORM code',
     & 'Error making formated string',
     & 'Null value is undefined',
     & 'Internal read error of string'/
 
        data er7/
     & 'Illegal logical column value',
     & 'Bad TFORM for descriptor I/O',
     & 'Variable array has 0 length',
     & 'End-of-rec in var. len. array',
     & 'Int to Char conversion error',
     & 'Real to Char conversion error',
     & 'Illegal Char to Int conversion',
     & 'Illegal Logical keyword value',
     & 'Illegal Char to R*4 conversion',
     & 'Illegal Char to R*8 conversion'/
 
        data er8/
     & 'Char to Int conversion error',
     & 'Char to Real conversion error',
     & 'Char to R*8 conversion error',
     & 'Illegal no. of decimal places',
     & 'Cannot modify a READONLY file',
     & 'END header keyword not found',
     & 'CHDU is not an IMAGE extension',
     & 'Illegal SIMPLE keyword value',
     & 'Column name (TTYPE) not found',
     & 'Out of bounds HDU number'/
 
        data er9/
     & 'Bad no. of array dimensions',
     & 'Max pixel less than min pixel',
     & 'Illegal BSCALE or TSCALn = 0',
     & 'Could not parse TDIMn keyword',
     & 'Axis length less than 1',
     & 'Incompatible FITSIO version',
     & 'All LUNs have been allocated',
     & 'TBCOLn value out of range',
     & 'END keyword value not blank ',
     & 'Header fill area not blank'/
 
        data er10/
     & 'Data fill area invalid',
     & 'Data type conversion overflow',
     & 'CHDU must be a table/bintable',
     & 'Column is too wide for table',
     & 'celestial angle too large',
     & 'bad celestial coordinate',
     & 'error in celestial coord calc',
     & 'unsupported projection',
     & 'missing celestial coord keywrd',
     & 'column name not unique'/
 
C       find the matching error code number
        do 10 i=1,nerror
                if (errnum .eq. errcod(i))then
                        text=errors(i)
                        return
                end if
10      continue
 
        text='Unknown FITSIO status code'
        end
        subroutine ftgext(iunit,extno,xtend,status)
 
C       'Get Extension'
C       move i/o pointer to another extension (or the primary HDU) and
C       initialize all the common block parameters which describe the
C       extension
 
C       iunit   i  fortran unit number
C       extno   i  number of the extension to point to.
C       xtend   i  type of extension:   0 = the primary HDU
C                                       1 = an ASCII table
C                                       2 = a binary table
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,extno,xtend,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,xchdu,xhdend,xmaxhd
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       move to the beginning of the desired extension
        call ftmbyt(iunit,hdstrt(ibuff,extno),.false.,status)
        if (status .le. 0)then
 
C               temporarily save parameters
                xchdu=chdu(ibuff)
                xmaxhd=maxhdu(ibuff)
                xhdend=hdend(ibuff)
 
C               initialize various parameters about the CHDU
                chdu(ibuff)=extno
                maxhdu(ibuff)=max(extno,maxhdu(ibuff))
C               the location of the END record is currently unknown, so
C               temporarily just set it to a very large number
                hdend(ibuff)=2000000000
 
C               determine the structure of the CHDU
                call ftrhdu(iunit,xtend,status)
                if (status .gt. 0)then
C                       couldn't read the extension so restore previous state
                        chdu(ibuff)= xchdu
                        maxhdu(ibuff)=xmaxhd
                        hdend(ibuff)= xhdend
                end if
        end if
        end
        subroutine ftggpb(iunit,group,fparm,nparm,array,status)
 
C       Read an array of group parameter values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter be read (starting with 1)
C       nparm   i  number of group parameters to be read
C       array   b  returned array of values that were read
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,fparm,nparm,status,row
        character*1 nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
C       set nulval to blank to inhibit checking for undefined values
        nulval=' '
        row=max(1,group)
        call ftgclb(iunit,1,row,fparm,nparm,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftggpd(iunit,group,fparm,nparm,array,status)
 
C       Read an array of group parameter values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter be read (starting with 1)
C       nparm   i  number of group parameters to be read
C       array   d  returned array of values that were read
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,fparm,nparm,status,row
        double precision nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
C       set nulval to blank to inhibit checking for undefined values
        nulval=0
        row=max(1,group)
        call ftgcld(iunit,1,row,fparm,nparm,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftggpe(iunit,group,fparm,nparm,array,status)
 
C       Read an array of group parameter values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter be read (starting with 1)
C       nparm   i  number of group parameters to be read
C       array   r  returned array of values that were read
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,fparm,nparm,status,row
        real nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
C       set nulval to blank to inhibit checking for undefined values
        nulval=0
        row=max(1,group)
        call ftgcle(iunit,1,row,fparm,nparm,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftggpi(iunit,group,fparm,nparm,array,status)
 
C       Read an array of group parameter values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter be read (starting with 1)
C       nparm   i  number of group parameters to be read
C       array   i*2  returned array of values that were read
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,fparm,nparm,status,row
        integer*2 nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
C       set nulval to blank to inhibit checking for undefined values
        nulval=0
        row=max(1,group)
        call ftgcli(iunit,1,row,fparm,nparm,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftggpj(iunit,group,fparm,nparm,array,status)
 
C       Read an array of group parameter values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter be read (starting with 1)
C       nparm   i  number of group parameters to be read
C       array   i  returned array of values that were read
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,fparm,nparm,status,row
        integer nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
C       set nulval to blank to inhibit checking for undefined values
        nulval=0
        row=max(1,group)
        call ftgclj(iunit,1,row,fparm,nparm,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftghad(iunit,curhdu,nxthdu)
 
C       return the starting byte address of the CHDU and the next HDU.
 
C       curhdu  i  starting address of the CHDU
C       nxthdu  i  starting address of the next HDU
 
C       written by Wm Pence, HEASARC/GSFC, May, 1995
 
        integer iunit,curhdu,nxthdu
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,hdunum
 
        ibuff=bufnum(iunit)
        hdunum=chdu(ibuff)
        curhdu=hdstrt(ibuff,hdunum)
        nxthdu=hdstrt(ibuff,hdunum+1)
        end
        subroutine ftghbn(iunit,maxfld,nrows,nfield,ttype,tform,
     &                    tunit,extnam,pcount,status)
 
C       read required standard header keywords from a binary table extension
C
C       iunit   i  Fortran i/o unit number
C       maxfld  i  maximum no. of fields to read; size of ttype array
C       OUTPUT PARAMETERS:
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array)
C       tform   c  format of each field (array)
C       tunit   c  units of each field (array)
C       extnam  c  name of table (optional)
C       pcount  i  size of special data area following the table (usually = 0)
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,maxfld,ncols,nrows,nfield,pcount,status,tstat
        integer maxf,i,nfind
        character*(*) ttype(*),tform(*),tunit(*),extnam
        character comm*72
 
C       check that this is a valid binary table and get parameters
        call ftgtbn(iunit,ncols,nrows,pcount,nfield,status)
        if (status .gt. 0)return
 
        if (maxfld .lt. 0)then
              maxf=nfield
        else if (maxfld .eq. 0)then
              go to 20
        else
              maxf=min(maxfld,nfield)
        end if
C       initialize optional keywords
        do 10 i=1,maxf
                ttype(i)=' '
                tunit(i)=' '
10      continue
 
        call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status)
        call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status)
 
        if (status .gt. 0)return
 
        call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status)
        if (status .gt. 0 .or. nfind .ne. maxf)then
                status=232
                return
        end if
 
20      extnam=' '
        tstat=status
        call ftgkys(iunit,'EXTNAME',extnam,comm,status)
C       this keyword is not required, so ignore status
        if (status .eq. 202)status =tstat
        end
        subroutine ftghdn(iunit,hdunum)
 
C       return the number of the current header data unit.  The
C       first HDU (the primary array) is number 1.
 
C       iunit   i  fortran unit number
C       hdunum  i  returned number of the current HDU
C
C       written by Wm Pence, HEASARC/GSFC, March, 1993
 
        integer iunit,hdunum
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        hdunum=chdu(bufnum(iunit))
        end
        subroutine ftghpr(iunit,maxdim,simple,bitpix,naxis,naxes,
     &                    pcount,gcount,extend,status)
 
C       get the required primary header or image extension keywords
C
C       iunit   i  fortran unit number to use for reading
C       maxdim  i  maximum no. of dimensions to read; dimension of naxes
C       OUTPUT PARAMETERS:
C       simple  l  does file conform to FITS standard?
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       pcount  i  number of group parameters (usually 0)
C       gcount  i  number of random groups (usually 1 or 0)
C       extend  l  may extensions be present in the FITS file?
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status
        integer maxdim,nblank
        logical simple,extend
        double precision fill
 
        call ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,
     &        pcount,gcount,extend,fill,fill,blank,nblank,status)
        end
        subroutine ftghps(iunit,nkeys,pos,status)
 
C       Get Header Position
C       get the number of keywords in the header and the current position
C       in the header, i.e.,  the number of the next keyword record that
C       would be read.
C
C       iunit   i  Fortran I/O unit number
C       pos     i  current position in header (1 = beginning of header)
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Jan 1995
 
        integer iunit,nkeys,pos,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        nkeys=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80
        pos=(nxthdr(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80+1
        end
        subroutine ftghsp(ounit,nexist,nmore,status)
 
C       Get Header SPace
C       return the number of additional keywords that will fit in the header
C
C       ounit   i  Fortran I/O unit number
C       nexist  i  number of keywords already present in the CHU
C       nmore   i  number of additional keywords that will fit in header
C                 -1 indicates that there is no limit to the number of keywords
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,nexist,nmore,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
 
        nexist=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80
        if (dtstrt(ibuff) .lt. 0)then
C               the max size of the header has not been defined, so there
C               is no limit to the number of keywords which may be written.
                nmore=-1
        else
                nmore=(dtstrt(ibuff)-hdend(ibuff))/80-1
        end if
        end
        subroutine ftghtb(iunit,maxfld,ncols,nrows,nfield,ttype,
     &                    tbcol,tform,tunit,extnam,status)
 
C       read required standard header keywords from an ASCII table extension
C
C       iunit   i  Fortran i/o unit number
C       maxfld  i  maximum no. of fields to read; dimension of ttype
C       OUTPUT PARAMETERS:
C       ncols   i  number of columns in the table
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array)
C       tbcol   i  beginning column of each field (array)
C       tform   c  Fortran-77 format of each field (array)
C       tunit   c  units of each field (array)
C       extnam  c  name of table (optional)
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,maxfld,ncols,nrows,nfield,status,tbcol(*)
        integer i,nfind,maxf,tstat
        character*(*) ttype(*),tform(*),tunit(*),extnam
        character comm*72
 
        call ftgttb(iunit,ncols,nrows,nfield,status)
        if (status .gt. 0)return
 
        if (maxfld .le. 0)then
                maxf=nfield
        else
                maxf=min(maxfld,nfield)
        end if
 
C       initialize optional keywords
        do 10 i=1,maxf
                ttype(i)=' '
                tunit(i)=' '
10      continue
 
        call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status)
        call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status)
 
        if (status .gt. 0)return
 
        call ftgknj(iunit,'TBCOL',1,maxf,tbcol,nfind,status)
        if (status .gt. 0 .or. nfind .ne. maxf)then
C               couldn't find the required TBCOL keywords
                status=231
        call ftpmsg('Required TBCOL keyword(s) not found in ASCII'//
     &  ' table header (FTGHTB).')
                return
        end if
 
        call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status)
        if (status .gt. 0 .or. nfind .ne. maxf)then
C               couldn't find the required TFORM keywords
                status=232
        call ftpmsg('Required TFORM keyword(s) not found in ASCII'//
     &  ' table header (FTGHTB).')
                return
        end if
 
        extnam=' '
        tstat=status
        call ftgkys(iunit,'EXTNAME',extnam,comm,status)
C       this keyword is not required, so ignore 'keyword not found' status
        if (status .eq. 202)status=tstat
        end
        subroutine ftgi1b(iunit,nvals,incre,chbuff,status)
 
C       Read an array of Integer*1 bytes from the input FITS file.
 
        integer nvals,incre,iunit,status,offset
        character*1 chbuff(nvals)
 
C       iunit   i  fortran unit number
C       nvals   i  number of pixels in the i2vals array
C       incre   i  byte increment between values
C       chbuff  c*1 array of input byte values
C       status  i  output error status
 
        if (incre .le. 1)then
                call ftgcbf(iunit,nvals,chbuff,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-1
                call ftgcbo(iunit,1,nvals,offset,chbuff,status)
        end if
        end
        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,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
 
        integer compid
        common/ftcpid/compid
 
        integer ierr,ieg2cray,i,nloop,fpixel,ntodo
        integer*2 temp(4)
        character ctemp*1
 
        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
                call ftgbyo(iunit,2,nvals,offset,i2vals,status)
        end if
 
        if (compid .eq. 0)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. -1)then
C           SUN F90 compiler maps I*2 -> I*4; have to unpack bytes
            call ftupi2(i2vals,nvals,ctemp)
        else if (compid .ge. 1)then
C           little endian machine (e.g. DEC, VAX, or PC) must be byte swapped
            call ftswby(i2vals,nvals)
        else
C           must be a CRAY
C           convert from IEEE I*2 to cray I*8
 
C           have to use a temporary array if nvals = 2 or 3
            if (nvals .le. 3)then
              ierr=ieg2cray(7,nvals,i2vals,0,temp,1,' ')
              do 5 i=1,nvals
                  i2vals(i)=temp(i)
5             continue
            else
 
C             have to work backwards, so as to not overwrite the input data
              nloop=(nvals-1)/4+1
              fpixel = (nloop*4)-3
              ntodo=nvals-(nloop-1)*4
              do 10 i=nloop,1,-1
                ierr=ieg2cray(7,ntodo,i2vals(i),0,i2vals(fpixel),1,' ')
                fpixel=fpixel-4
                ntodo=4
10            continue
            end if
        end if
        end
        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,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
 
        integer ierr,ieg2cray,nloop,fpixel,ntodo,i
 
        integer compid
        common/ftcpid/compid
 
        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
                call ftgbyo(iunit,4,nvals,offset,i4vals,status)
        end if
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .ge. 1)then
C           little endian machine (e.g. DEC, VAX, or PC) must be byte swapped
            call ftswi4(i4vals,nvals)
        else
C           must be a CRAY
C           convert from IEEE I*4 to cray I*8
C           have to work backwards, so as to not overwrite the input data
 
            nloop=(nvals+1)/2
            fpixel = (nloop*2)-1
            ntodo=nvals-(nloop-1)*2
            do 10 i=nloop,1,-1
                ierr=ieg2cray(1,ntodo,i4vals(i),0,i4vals(fpixel),1,' ')
                fpixel=fpixel-2
                ntodo=2
10          continue
        end if
        end
        subroutine ftgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,
     &                   type,status)
 
C       read the values of the celestial coordinate system keywords.
C       These values may be used as input to the subroutines that
C       calculate celestial coordinates. (FTXYPX, FTWLDP)
 
C       This routine assumes that the CHDU contains an image
C       with the RA type coordinate running along the first axis
C       and the DEC type coordinate running along the 2nd axis.
 
        double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot
        integer iunit,status,tstat
        character*(*) type
        character comm*20,ctype*8
 
        if (status .gt. 0)return
 
        call ftgkyd(iunit,'CRVAL1',xrval,comm,status)
        call ftgkyd(iunit,'CRVAL2',yrval,comm,status)
 
        call ftgkyd(iunit,'CRPIX1',xrpix,comm,status)
        call ftgkyd(iunit,'CRPIX2',yrpix,comm,status)
 
        call ftgkyd(iunit,'CDELT1',xinc,comm,status)
        call ftgkyd(iunit,'CDELT2',yinc,comm,status)
 
        call ftgkys(iunit,'CTYPE1',ctype,comm,status)
 
        if (status .gt. 0)then
            call ftpmsg('FTGICS could not find all the required'//
     &                  'celestial coordinate Keywords.')
            status=505
            return
        end if
 
        type=ctype(5:8)
 
        tstat=status
        call ftgkyd(iunit,'CROTA2',rot,comm,status)
        if (status .gt. 0)then
C           CROTA2 is assumed to = 0 if keyword is not present
            status=tstat
            rot=0.
        end if
        end
        subroutine ftgiou(iounit,status)
 
C       get an unallocated logical unit number
 
        integer iounit,status
 
        if (status .gt. 0)return
        iounit=0
        call ftxiou(iounit,status)
        end
        subroutine ftgkey(iunit,keynam,value,comm,status)
 
C       Read value and comment of a header keyword from the keyword buffer
 
C       iunit   i  Fortran I/O unit number
C       keynam  c  name of keyword to be read
C       OUTPUT PARAMETERS:
C       value   c  output value of the keyword, if any
C       comm    c  output comment string, if any, of the keyword
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,status
        character*(*) keynam,value,comm
        character*80 keybuf
 
        call ftgcrd(iunit,keynam,keybuf,status)
        if (status .le. 0)then
C               parse the record to find value and comment strings
                call ftpsvc(keybuf,value,comm,status)
        end if
        end
        subroutine ftgknd(iunit,keywrd,nstart,nmax,
     &                    dval,nfound,status)
 
C       read an array of real*8 values from  header records
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       nstart  i  starting sequence number (usually 1)
C       nmax    i  number of keywords to read
C       OUTPUT PARAMETERS:
C       dval    d  array of output keyword values
C       nfound  i  number of keywords found
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd
        double precision dval(*)
        integer iunit,nstart,nmax,nfound,status,tstat
        integer nkeys,mkeys,i,ival,nend,namlen,indval
        logical vnull
        character inname*8,keynam*8
        character*80 rec,value,comm
 
        if (status .gt. 0)return
 
C       for efficiency, we want to search just once through the header
C       for all the keywords which match the root.
 
        nfound=0
        nend=nstart+nmax-1
        inname=keywrd
        call ftupch(inname)
 
C       find the length of the root name
        namlen=0
        do 5 i=8,1,-1
                if (inname(i:i) .ne. ' ')then
                        namlen=i
                        go to 6
                end if
5       continue
6       if (namlen .eq. 0)return
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,mkeys,status)
 
        vnull = .false.
        do 10 i=3,nkeys
                call ftgrec(iunit,i,rec,status)
                if (status .gt. 0)return
                keynam=rec(1:8)
                if (keynam(1:namlen) .eq. inname(1:namlen))then
 
C                   try to interpret the remainder of the name as an integer
                    tstat=status
                    call ftc2ii(keynam(namlen+1:8),ival,status)
                    if (status .le. 0)then
                        if (ival .le. nend .and. ival .ge. nstart)then
                            call ftpsvc(rec,value,comm,status)
                            indval=ival-nstart+1
                            call ftc2d(value,dval(indval),status)
 
                            if (status .eq. 204)then
C                             value is undefined
                              status=0
                              vnull = .true.
                            end if
 
                            if (status .gt. 0)then
             call ftpmsg('Error in FTGKND evaluating '//keynam//
     &       ' as a Double: '//value)
                               return
                             else
                               nfound=max(nfound,indval)
                             end if
                        end if
                    else
                        if (status .eq. 407)then
                                status=tstat
                        else
                                return
                        end if
                    end if
                end if
10      continue
 
        if (status .le. 0 .and. vnull)then
C           one or more values were undefined
            status = 204
        end if
        end
        subroutine ftgkne(iunit,keywrd,nstart,nmax,
     &                    rval,nfound,status)
 
C       read an array of real*4 values from  header records
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       nstart  i  starting sequence number (usually 1)
C       nmax    i  number of keywords to read
C       OUTPUT PARAMETERS:
C       rval    r  array of output keyword values
C       nfound  i  number of keywords found
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd
        real rval(*)
        integer iunit,nstart,nmax,nfound,status,tstat
        integer nkeys,mkeys,i,ival,nend,namlen,indval
        logical vnull
        character inname*8,keynam*8
        character*80 rec,value,comm
 
        if (status .gt. 0)return
 
C       for efficiency, we want to search just once through the header
C       for all the keywords which match the root.
 
        nfound=0
        nend=nstart+nmax-1
        inname=keywrd
        call ftupch(inname)
 
C       find the length of the root name
        namlen=0
        do 5 i=8,1,-1
                if (inname(i:i) .ne. ' ')then
                        namlen=i
                        go to 6
                end if
5       continue
6       if (namlen .eq. 0)return
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,mkeys,status)
 
        vnull = .false.
        do 10 i=3,nkeys
                call ftgrec(iunit,i,rec,status)
                if (status .gt. 0)return
                keynam=rec(1:8)
                if (keynam(1:namlen) .eq. inname(1:namlen))then
 
C                   try to interpret the remainder of the name as an integer
                    tstat=status
                    call ftc2ii(keynam(namlen+1:8),ival,status)
                    if (status .le. 0)then
                        if (ival .le. nend .and. ival .ge. nstart)then
                            call ftpsvc(rec,value,comm,status)
                            indval=ival-nstart+1
                            call ftc2r(value,rval(indval),status)
 
                            if (status .eq. 204)then
C                             value is undefined
                              status=0
                              vnull = .true.
                            end if
 
                            if (status .gt. 0)then
             call ftpmsg('Error in FTGKNE evaluating '//keynam//
     &       ' as a Real: '//value)
                               return
                             else
                               nfound=max(nfound,indval)
                             end if
                        end if
                    else
                        if (status .eq. 407)then
                                status=tstat
                        else
                                return
                        end if
                    end if
                end if
10      continue
 
        if (status .le. 0 .and. vnull)then
C           one or more values were undefined
            status = 204
        end if
        end
        subroutine ftgknj(iunit,keywrd,nstart,nmax,intval,
     &                    nfound,status)
 
C       read an array of integer values from  header records
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       nstart  i  starting sequence number (usually 1)
C       nmax    i  number of keywords to read
C       OUTPUT PARAMETERS:
C       intval  i  array of output keyword values
C       nfound  i  number of keywords found
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd
        integer intval(*)
        integer iunit,nstart,nmax,nfound,status,tstat
        integer nkeys,mkeys,i,ival,nend,namlen,indval
        logical vnull
        character inname*8,keynam*8
        character*80 rec,value,comm
 
        if (status .gt. 0)return
 
C       for efficiency, we want to search just once through the header
C       for all the keywords which match the root.
 
        nfound=0
        nend=nstart+nmax-1
        inname=keywrd
        call ftupch(inname)
 
C       find the length of the root name
        namlen=0
        do 5 i=8,1,-1
                if (inname(i:i) .ne. ' ')then
                        namlen=i
                        go to 6
                end if
5       continue
6       if (namlen .eq. 0)return
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,mkeys,status)
 
        vnull = .false.
        do 10 i=3,nkeys
                call ftgrec(iunit,i,rec,status)
                if (status .gt. 0)return
                keynam=rec(1:8)
                if (keynam(1:namlen) .eq. inname(1:namlen))then
 
C                   try to interpret the remainder of the name as an integer
                    tstat=status
                    call ftc2ii(keynam(namlen+1:8),ival,status)
                    if (status .le. 0)then
                        if (ival .le. nend .and. ival .ge. nstart)then
                            call ftpsvc(rec,value,comm,status)
                            indval=ival-nstart+1
                            call ftc2i(value,intval(indval),status)
 
                            if (status .eq. 204)then
C                             value is undefined
                              status=0
                              vnull = .true.
                            end if
 
                            if (status .gt. 0)then
             call ftpmsg('Error in FTGKNJ evaluating '//keynam//
     &       ' as an integer: '//value)
                               return
                            else
                               nfound=max(nfound,indval)
                            end if
                        end if
                    else
                        if (status .eq. 407)then
                                status=tstat
                        else
                                return
                        end if
                    end if
                end if
10      continue
 
        if (status .le. 0 .and. vnull)then
C           one or more values were undefined
            status = 204
        end if
        end
        subroutine ftgknl(iunit,keywrd,nstart,nmax,logval,
     &                    nfound,status)
 
C       read an array of logical values from  header records
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       nstart  i  starting sequence number (usually 1)
C       nmax    i  number of keywords to read
C       OUTPUT PARAMETERS:
C       logval  l  array of output keyword values
C       nfound  i  number of keywords found
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd
        logical logval(*), vnull
        integer iunit,nstart,nmax,nfound,status,tstat
        integer nkeys,mkeys,i,ival,nend,namlen,indval
        character inname*8,keynam*8
        character*80 rec,value,comm
 
        if (status .gt. 0)return
 
C       for efficiency, we want to search just once through the header
C       for all the keywords which match the root.
 
        nfound=0
        nend=nstart+nmax-1
        inname=keywrd
        call ftupch(inname)
 
C       find the length of the root name
        namlen=0
        do 5 i=8,1,-1
                if (inname(i:i) .ne. ' ')then
                        namlen=i
                        go to 6
                end if
5       continue
6       if (namlen .eq. 0)return
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,mkeys,status)
 
        vnull = .false.
        do 10 i=3,nkeys
                call ftgrec(iunit,i,rec,status)
                if (status .gt. 0)return
                keynam=rec(1:8)
                if (keynam(1:namlen) .eq. inname(1:namlen))then
 
C                   try to interpret the remainder of the name as an integer
                    tstat=status
                    call ftc2ii(keynam(namlen+1:8),ival,status)
                    if (status .le. 0)then
                        if (ival .le. nend .and. ival .ge. nstart)then
                            call ftpsvc(rec,value,comm,status)
                            indval=ival-nstart+1
                            call ftc2ll(value,logval(indval),status)
                            nfound=max(nfound,indval)
 
                            if (status .eq. 204)then
C                             value is undefined
                              status=0
                              vnull = .true.
                            end if
                        end if
                    else
                        if (status .eq. 407)then
                                status=tstat
                        else
                                return
                        end if
                    end if
                end if
10      continue
 
        if (status .le. 0 .and. vnull)then
C           one or more values were undefined
            status = 204
        end if
        end
        subroutine ftgkns(iunit,keywrd,nstart,nmax,strval,nfound,
     &                    status)
 
C       read an array of character string values from  header records
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       nstart  i  starting sequence number (usually 1)
C       nmax    i  number of keywords to read
C       OUTPUT PARAMETERS:
C       strval  c  array of output keyword values
C       nfound  i  number of keywords found
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,strval(*)
        integer iunit,nstart,nmax,nfound,status,tstat
        integer nkeys,mkeys,i,ival,nend,namlen,indval,ibuff
        logical vnull
        character inname*8,keynam*8
        character*80 value,comm
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(iunit)
 
C       for efficiency, we want to search just once through the header
C       for all the keywords which match the root.
 
        nfound=0
        nend=nstart+nmax-1
        inname=keywrd
        call ftupch(inname)
 
C       find the length of the root name
        namlen=0
        do 5 i=8,1,-1
                if (inname(i:i) .ne. ' ')then
                        namlen=i
                        go to 6
                end if
5       continue
6       if (namlen .eq. 0)return
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,mkeys,status)
 
        vnull = .false.
        do 10 i=3,nkeys
                call ftgrec(iunit,i,value,status)
                if (status .gt. 0)return
                keynam=value(1:8)
                if (keynam(1:namlen) .eq. inname(1:namlen))then
 
C                   try to interpret the remainder of the name as an integer
                    tstat=status
                    call ftc2ii(keynam(namlen+1:8),ival,status)
                    if (status .le. 0)then
                      if (ival .le. nend .and. ival .ge. nstart)then
 
C                       OK, this looks like a valid keyword; Reset the
C                       next-header-keyword pointer by one record, then
C                       call ftgkys to read it. (This does  support
C                       long continued string values)
 
                        nxthdr(ibuff)=nxthdr(ibuff)-80
                        indval=ival-nstart+1
                        call ftgkys(iunit,keynam,strval(indval),
     &                              comm,status)
 
                        if (status .eq. 204)then
C                         value is undefined
                          status=0
                          vnull = .true.
                        end if
 
                        nfound=max(nfound,indval)
                      end if
                    else
                        if (status .eq. 407)then
                                status=tstat
                        else
                                return
                        end if
                    end if
                end if
10      continue
 
        if (status .le. 0 .and. vnull)then
C           one or more values were undefined
            status = 204
        end if
        end
        subroutine ftgkyd(iunit,keywrd,dval,comm,status)
 
C       read a double precision value and comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       dval    i  output keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer iunit,status
        character value*35
        double precision dval
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       convert character string to double precision
C       datatype conversion will be performed if necessary and if possible
        call ftc2d(value,dval,status)
        end
        subroutine ftgkye(iunit,keywrd,rval,comm,status)
 
C       read a real*4 value and the comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       rval    r  output keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer iunit,status
        character value*35
        real rval
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       convert character string to real
C       datatype conversion will be performed if necessary and if possible
        call ftc2r(value,rval,status)
        end
        subroutine ftgkyj(iunit,keywrd,intval,comm,status)
 
C       read an integer value and the comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       intval  i  output keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer iunit,intval,status
        character value*35
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       convert character string to integer
C       datatype conversion will be performed if necessary and if possible
        call ftc2i(value,intval,status)
        end
        subroutine ftgkyl(iunit,keywrd,logval,comm,status)
 
C       read a logical value and the comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       logval  l  output keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer iunit,status
        character value*20
        logical logval
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       convert character string to logical
        call ftc2l(value,logval,status)
        end
        subroutine ftgkyn(iunit,nkey,keynam,value,comm,status)
 
C       Read value and comment of the NKEYth header record
C       This routine is useful for reading the entire header, one
C       record at a time.
 
C       iunit   i  Fortran I/O unit number
C       nkey    i  sequence number (starting with 1) of the keyword to read
C       OUTPUT PARAMETERS:
C       keynam  c  output name of the keyword
C       value   c  output value of the keyword, if any
C       comm    c  output comment string, if any, of the keyword
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,nkey,status
        character*(*) keynam,value,comm
        character keybuf*80,arec*8
 
        if (status .gt. 0)return
 
        call ftgrec(iunit,nkey,keybuf,status)
        if (status .gt. 0)return
 
        keynam=keybuf(1:8)
 
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
        if (status .gt. 0)return
 
C       Test that keyword name contains only valid characters.
C       This also serves as a check in case there was no END keyword and
C       program continues to read on into the data unit
        call fttkey(keybuf(1:8),status)
        if (status .gt. 0)then
            write(arec,1000)nkey
1000        format(i8)
            call ftpmsg('Name of header keyword number'//arec//
     &     ' contains illegal character(s):')
            call ftpmsg(keybuf)
 
C          see if we are at the beginning of FITS logical record
           if (nkey-1 .eq. (nkey-1)/36*36 .and. nkey .gt. 1)then
             call ftpmsg('(This may indicate a missing END keyword).')
           end if
        end if
        end
        subroutine ftgkys(iunit,keywrd,strval,comm,status)
 
C       read a character string value and comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       strval  c  output keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C       modified 6/93 to support long strings which are continued
C       over several keywords.  A string may be continued by putting
C       a backslash as the last non-blank character in the keyword string,
C       then continuing the string in the next keyword which must have
C       a blank keyword name.
C       Modified 9/94 to support the new OGIP continuation convention
 
        character*(*) keywrd,comm,strval
        integer status,iunit
        character value*70, comm2*70, bslash*1
        integer clen,i,bspos,lenval
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       convert character string to unquoted string
        call ftc2s(value,strval,status)
 
        if (status .gt. 0)return
 
        clen=len(strval)
 
C       is last character a backslash or & ?
C       have to use 2 \\'s because the SUN compiler treats 1 \ as an escape
        bslash='\\'
        do 10 i=70,1,-1
                if (value(i:i) .ne. ' ' .and. value(i:i).ne.'''')then
                        if (value(i:i) .eq. bslash .or.
     &                      value(i:i) .eq. '&')then
C                               have to subtract 1 due to the leading quote char
                                bspos=i-1
                                go to 20
                        end if
C                       no continuation character, so just return
                        return
                end if
10      continue
C       value field was blank, so just return
        return
 
C       try to get the string continuation, and new comment string
20      call ftgnst(iunit,value,lenval,comm2,status)
        if (lenval .eq. 0)return
 
        if (bspos .le. clen)then
                strval(bspos:)=value(1:lenval)
                bspos=bspos+lenval-1
        end if
 
        if (comm2 .ne. ' ')comm=comm2
 
C       see if there is another continuation line
        if (value(lenval:lenval) .eq. bslash .or.
     &      value(lenval:lenval) .eq. '&')go to 20
        end
        subroutine ftgkyt(iunit,keywrd,jval,dval,comm,status)
 
C       read an integer value and fractional parts of a keyword value
C       and the comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       jval    i  output integer part of keyword value
C       dval    d  output fractional part of keyword value
C       comm    c  output keyword comment
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, Sept 1992
 
        character*(*) keywrd,comm
        integer iunit,jval,status,i,dot
        double precision dval
        character value*35
        logical ed
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
C       read keyword in straight forward way first:
C       just convert character string to double precision
C       datatype conversion will be performed if necessary and if possible
        call ftc2d(value,dval,status)
        jval=dval
        if (jval .ge. 0)then
                dval=dval-jval
        else
                dval=dval+jval
        end if
 
C       now see if we have to read the fractional part again, this time
C       with more precision
 
C       find the decimal point, if any, and look for a D or E
        dot=0
        ed=.false.
        do 10 i=1,35
            if (value(i:i) .eq. '.')dot=i
            if (value(i:i) .eq. 'E' .or. value(i:i) .eq. 'D')ed=.true.
10      continue
 
        if (.not. ed .and. dot .gt. 0)then
C           convert fractional part to double precision
            call ftc2d(value(dot:),dval,status)
        end if
 
        end
        subroutine ftgmsg(text)
 
C       get error message from top of stack and shift the stack up one message
        character*(*) text
        call ftxmsg(-1,text)
        end
        subroutine ftgnst(iunit,value,lenval,comm,status)
 
C       get the next string keyword.
C       see if the next keyword in the header is the continuation
C       of a long string keyword, and if so, return the value string,
C       the number of characters in the string, and the associated comment
C       string.
 
C       value  c  returned value of the string continuation
C       lenval i  number of non-blank characters in the continuation string
C       comm   C  value of the comment string, if any, in this keyword.
 
        character*(*) value,comm
        integer iunit,lenval,status
 
        integer i,length,tstat,nkeys,nextky
        character record*80, strval*70
 
        if (status .gt. 0)return
 
        tstat=status
        value=' '
        comm=' '
        lenval=0
 
C       get current header position
        call ftghps(iunit,nkeys,nextky,status)
 
C       get the next keyword record
        if (nextky .le. nkeys)then
            call ftgrec(iunit,nextky,record,status)
        else
C           positioned at end of header, so there is no next keyword to read
            return
        end if
 
C       does this appear to be a continuation keyword (=blank keyword name
C       or CONTINUE)?
        if (record(1:10) .ne. ' ' .and. record(1:10) .ne.
     &     'CONTINUE  ')return
 
C       return if record is blank
        if (record .eq. ' ')return
 
C       set a dummy keyword name
        record(1:10)='DUMMYKEY= '
 
C       parse the record to get the value string and comment
        call ftpsvc(record,strval,comm,status)
 
C       convert character string to unquoted string
        call ftc2s(strval,value,status)
        if (status .gt. 0)then
C               this must not be a continuation card; reset status and messages
                status=tstat
                call ftcmsg
                value=' '
                comm=' '
                return
        end if
 
        length=len(value)
        do 10 i=length,1,-1
                if (value(i:i) .ne. ' ')then
                        lenval=i
                        return
                end if
10      continue
        end
        subroutine ftgnxk(iunit,inclst,ninc,exclst,nexc,card,status)
 
C    Return the next keyword that matches one of the names in inclist
C    but does not match any of the names in exclist.  The search
C    goes from the current position to the end of the header, only.
C    Wild card characters may be used in the name lists ('*', '?' and '#').
 
C       iunit   i  Fortran I/O unit number
C       inclist c  list of included keyword names
C       ninc    i number of names in inclist
C       exclist c list of excluded keyword names
C       nexc    i number of names in exclist
C       OUTPUT PARAMETERS:
C       card    c  first matching 80 character card image
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, January 1997
 
        integer iunit,ninc,nexc,status,ii,jj
        character*(*) inclst(*),exclst(*),card
        character*80 keybuf
        logical casesn,match,exact
 
        card=' '
        if (status .gt. 0)return
        casesn=.false.
 
10      call ftgcrd(iunit,'*',keybuf,status)
        if (status .le. 0)then
          do 30 ii = 1, ninc
            call ftcmps(inclst(ii),keybuf(1:8),casesn,match,exact)
            if (match)then
              do 20 jj = 1,nexc
                call ftcmps(exclst(jj),keybuf(1:8),casesn,match,exact)
C               reject this card if in exclusion list
                if (match)go to 10
20            continue
 
C             keyword is not excluded, so return it
              card = keybuf
              return
            end if
30        continue
 
C         didn't match, so go back to read next keyword
          go to 10
        end if
 
C       failed to read next keyword (probably hit end of header)
        end
        subroutine ftgpfb(iunit,group,felem,nelem,
     &                    array,flgval,anynul,status)
 
C       Read an array of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will have the corresponding element of
C       FLGVAL set equal to .true.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       array   b  returned array of values that were read
C       flgval  l  set to .true. if the corresponding element is undefined
C       anynul  l  set to .true. if any returned elements are undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        character*1 nulval,array(*)
        logical anynul,flgval(*)
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgclb(iunit,2,row,felem,nelem,1,2,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpfd(iunit,group,felem,nelem,
     &                    array,flgval,anynul,status)
 
C       Read an array of r*8 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will have the corresponding element of
C       FLGVAL set equal to .true.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       array   d  returned array of values that were read
C       flgval  l  set to .true. if the corresponding element is undefined
C       anynul  l  set to .true. if any returned elements are undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        double precision nulval,array(*)
        logical anynul,flgval(*)
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcld(iunit,2,row,felem,nelem,1,2,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpfe(iunit,group,felem,nelem,
     &                    array,flgval,anynul,status)
 
C       Read an array of r*4 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will have the corresponding element of
C       FLGVAL set equal to .true.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       array   r  returned array of values that were read
C       flgval  l  set to .true. if the corresponding element is undefined
C       anynul  l  set to .true. if any returned elements are undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        real nulval,array(*)
        logical anynul,flgval(*)
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcle(iunit,2,row,felem,nelem,1,2,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpfi(iunit,group,felem,nelem,
     &                    array,flgval,anynul,status)
 
C       Read an array of I*2 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will have the corresponding element of
C       FLGVAL set equal to .true.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       array   i*2  returned array of values that were read
C       flgval  l  set to .true. if the corresponding element is undefined
C       anynul  l  set to .true. if any returned elements are undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        integer*2 nulval,array(*)
        logical anynul,flgval(*)
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcli(iunit,2,row,felem,nelem,1,2,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpfj(iunit,group,felem,nelem,
     &                    array,flgval,anynul,status)
 
C       Read an array of I*4 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will have the corresponding element of
C       FLGVAL set equal to .true.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       array   i  returned array of values that were read
C       flgval  l  set to .true. if the corresponding element is undefined
C       anynul  l  set to .true. if any returned elements are undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        integer nulval,array(*)
        logical anynul,flgval(*)
        integer i
 
        do 10 i=1,nelem
                flgval(i)=.false.
10      continue
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgclj(iunit,2,row,felem,nelem,1,2,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount
     &               ,gcount,extend,bscale,bzero,blank,nblank,status)
 
C       get the main primary header keywords which define the array structure
C
C       iunit   i  fortran unit number to use for reading
C       maxdim  i  maximum no. of dimensions to read; dimension of naxes
C       OUTPUT PARAMETERS:
C       simple  l  does file conform to FITS standard?
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       pcount  i  number of group parameters (usually 0)
C       gcount  i  number of random groups (usually 1 or 0)
C       extend  l  may extensions be present in the FITS file?
C       bscale  d  scaling factor
C       bzero   d  scaling zero point
C       blank   i  value used to represent undefined pixels
C       nblank  i  number of trailing blank keywords immediately before the END
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,maxdim,bitpix,naxis
        integer naxes(*),pcount,gcount,blank,status,tstat
        logical simple,extend,unknow
        character keynam*8,value*20,lngval*40,comm*72,extn*4,keybuf*80
        double precision bscale,bzero
        integer nkey,nblank,i,ibuff,taxes,maxd
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check that the first keyword is valid
        call ftgrec(iunit,1,keybuf,status)
 
        keynam=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
 
        if (status .gt. 0)go to 900
 
        simple=.true.
        unknow=.false.
        if (chdu(ibuff) .eq. 1)then
            if (keynam .eq. 'SIMPLE')then
                if (value .eq. 'F')then
C                       this is not a simple FITS file; try to process it anyway
                        simple=.false.
                else if (value .ne. 'T')then
C                       illegal value for the SIMPLE keyword
                        status=220
 
         if (keybuf(9:10) .ne. '= ')then
           call ftpmsg('The SIMPLE keyword is missing "= " in '//
     &     'columns 9-10.')
         else
           call ftpmsg('The SIMPLE keyword value is illegal:'//value
     &     // '.  It must equal T or F:')
         end if
 
                        call ftpmsg(keybuf)
                end if
            else
                status=221
        call ftpmsg('First keyword of the file is not SIMPLE: '//keynam)
                call ftpmsg(keybuf)
                go to 900
            end if
        else
             if (keynam .eq. 'XTENSION')then
                if (value(2:9) .ne. 'IMAGE   ' .and.
     &              value(2:9) .ne. 'IUEIMAGE')then
C                    I don't know what type of extension this is, but press on
                     unknow=.true.
 
         if (keybuf(9:10) .ne. '= ')then
           call ftpmsg('The XTENSION keyword is missing "= " in '//
     &     'columns 9-10.')
         else
           call ftpmsg('This is not an IMAGE extension: '//value)
         end if
 
                     call ftpmsg(keybuf)
                 end if
             else
                 status=225
                 write(extn,1000)chdu(ibuff)
1000             format(i4)
                 call ftpmsg('First keyword in extension '//extn//
     &           ' was not XTENSION: '//keynam)
                 call ftpmsg(keybuf)
             end if
        end if
        if (status .gt. 0)go to 900
 
C       check that BITPIX is the second keyword
        call ftgrec(iunit,2,keybuf,status)
 
        keynam=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
 
        if (status .gt. 0)go to 900
        if (keynam .ne. 'BITPIX')then
                status=222
        call ftpmsg('Second keyword was not BITPIX: '//keynam)
                call ftpmsg(keybuf)
                go to 900
        end if
C       convert character string to integer
        call ftc2ii(value,bitpix,status)
        if (status .gt. 0)then
C         bitpix value must be an integer
          if (keybuf(9:10) .ne. '= ')then
             call ftpmsg('BITPIX keyword is missing "= "'//
     &      ' in columns 9-10.')
          else
              call ftpmsg('Value of BITPIX is not an integer: '//value)
          end if
          call ftpmsg(keybuf)
          status=211
          go to 900
        end if
 
C       test that bitpix has a legal value
        call fttbit(bitpix,status)
        if (status .gt. 0)then
                call ftpmsg(keybuf)
                go to 900
        end if
 
C       check that the third keyword is NAXIS
        call ftgtkn(iunit,3,'NAXIS',naxis,status)
        if (status .eq. 208)then
C               third keyword was not NAXIS
                status=223
        else if (status .eq. 209)then
C               NAXIS value was not an integer
                status=212
        end if
        if (status .gt. 0)go to 900
 
        if (maxdim .le. 0)then
                maxd=naxis
        else
                maxd=min(maxdim,naxis)
        end if
 
        do 10 i=1,naxis
C               construct keyword name
                call ftkeyn('NAXIS',i,keynam,status)
C               attempt to read the keyword
                call ftgtkn(iunit,3+i,keynam,taxes,status)
                if (status .gt. 0)then
                        status=224
                        go to 900
                else if (taxes .lt. 0)then
C                       NAXISn keywords must not be negative
                        status=213
                        go to 900
                else if (i .le. maxd)then
                        naxes(i)=taxes
                end if
10      continue
 
C       now look for other keywords of interest: bscale, bzero, blank, and END
C       and pcount, gcount, and extend
15      bscale=1.
        bzero=0.
        pcount=0
        gcount=1
        extend=.false.
C       choose a special value to represent the absence of a blank value
        blank=123454321
 
        nkey=3+naxis
18      nblank=0
20      nkey=nkey+1
        tstat=status
        call ftgrec(iunit,nkey,keybuf,status)
        if (status .gt. 0)then
C               first, check for normal end-of-header status, and reset to 0
                if (status .eq. 203)status=tstat
C               if we hit the end of file, then set status = no END card found
                if (status .eq. 107)then
                       status=210
                       call ftpmsg('FITS header has no END keyword!')
                end if
                go to 900
        end if
        keynam=keybuf(1:8)
        comm=keybuf(9:80)
 
        if (keynam .eq. 'BSCALE')then
C               convert character string to floating pt.
                call ftpsvc(keybuf,lngval,comm,status)
                call ftc2dd(lngval,bscale,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading BSCALE keyword value'//
     &               ' as a Double:'//lngval)
                end if
        else if (keynam .eq. 'BZERO')then
C               convert character string to floating pt.
                call ftpsvc(keybuf,lngval,comm,status)
                call ftc2dd(lngval,bzero,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading BZERO keyword value'//
     &               ' as a Double:'//lngval)
                end if
        else if (keynam .eq. 'BLANK')then
C               convert character string to integer
                call ftpsvc(keybuf,value,comm,status)
                call ftc2ii(value,blank,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading BLANK keyword value'//
     &               ' as an integer:'//value)
                end if
        else if (keynam .eq. 'PCOUNT')then
C               convert character string to integer
                call ftpsvc(keybuf,value,comm,status)
                call ftc2ii(value,pcount,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading PCOUNT keyword value'//
     &               ' as an integer:'//value)
                end if
        else if (keynam .eq. 'GCOUNT')then
C               convert character string to integer
                call ftpsvc(keybuf,value,comm,status)
                call ftc2ii(value,gcount,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading GCOUNT keyword value'//
     &               ' as an integer:'//value)
                end if
        else if (keynam .eq. 'EXTEND')then
C               convert character string to logical
                call ftpsvc(keybuf,value,comm,status)
                call ftc2ll(value,extend,status)
                if (status .gt. 0)then
                     call ftpmsg('Error reading EXTEND keyword value'//
     &               ' as a Logical:'//value)
                 end if
        else if (keynam .eq. ' ' .and. comm .eq. ' ')then
C               need to ignore trailing blank records before the END card
                nblank=nblank+1
                go to 20
        else if (keynam .eq. 'END')then
                go to 900
        end if
        if (status .gt. 0)go to 900
        go to 18
 
900     continue
 
        if (status .gt. 0)then
          if (chdu(ibuff) .eq. 1)then
            call ftpmsg('Failed to parse the required keywords in '//
     &       'the Primary Array header ')
          else
            call ftpmsg('Failed to parse the required keywords in '//
     &       'the Image Extension header (FTGPHX).')
          end if
 
        else if (unknow)then
C           set status if this was an unknown type of extension
            status=233
        end if
        end
        subroutine ftgprh(iunit,simple,bitpix,naxis,naxes,
     &                    pcount,gcount,extend,status)
 
C       OBSOLETE routine: should call ftghpr instead
 
        integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status
        integer nblank
        logical simple,extend
        double precision fill
 
        call ftgphx(iunit,0,simple,bitpix,naxis,naxes,
     &        pcount,gcount,extend,fill,fill,blank,nblank,status)
        end
        subroutine ftgpvb(iunit,group,felem,nelem,nulval,
     &                    array,anynul,status)
 
C       Read an array of byte values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will be set equal to NULVAL, unless NULVAL=0
C       in which case no checking for undefined values will be performed.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       nulval  b  the value to be assigned to undefined pixels
C       array   b  returned array of values that were read
C       anynul  l  set to .true. if any returned elements were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        character nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgclb(iunit,2,row,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpvd(iunit,group,felem,nelem,nulval,
     &                    array,anynul,status)
 
C       Read an array of r*8 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will be set equal to NULVAL, unless NULVAL=0
C       in which case no checking for undefined values will be performed.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       nulval  b  the value to be assigned to undefined pixels
C       array   b  returned array of values that were read
C       anynul  l  set to .true. if any returned elements were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        double precision nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcld(iunit,2,row,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpve(iunit,group,felem,nelem,nulval,
     &                    array,anynul,status)
 
C       Read an array of r*4 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will be set equal to NULVAL, unless NULVAL=0
C       in which case no checking for undefined values will be performed.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       nulval  r  the value to be assigned to undefined pixels
C       array   r  returned array of values that were read
C       anynul  l  set to .true. if any returned elements were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        real nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcle(iunit,2,row,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpvi(iunit,group,felem,nelem,nulval,
     &                    array,anynul,status)
 
C       Read an array of i*2 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will be set equal to NULVAL, unless NULVAL=0
C       in which case no checking for undefined values will be performed.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       nulval  i*2  the value to be assigned to undefined pixels
C       array   i*2  returned array of values that were read
C       anynul  l  set to .true. if any returned elements were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        integer*2 nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgcli(iunit,2,row,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        subroutine ftgpvj(iunit,group,felem,nelem,nulval,
     &                    array,anynul,status)
 
C       Read an array of i*4 values from the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
C       Undefined elements will be set equal to NULVAL, unless NULVAL=0
C       in which case no checking for undefined values will be performed.
C       ANYNUL is return with a value of .true. if any pixels were undefined.
 
C       iunit   i  Fortran unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be read (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be read
C       nulval  i  the value to be assigned to undefined pixels
C       array   i  returned array of values that were read
C       anynul  l  set to .true. if any returned elements were undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,group,felem,nelem,status,row
        integer nulval,array(*)
        logical anynul,flgval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(1,group)
        call ftgclj(iunit,2,row,felem,nelem,1,1,nulval,
     &      array,flgval,anynul,status)
        end
        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,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
 
        integer ierr,ieg2cray,nloop,fpixel,ntodo,i
 
        integer compid
        common/ftcpid/compid
 
        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
                call ftgbyo(iunit,4,nvals,offset,r4vals,status)
        end if
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. 1)then
C           little endian machine (e.g. DEC or PC) must be byte swapped
            call ftswi4(r4vals,nvals)
        else if (compid .ge. 2)then
C           convert the values from IEEE format to VAX floating point format
C           first, swap the bytes
            call ftswby(r4vals,nvals*2)
C           then test for IEEE special values and multiply value by 4.0
            call ftr4vx(r4vals,r4vals,nvals)
        else
C           must be a CRAY
C           convert from IEEE R*4 to cray R*8
C           have to work backwards, so as to not overwrite the input data
 
            nloop=(nvals+1)/2
            fpixel = (nloop*2)-1
            ntodo=nvals-(nloop-1)*2
            do 10 i=nloop,1,-1
                ierr=ieg2cray(2,ntodo,r4vals(i),0,r4vals(fpixel),1,' ')
                fpixel=fpixel-2
                ntodo=2
10          continue
        end if
        end
        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,offset
        double precision r8vals(nvals)
 
C       iunit   i  fortran unit number
C       nvals   i  number of pixels to read
C       incre   i  byte increment between values
C       r8vals  d  output array of real*8 values
C       status  i  output error status
 
        integer compid
        common/ftcpid/compid
 
        integer ierr,ieg2cray,nloop,fpixel,ntodo,i
 
        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
                call ftgbyo(iunit,8,nvals,offset,r8vals,status)
        end if
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. 1)then
C           little endian machine (e.g. DEC or PC) must be byte swapped
            call ftswi8(r8vals,nvals)
        else if (compid .eq. 2)then
C           convert the values from IEEE format to VAX double (D) format
            call ieevud(r8vals,r8vals,nvals)
        else if (compid .eq. 3)then
C           convert the values from IEEE format to VMS double (G) format
C           first, swap the bytes
            call ftswby(r8vals,nvals*4)
C           then test for IEEE special values and multiply value by 4.0
            call ftr8vx(r8vals,r8vals,r8vals,nvals)
        else
C           must be a CRAY
C           convert from IEEE R*8 to cray R*16
C           have to work backwards, so as to not overwrite the input data
 
            nloop=(nvals+1)/2
            fpixel = (nloop*2)-1
            ntodo=nvals-(nloop-1)*2
            do 10 i=nloop,1,-1
                ierr=ieg2cray(3,ntodo,r8vals(i),0,r8vals(fpixel),1,' ')
                fpixel=fpixel-2
                ntodo=2
10          continue
        end if
        end
        subroutine ftgrec(iunit,nrec,record,status)
 
C       Read the Nth 80-byte header record
C       This routine is useful for reading the entire header, one
C       record at a time.
 
C       iunit   i  Fortran I/O unit number
C       nrec    i  sequence number (starting with 1) of the record to read
C       OUTPUT PARAMETERS:
C       record  c  output 80-byte record
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,nrec,status
        character*(*) record
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,nbyte,endhd
        character arec*8
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(iunit)
 
C       calculate byte location of the record, and check if it is legal
        nbyte=hdstrt(ibuff,chdu(ibuff))+(nrec-1)*80
 
C       endhd=(hdend(ibuff)/2880+1)*2880
C       modified this on 4 Nov 1994 to allow for blanks before the END keyword
        endhd=max(hdend(ibuff),dtstrt(ibuff)-2880)
 
        if (nrec .eq. 0)then
C               simply move to the beginning of the header
C               update the keyword pointer position
                nxthdr(ibuff)=nbyte+80
                record=' '
                return
        else if (nbyte .gt. endhd .or. nrec .lt. 0)then
C               header record number is out of bounds
                status=203
                write(arec,1000)nrec
1000            format(i8)
                call ftpmsg('Cannot get Keyword number '//arec//'.'//
     &          '  It does not exist.')
                go to 100
        end if
 
C       position the I/O pointer to the appropriate header keyword
        call ftmbyt(iunit,nbyte,.false.,status)
 
C       read the 80 byte record
        call ftgcbf(iunit,80,record,status)
        if (status .gt. 0)then
                write(arec,1000)nrec
                call ftpmsg('FTGREC could not read header keyword'//
     &            ' number '//arec//'.')
                return
        end if
 
C       update the keyword pointer position
        nxthdr(ibuff)=nbyte+80
 
100     continue
        end
        subroutine ftgrsz(iunit,nrows,status)
 
C       Returns an optimal value for the number of rows that should be
C       read or written at one time in a binary table for maximum efficiency.
C       Accessing more rows than this may cause excessive flushing and
C       rereading of buffers to/from disk.
 
C       iunit   i  fortran unit number
C       nrows   i  optimal number of rows to access
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, December, 1996
 
        integer iunit,nrows,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,nf,ne,pb
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff, ii, jj, unique, nfiles
 
C       There are pb internal buffers available each reclen(nb) bytes long
        ibuff=bufnum(iunit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status)
        if (status .gt. 0)return
 
C       determine how many different FITS files are currently open
        nfiles = 0
        do 20 ii = 1,nb
           unique = 1
           do 10 jj = 1, ii-1
             if (buflun(ii) .le. 0 .or. buflun(ii) .eq. buflun(jj))then
               unique = 0
               go to 15
             end if
10         continue
15         continue
 
           if (unique .eq. 1)nfiles=nfiles+1
20      continue
 
C       one buffer (at least) is always allocated to each open file.
C       assume record size is 2880 bytes (not necessarily true on Vax)
 
        nrows = ((pb - nfiles) * 2880) / max(1,rowlen(ibuff))
        nrows = max(1, nrows)
        end
        subroutine ftgsfb(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  array,flgval,anynul,status)
 
C       read a subsection of byte data values from an image or
C       a table column. Returns an associated array of null value flags.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set to .true. if corresponding array element is undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        character*1 array(*),nulval
        logical anynul,anyf,flgval(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFB '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=2
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSFB, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgclb(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),flgval(i1),anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsfd(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  array,flgval,anynul,status)
 
C       read a subsection of double precision data values from an image or
C       a table column.  Returns an associated array of null value flags.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set to .true. if corresponding array element is undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        double precision array(*),nulval
        logical anynul,anyf,flgval(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFD '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=2
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSFD, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcld(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),flgval(i1),anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsfe(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  array,flgval,anynul,status)
 
C       read a subsection of real data values from an image or
C       a table column.  Returns an associated array of null value flags.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set to .true. if corresponding array element is undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        real array(*),nulval
        logical anynul,anyf,flgval(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFE '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=2
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSFE, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcle(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),flgval(i1),anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsfi(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  array,flgval,anynul,status)
 
C       read a subsection of integer*2 data values from an image or
C       a table column.  Returns an associated array of null value flags.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set to .true. if corresponding array element is undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        integer*2 array(*),nulval
        logical anynul,anyf,flgval(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFI '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=2
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSFI, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcli(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),flgval(i1),anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsfj(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  array,flgval,anynul,status)
 
C       read a subsection of integer*4 data values from an image or
C       a table column.  Returns an associated array of null value flags.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       array   i  array of data values that are read from the FITS file
C       flgval  l  set to .true. if corresponding array element is undefined
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        integer array(*),nulval
        logical anynul,anyf,flgval(*)
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFJ '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=2
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSFJ, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgclj(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),flgval(i1),anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsvb(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  nulval,array,anynul,status)
 
C       read a subsection of byte data values from an image or
C       a table column.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       nulval  i  value that undefined pixels will be set to
C       array   i  array of data values that are read from the FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        character*1 array(*),nulval
        logical anynul,anyf
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        logical ldummy
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVB '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=1
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSVB, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgclb(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),ldummy,anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsvd(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  nulval,array,anynul,status)
 
C       read a subsection of double precision data values from an image or
C       a table column.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       nulval  i  value that undefined pixels will be set to
C       array   i  array of data values that are read from the FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        double precision array(*),nulval
        logical anynul,anyf
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        logical ldummy
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVD '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=1
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSVD, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcld(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),ldummy,anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsve(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  nulval,array,anynul,status)
 
C       read a subsection of real data values from an image or
C       a table column.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       nulval  i  value that undefined pixels will be set to
C       array   i  array of data values that are read from the FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        real array(*),nulval
        logical anynul,anyf
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        logical ldummy
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVE '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=1
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSVE, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcle(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),ldummy,anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsvi(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  nulval,array,anynul,status)
 
C       read a subsection of integer*2 data values from an image or
C       a table column.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       nulval  i  value that undefined pixels will be set to
C       array   i  array of data values that are read from the FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        integer*2 array(*),nulval
        logical anynul,anyf
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        logical ldummy
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVI '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=1
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSVI, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgcli(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),ldummy,anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgsvj(iunit,colnum,naxis,naxes,blc,trc,inc,
     &  nulval,array,anynul,status)
 
C       read a subsection of integer*4 data values from an image or
C       a table column.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to read from
C       naxis   i  number of dimensions in the FITS array
C       naxes   i  size of each dimension.
C       blc     i  'bottom left corner' of the subsection to be read
C       trc     i  'top right corner' of the subsection to be read
C       inc     i  increment to be applied in each dimension
C       nulval  i  value that undefined pixels will be set to
C       array   i  array of data values that are read from the FITS file
C       anynul  l  set to .true. if any of the returned values are undefined
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1993
 
        integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status
        integer array(*),nulval
        logical anynul,anyf
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc
        integer str(9),stp(9),incr(9),dsize(10)
        integer felem,nelem,nultyp,ninc,ibuff,numcol
        logical ldummy
        character caxis*20
 
C       this routine is set up to handle a maximum of nine dimensions
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 9)then
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVJ '
     &          //'is illegal.')
                return
        end if
 
C       if this is a primary array, then the input COLNUM parameter should
C       be interpreted as the row number, and we will alway read the image
C       data from column 2 (any group parameters are in column 1).
 
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 0)then
C               this is a primary array, or image extension
                if (colnum .eq. 0)then
                    rstr=1
                    rstp=1
                else
                    rstr=colnum
                    rstp=colnum
                end if
                rinc=1
                numcol=2
        else
C               this is a table, so the row info is in the (naxis+1) elements
                rstr=blc(naxis+1)
                rstp=trc(naxis+1)
                rinc=inc(naxis+1)
                numcol=colnum
        end if
 
        nultyp=1
        anynul=.false.
        i1=1
        do 5 i=1,9
                str(i)=1
                stp(i)=1
                incr(i)=1
                dsize(i)=1
5       continue
        do 10 i=1,naxis
                if (trc(i) .lt. blc(i))then
                        status=321
                        write(caxis,1001)i
        call ftpmsg('In FTGSVJ, the range specified for axis '//
     &  caxis(19:20)//' has the start greater than the end.')
                        return
                end if
                str(i)=blc(i)
                stp(i)=trc(i)
                incr(i)=inc(i)
                dsize(i+1)=dsize(i)*naxes(i)
10      continue
 
        if (naxis .eq. 1 .and. naxes(1) .eq. 1)then
C               This is not a vector column, so read all the rows at once
                nelem=(rstp-rstr)/rinc+1
                ninc=rinc
                rstp=rstr
        else
C               have to read each row individually, in all dimensions
                nelem=(stp(1)-str(1))/inc(1)+1
                ninc=incr(1)
        end if
 
        do 100 row=rstr,rstp,rinc
         do 90 i9=str(9),stp(9),incr(9)
          do 80 i8=str(8),stp(8),incr(8)
           do 70 i7=str(7),stp(7),incr(7)
            do 60 i6=str(6),stp(6),incr(6)
             do 50 i5=str(5),stp(5),incr(5)
              do 40 i4=str(4),stp(4),incr(4)
               do 30 i3=str(3),stp(3),incr(3)
                do 20 i2=str(2),stp(2),incr(2)
 
        felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4)
     &  +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7)
     &  +(i8-1)*dsize(8)+(i9-1)*dsize(9)
 
        call ftgclj(iunit,numcol,row,felem,nelem,ninc,
     &  nultyp,nulval,array(i1),ldummy,anyf,status)
        if (status .gt. 0)return
        if (anyf)anynul=.true.
        i1=i1+nelem
 
20              continue
30             continue
40            continue
50           continue
60          continue
70         continue
80        continue
90       continue
100     continue
        end
        subroutine ftgtbb(iunit,frow,fchar,nchars,value,status)
 
C       read a consecutive string of bytes from an ascii or binary
C       table. This will span multiple rows of the table if NCHARS+FCHAR is
C       greater than the length of a row.
 
C       iunit   i  fortran unit number
C       frow    i  starting row number (1st row = 1)
C       fchar   i  starting character/byte in the row to read (1st character=1)
C       nchars  i  number of characters/bytes to read (can span multiple rows)
C       value   i  returned string of bytes
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1991
 
        integer iunit,frow,fchar,nchars,status
        integer value(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check for errors
        if (nchars .le. 0)then
C               zero or negative number of character requested
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                return
        else if (fchar .lt. 1)then
C               error: illegal starting character
                status=308
                return
        end if
 
C       move the i/o pointer to the start of the sequence of characters
        bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1
        call ftmbyt(iunit,bstart,.false.,status)
 
C       get the string of bytes
        call ftgbyt(iunit,nchars,value,status)
        end
        subroutine ftgtbc(tfld,tdtype,trept,tbcol,lenrow,status)
 
C       Get Table Beginning Columns
C       determine the byte offset of the beginning of each field of a
C       binary table
 
C       tfld   i  number of fields in the binary table
C       tdtype i array of numerical datatype codes of each column
C       trept  i array of repetition factors for each column
C       OUTPUT PARAMETERS:
C       tbcol  i array giving the byte offset to the start of each column
C       lenrow i total width of the table, in bytes
C       status i  returned error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C       modified 6/17/92 to deal with ASCII column trept values measured
C       in units of characters rather than in terms of number of repeated
C       strings.
 
        integer tfld,tdtype(*),trept(*),tbcol(*),lenrow
        integer status,i,nbytes
        character ifld*4
 
        if (status .gt. 0)return
 
C       the first column always begins at the first byte of the row:
        tbcol(1)=0
 
        do 100 i=1,tfld-1
                if (tdtype(i) .eq. 16)then
C                       ASCII field; each character is 1 byte
                        nbytes=1
                else if (tdtype(i) .gt. 0)then
                        nbytes=tdtype(i)/10
                else if (tdtype(i) .eq. 0)then
C                   error: data type of column not defined! (no TFORM keyword)
                        status=232
                        write(ifld,1000)i
1000                    format(i4)
                        call ftpmsg('Field'//ifld//' of the binary'//
     &                  ' table has no TFORMn keyword')
                        return
                else
C                       this is a descriptor field: 2J
                        nbytes=8
                end if
 
                if (nbytes .eq. 0)then
C                       this is a bit array
                        tbcol(i+1)=tbcol(i)+(trept(i)+7)/8
                else
                        tbcol(i+1)=tbcol(i)+trept(i)*nbytes
                end if
100     continue
 
C       determine the total row width
        if (tdtype(tfld) .eq. 16)then
C               ASCII field; each character is 1 byte
                nbytes=1
        else if (tdtype(tfld) .gt. 0)then
                nbytes=tdtype(tfld)/10
        else if (tdtype(i) .eq. 0)then
C            error: data type of column not defined! (no TFORM keyword)
                status=232
                write(ifld,1000)tfld
                call ftpmsg('Field'//ifld//' of the binary'//
     &                  ' table is missing required TFORMn keyword.')
                return
        else
C               this is a descriptor field: 2J
                nbytes=8
        end if
        if (nbytes .eq. 0)then
C               this is a bit array
                lenrow=tbcol(tfld)+(trept(tfld)+7)/8
        else
                lenrow=tbcol(tfld)+trept(tfld)*nbytes
        end if
 
        end
        subroutine ftgtbh(iunit,ncols,nrows,nfield,ttype,tbcol,
     &                    tform,tunit,extnam,status)
 
C       OBSOLETE routine: should call ftghtb instead
 
        integer iunit,ncols,nrows,nfield,status,tbcol(*)
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
        call ftghtb(iunit,0,ncols,nrows,nfield,ttype,
     &                    tbcol,tform,tunit,extnam,status)
        end
        subroutine ftgtbn(iunit,ncols,nrows,pcount,nfield,status)
 
C       check that this is a valid binary table and get parameters
C
C       iunit   i  Fortran i/o unit number
C       ncols   i  width of each row of the table, in bytes
C       nrows   i  number of rows in the table
C       pcount  i  size of special data area following the table (usually = 0)
C       nfield  i  number of fields in the table
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,ncols,nrows,nfield,pcount,status
        character keynam*8,value*10,comm*8,rec*80
 
        if (status .gt. 0)return
 
C       check for correct type of extension
        call ftgrec(iunit,1,rec,status)
        if (status .gt. 0)go to 900
 
        keynam=rec(1:8)
 
        if (keynam .eq. 'XTENSION')then
                call ftpsvc(rec,value,comm,status)
                if (status .gt. 0)go to 900
 
                if (value(2:9) .ne. 'BINTABLE' .and.
     &              value(2:9) .ne. 'A3DTABLE' .and.
     &              value(2:9) .ne. '3DTABLE ')then
C                       this is not a binary table extension
                        status=227
                        go to 900
                 end if
        else
                 status=225
                 go to 900
        end if
 
C       check that the second keyword is BITPIX = 8
        call fttkyn(iunit,2,'BITPIX','8',status)
        if (status .eq. 208)then
C               BITPIX keyword not found
                status=222
        else if (status .eq. 209)then
C               illegal value of BITPIX
                status=211
        end if
        if (status .gt. 0)go to 900
 
C       check that the third keyword is NAXIS = 2
        call fttkyn(iunit,3,'NAXIS','2',status)
        if (status .eq. 208)then
C               NAXIS keyword not found
                status=223
        else if (status .eq. 209)then
C               illegal NAXIS value
                status=212
        end if
        if (status .gt. 0)go to 900
 
C       check that the 4th keyword is NAXIS1 and get it's value
        call ftgtkn(iunit,4,'NAXIS1',ncols,status)
        if (status .eq. 208)then
C               NAXIS1 keyword not found
                status=224
        else if (status .eq. 209)then
C               illegal value of NAXISnnn
                status=213
        end if
        if (status .gt. 0)go to 900
 
C       check that the 5th keyword is NAXIS2 and get it's value
        call ftgtkn(iunit,5,'NAXIS2',nrows,status)
        if (status .eq. 208)then
C               NAXIS2 keyword not found
                status=224
        else if (status .eq. 209)then
C               illegal value of NAXISnnn
                status=213
        end if
        if (status .gt. 0)go to 900
 
C       check that the 6th keyword is PCOUNT and get it's value
        call ftgtkn(iunit,6,'PCOUNT',pcount,status)
        if (status .eq. 208)then
C               PCOUNT keyword not found
                status=228
        else if (status .eq. 209)then
C               illegal PCOUNT value
                status=214
        end if
        if (status .gt. 0)go to 900
 
C       check that the 7th keyword is GCOUNT = 1
        call fttkyn(iunit,7,'GCOUNT','1',status)
        if (status .eq. 208)then
C               GCOUNT keyword not found
                status=229
        else if (status .eq. 209)then
C               illegal value of GCOUNT
                status=215
        end if
        if (status .gt. 0)go to 900
 
C       check that the 8th keyword is TFIELDS and get it's value
        call ftgtkn(iunit,8,'TFIELDS',nfield,status)
        if (status .eq. 208)then
C               TFIELDS keyword not found
                status=230
        else if (status .eq. 209)then
C               illegal value of TFIELDS
                status=216
        end if
 
900     continue
        if (status .gt. 0)then
            call ftpmsg('Failed to parse the required keywords in '//
     &       'the binary BINTABLE header (FTGTTB).')
        end if
        end
        subroutine ftgtbs(iunit,frow,fchar,nchars,svalue,status)
 
C       read a consecutive string of characters from an ascii or binary
C       table. This will span multiple rows of the table if NCHARS+FCHAR is
C       greater than the length of a row.
 
C       iunit   i  fortran unit number
C       frow    i  starting row number (1st row = 1)
C       fchar   i  starting character/byte in the row to read (1st character=1)
C       nchars  i  number of characters/bytes to read (can span multiple rows)
C       svalue  c  returned string of characters
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,frow,fchar,nchars,status
        character*(*) svalue
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart,nget
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check for errors
        if (nchars .le. 0)then
C               zero or negative number of character requested
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                return
        else if (fchar .lt. 1)then
C               error: illegal starting character
                status=308
                return
        end if
 
C       move the i/o pointer to the start of the sequence of characters
        bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1
        call ftmbyt(iunit,bstart,.false.,status)
 
C       get the string of characters, (up to the length of the input string)
        if (len(svalue) .ne. 1)then
            svalue=' '
            nget=min(nchars,len(svalue))
        else
C           assume svalue was dimensioned as: character*1 svalue(nchars)
            nget=nchars
        end if
        call ftgcbf(iunit,nget,svalue,status)
        end
        subroutine ftgtcl(iunit,colnum,datcod,repeat,width,status)
 
C       get the datatype of the column, as well as the vector
C       repeat count and (if it is an ASCII character column) the
C       width of a unit string within the column.  This supports the
C       TFORMn = 'rAw' syntax for specifying arrays of substrings.
 
 
C       iunit   i  Fortran i/o unit number
C       colnum  i  number of the column (first column = 1)
 
C       datcod  i  returned datatype code
C       repeat  i  number of elements in the vector column
C       width   i  width of unit string in character columns
C       status  i  returned error status
C
C       written by Wm Pence, HEASARC/GSFC, November 1994
 
        integer iunit,colnum,datcod,repeat,width,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS------------------------------------
 
        integer ibuff,dummy
        character keywrd*8,tform*24,comm*20
 
        if (status .gt. 0)return
 
C       construct the keyword name
        call ftkeyn('TFORM',colnum,keywrd,status)
 
C       get the keyword value
        call ftgkys(iunit,keywrd,tform,comm,status)
        if (status .gt. 0)then
            call ftpmsg('Could not read the '//keywrd//' keyword.')
            return
        end if
 
C       parse the keyword value
        ibuff=bufnum(iunit)
        if (hdutyp(ibuff) .eq. 1)then
C           this is an ASCII table
            repeat=1
            call ftasfm(tform,datcod,width,dummy,status)
 
        else if (hdutyp(ibuff) .eq. 2)then
C           this is a binary table
            call ftbnfm(tform,datcod,repeat,width,status)
 
        else
C           error: this HDU is not a table
            status=235
            return
        end if
        end
        subroutine ftgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix,
     &                   xinc,yinc,rot,type,status)
 
C       read the values of the celestial coordinate system keywords
C       from a FITS table where the X and Y or RA and DEC coordinates
C       are stored in separate column.
C
C       These values may be used as input to the subroutines that
C       calculate celestial coordinates. (FTXYPX, FTWLDP)
 
C       xcol (integer) number of the column containing the RA type coordinate
C       ycol (integer) number of the column containing the DEC type coordinate
 
        double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot
        integer iunit,xcol,ycol,status
        character*(*) type
        character comm*20,ctype*8,keynam*8,xnum*3,ynum*3
 
        if (status .gt. 0)return
 
        call ftkeyn('TCRVL',xcol,keynam,status)
        xnum=keynam(6:8)
        call ftgkyd(iunit,keynam,xrval,comm,status)
 
        call ftkeyn('TCRVL',ycol,keynam,status)
        ynum=keynam(6:8)
        call ftgkyd(iunit,keynam,yrval,comm,status)
 
        keynam='TCRPX'//xnum
        call ftgkyd(iunit,keynam,xrpix,comm,status)
        keynam='TCRPX'//ynum
        call ftgkyd(iunit,keynam,yrpix,comm,status)
 
        keynam='TCDLT'//xnum
        call ftgkyd(iunit,keynam,xinc,comm,status)
        keynam='TCDLT'//ynum
        call ftgkyd(iunit,keynam,yinc,comm,status)
 
        keynam='TCTYP'//xnum
        call ftgkys(iunit,keynam,ctype,comm,status)
 
        if (status .gt. 0)then
            call ftpmsg('FTGTCS could not find all the required'//
     &                  ' celestial coordinate Keywords.')
            status=505
            return
        end if
 
        type=ctype(5:8)
 
        rot=0.
        end
        subroutine ftgtdm(iunit,colnum,maxdim,naxis,naxes,status)
 
C       parse the TDIMnnn keyword to get the dimensionality of a column
 
C       iunit   i  fortran unit number to use for reading
C       colnum  i  column number to read
C       maxdim  i  maximum no. of dimensions to read; dimension of naxes
C       OUTPUT PARAMETERS:
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, October 1993
 
        integer iunit,colnum,maxdim,naxis,naxes(*),status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,nfound,c1,c2,clast,dimval
        logical last
        character*120 tdim
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
        if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
C               illegal column number
                status=302
                return
        end if
 
        nfound=0
C       try getting the TDIM keyword value
        call ftgkns(iunit,'TDIM',colnum,1,tdim,nfound,status)
 
        if (nfound .ne. 1)then
C               no TDIM keyword found
                naxis=1
                naxes(1)=trept(colnum+tstart(ibuff))
                return
        end if
 
        naxis=0
C       first, find the opening ( and closing )
        c1=index(tdim,'(')+1
        c2=index(tdim,')')-1
        if (c1 .eq. 1 .or. c2 .eq. -1)go to 900
 
        last=.false.
C       find first non-blank character
10      if (tdim(c1:c1) .ne. ' ')go to 20
        c1=c1+1
        go to 10
 
C       find the comma separating the dimension sizes
20      clast=index(tdim(c1:c2),',')+c1-2
        if (clast .eq. c1-2)then
                last=.true.
                clast=c2
        end if
 
C       read the string of characters as the (integer) dimension size
        call ftc2ii(tdim(c1:clast),dimval,status)
        if (status .gt. 0)then
             call ftpmsg('Error in FTGTDM parsing dimension string: '
     &       //tdim)
             go to 900
        end if
 
        naxis=naxis+1
        if (naxis .le. maxdim)naxes(naxis)=dimval
 
        if (last)return
 
        c1=clast+2
        go to 10
 
C       could not parse the tdim value
900     status=263
        end
        subroutine ftgthd(tmplat,card,hdtype,status)
 
C       'Get Template HeaDer'
C       parse a template header line and create a formated
C       80-character string which is suitable for appending to a FITS header
 
C       tmplat  c  input header template string
C       card    c  returned 80-character string = FITS header record
C       hdtype  i  type of operation that should be applied to this keyword:
C                      -2  =  modify the name of a keyword; the new name
C                             is returned in characters 41:48 of CARD.
C                      -1  =  delete this keyword
C                       0  =  append (if it doesn't already exist) or
C                             overwrite this keyword (if it does exist)
C                       1  =  append this comment keyword ('HISTORY',
C                             'COMMENT', or blank keyword name)
C                       2  =  this is an END record; do not append it
C                             to a FITS header!
C       status  i  returned error status
C               if a positive error status is returned then the first
C               80 characters of the offending input line are returned
C               by the CARD parameter
 
        integer hdtype,status,tstat
        character*(*) tmplat,card
        integer i1,i2,com1,strend,length
        character inline*100,keynam*8,ctemp*80,qc*1
        logical number
        double precision dvalue
 
        if (status .gt. 0)return
        card=' '
        hdtype=0
 
        inline=tmplat
 
C       test if columns 1-8 are blank; if so, this is a FITS comment record;
C       just copy it verbatim to the FITS header
        if (inline(1:8) .eq. ' ')then
                card=inline(1:80)
                go to 999
        end if
 
C       parse the keyword name = the first token separated by a space or a '='
C       1st locate the first nonblank character (we know it is not all blank):
        i1=0
20      i1=i1+1
C       test for a leading minus sign which flags name of keywords to be deleted
        if (inline(i1:i1) .eq. '-')then
                hdtype=-1
C               test for a blank keyword name
                if (inline(i1+1:i1+8) .eq. '        ')then
                       card=' '
                       i2=i1+9
                       go to 35
                end if
                go to 20
        else if (inline(i1:i1) .eq. ' ')then
                go to 20
        end if
 
C       now find the last character of the keyword name
        i2=i1
30      i2=i2+1
        if (inline(i2:i2) .ne. ' ' .and. inline(i2:i2) .ne. '=')go to 30
 
C       test for legal keyword name length (max 8 characters)
        if (i2-i1 .gt. 8)then
                status=207
                card=inline(1:80)
                go to 999
        end if
 
        keynam=inline(i1:i2-1)
 
C       convert to upper case and test for illegal characters in keyword name
        call ftupch(keynam)
        call fttkey(keynam,status)
        if (status .gt. 0)then
                card=inline(1:80)
                go to 999
        end if
 
C       if this is the 'END' then this is the end of the input file
        if (keynam .eq. 'END     ')goto 998
 
C       copy the keyword name to the output record string
        card(1:8)=keynam
 
C       jump if this is just the name of keyword to be deleted
        if (hdtype .lt. 0)go to 35
 
C       test if this is a COMMENT or HISTORY record
        if (keynam .eq. 'COMMENT' .or. keynam .eq. 'HISTORY')then
C               append next 72 characters from input line to output record
                card(9:80)=inline(i2:)
                hdtype=1
                go to 999
        else
C               this keyword must have a value, so append the '= ' to output
                card(9:10)='= '
        end if
 
C       now locate the value token in the input line.  If it includes
C       embedded spaces it must be enclosed in single quotes. The value must
C       be separated by at least one blank space from the comment string
 
C       find the first character of the value string
35      i1=i2-1
40      i1=i1+1
        if (i1 .gt. 100)then
C               no value is present in the input line
                if (hdtype .lt. 0)then
C                       this is normal; just quit
                        go to 999
                else
                        status=204
                        card=inline(1:80)
                        go to 999
                end if
        end if
        if (hdtype .lt. 0 .and. inline(i1:i1) .eq. '=')then
C               The leading minus sign, plus the presence of an equal sign
C               between the first 2 tokens is taken to mean that the
C               keyword with the first token name is to be deleted.
                go to 999
        else if (inline(i1:i1).eq. ' ' .or.inline(i1:i1).eq. '=')then
                go to 40
        end if
 
C       is the value a quoted string?
        if (inline(i1:i1) .eq. '''')then
C               find the closing quote
                i2=i1
50              i2=i2+1
                if (i2 .gt. 100)then
C                       error: no closing quote on value string
                        status=205
                        card=inline(1:80)
            call ftpmsg('Keyword value string has no closing quote:')
            call ftpmsg(card)
                        go to 999
                end if
                if (inline(i2:i2) .eq. '''')then
                        if (inline(i2+1:i2+1) .eq. '''')then
C                               ignore 2 adjacent single quotes
                                i2=i2+1
                                go to 50
                        end if
                else
                        go to 50
                end if
C               value string can't be more than 70 characters long (cols 11-80)
                length=i2-i1
                if (length .gt. 69)then
                        status=205
                        card=inline(1:80)
            call ftpmsg('Keyword value string is too long:')
            call ftpmsg(card)
                        go to 999
                end if
 
C               append value string to output, left justified in column 11
                card(11:11+length)=inline(i1:i2)
C               com1 is the starting position for the comment string
                com1=max(32,13+length)
 
C               FITS string must be at least 8 characters long
                if (length .lt. 9)then
                        card(11+length:11+length)=' '
                        card(20:20)=''''
                end if
        else
C               find the end of the value field
                i2=i1
60              i2=i2+1
                if (i2 .gt. 100)then
C                       error: value string is too long
                        status=205
                        card=inline(1:80)
            call ftpmsg('Keyword value string is too long:')
            call ftpmsg(card)
                        go to 999
                end if
                if (inline(i2:i2) .ne. ' ')go to 60
 
C               test if this is a logical value
                length=i2-i1
                if (length .eq. 1 .and. (inline(i1:i1) .eq. 'T'
     &              .or. inline(i1:i1) .eq. 'F'))then
                        card(30:30)=inline(i1:i1)
                        com1=32
                else
C                   test if this is a numeric value; try reading it as
C                   double precision value; if it fails, it must be a string
                    number=.true.
                    tstat=status
                    call ftc2dd(inline(i1:i2-1),dvalue,status)
                    if (status .gt. 0)then
                        status=tstat
                        number=.false.
                    else
C                       check the first character to make sure this is a number
C                       since certain non-numeric character strings pass the
C                       above test on SUN machines.
                        qc=inline(i1:i1)
                        if (qc .ne. '+' .and. qc .ne. '-' .and. qc .ne.
     &                  '.' .and. (qc .lt. '0' .or. qc .gt. '9'))then
C                              This really was not a number!
                               number=.false.
                        end if
                    end if
 
                    if (number)then
                        if (length .le. 20)then
C                               write the value right justified in col 30
                                card(31-length:30)=inline(i1:i2-1)
                                com1=32
                        else
C                               write the long value left justified in col 11
                                card(11:10+length)=inline(i1:i2-1)
                                com1=max(32,12+length)
                        end if
                    else
C                       value is a character string datatype
                        card(11:11)=''''
                        strend=11+length
                        card(12:strend)=inline(i1:i2-1)
C                       need to expand any embedded single quotes into 2 quotes
                        i1=11
70                      i1=i1+1
                        if (i1 .gt. strend) go to 80
                        if (card(i1:i1) .eq. '''')then
                                i1=i1+1
                                if (card(i1:i1) .ne. '''')then
C                                       have to insert a 2nd quote into string
                                        ctemp=card(i1:strend)
                                        card(i1:i1)=''''
                                        strend=strend+1
                                        i1=i1+1
                                        card(i1:strend)=ctemp
                                end if
                        end if
                        go to 70
 
80                      strend=max(20,strend+1)
                        card(strend:strend)=''''
                        com1=max(32,strend+2)
                    end if
                end if
        end if
 
C       check if this was a request to modify a keyword name
        if (hdtype .eq. -1)then
                hdtype = -2
C               the keyword value is really the new keyword name
C               return the new name in characters 41:48 of the output card
                keynam=card(12:19)
C               convert to upper case and test for illegal characters in name
                call ftupch(keynam)
                call fttkey(keynam,status)
                if (status .gt. 0)then
                        card=inline(1:80)
                        go to 999
                else
                        card(9:80)=' '
                        card(41:48)=keynam
                        go to 999
                end if
        end if
 
C       is there room for a comment string?
        if (com1 .lt. 79)then
C               now look for the beginning of the comment string
                i1=i2
90              i1=i1+1
C               if no comment field then just quit
                if (i1 .gt. 100)go to 999
                if (inline(i1:i1) .eq. ' ')go to 90
 
C               append the comment field
                if (inline(i1:i1) .eq. '/')then
                        card(com1:80)=inline(i1:)
                else
                        card(com1:80)='/ '//inline(i1:)
                end if
        end if
 
        go to 999
 
C       end of input file was detected
998     hdtype=2
 
999     continue
        end
        subroutine ftgtkn(iunit,nkey,keynam,ival,status)
 
C       test that keyword number NKEY has name = KEYNAM and get the
C       integer value of the keyword.  Return an error if the keyword
C       name does not match the input KEYNAM, or if the value of the
C       keyword is not a positive integer.
C
C       iunit   i  Fortran I/O unit number
C       nkey    i  sequence number of the keyword to test
C       keynam  c  name that the keyword is supposed to have
C       OUTPUT PARAMETERS:
C       ival    i  returned value of the integer keyword
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C
        integer iunit,nkey,status,ival
        character*(*) keynam
        character kname*8,value*30,comm*48,npos*8,keybuf*80
 
        if (status .gt. 0)return
 
C       read the name and value of the keyword
        call ftgrec(iunit,nkey,keybuf,status)
 
        kname=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
 
        if (status .gt. 0)go to 900
 
C       test if the keyword has the correct name
        if (kname .ne. keynam)then
                status=208
                go to 900
        end if
 
C       convert character string to integer
        call ftc2ii(value,ival,status)
        if (status .gt. 0 .or. ival .lt. 0 )then
C               keyword value must be zero or positive integer
                status=209
        end if
 
900     continue
 
        if (status .gt. 0)then
            write(npos,1000)nkey
1000        format(i8)
            call ftpmsg('FTGTKN found unexpected keyword or value '//
     &      'for header keyword number '//npos//'.')
            call ftpmsg('  Was expecting positive integer keyword '//
     &      keynam(1:8))
            if (keybuf(9:10) .ne. '= ')then
                call ftpmsg('  but found the keyword '//kname//
     &          ' with no value field (no "= " in cols. 9-10).')
            else
              call ftpmsg('  but instead found keyword = '//kname//
     &        ' with value = '//value)
            end if
            call ftpmsg(keybuf)
        end if
        end
        subroutine ftgttb(iunit,ncols,nrows,nfield,status)
 
C       test that this is a legal ASCII table, and get some keywords
C
C       iunit   i  Fortran i/o unit number
C       OUTPUT PARAMETERS:
C       ncols   i  number of columns in the table
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,ncols,nrows,nfield,status
        character keynam*8,value*10,comm*8,keybuf*80
 
        if (status .gt. 0)return
 
C       check for correct type of extension
        call ftgrec(iunit,1,keybuf,status)
 
        keynam=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
 
        if (status .gt. 0)go to 900
 
        if (keynam .eq. 'XTENSION')then
                if (value(2:9) .ne. 'TABLE   ')then
C                       this is not a ASCII table extension
                        status=226
        call ftpmsg('Was expecting an ASCII table; instead got '//
     &  'XTENSION= '//value)
                        call ftpmsg(keybuf)
                        go to 900
                 end if
        else
                 status=225
        call ftpmsg('First keyword of extension was not XTENSION:'//
     &           keynam)
                 call ftpmsg(keybuf)
                 go to 900
        end if
 
C       check that the second keyword is BITPIX = 8
        call fttkyn(iunit,2,'BITPIX','8',status)
        if (status .eq. 208)then
C               BITPIX keyword not found
                status=222
        else if (status .eq. 209)then
C               illegal value of BITPIX
                status=211
        end if
        if (status .gt. 0)go to 900
 
C       check that the third keyword is NAXIS = 2
        call fttkyn(iunit,3,'NAXIS','2',status)
        if (status .eq. 208)then
C               NAXIS keyword not found
                status=223
        else if (status .eq. 209)then
C               illegal value of NAXIS
                status=212
        end if
        if (status .gt. 0)go to 900
 
C       check that the 4th keyword is NAXIS1 and get it's value
        call ftgtkn(iunit,4,'NAXIS1',ncols,status)
        if (status .eq. 208)then
C               NAXIS1 keyword not found
                status=224
        else if (status .eq. 209)then
C               illegal NAXIS1 value
                status=213
        end if
        if (status .gt. 0)go to 900
 
C       check that the 5th keyword is NAXIS2 and get it's value
        call ftgtkn(iunit,5,'NAXIS2',nrows,status)
        if (status .eq. 208)then
C               NAXIS2 keyword not found
                status=224
        else if (status .eq. 209)then
C               illegal NAXIS2 value
                status=213
        end if
        if (status .gt. 0)go to 900
 
C       check that the 6th keyword is PCOUNT = 0
        call fttkyn(iunit,6,'PCOUNT','0',status)
        if (status .eq. 208)then
C               PCOUNT keyword not found
                status=228
        else if (status .eq. 209)then
C               illegal PCOUNT value
                status=214
        end if
        if (status .gt. 0)go to 900
 
C       check that the 7th keyword is GCOUNT = 1
        call fttkyn(iunit,7,'GCOUNT','1',status)
        if (status .eq. 208)then
C               GCOUNT keyword not found
                status=229
        else if (status .eq. 209)then
C               illegal value of GCOUNT
                status=215
        end if
        if (status .gt. 0)go to 900
 
C       check that the 8th keyword is TFIELDS
        call ftgtkn(iunit,8,'TFIELDS',nfield,status)
        if (status .eq. 208)then
C               TFIELDS keyword not found
                status=230
        else if (status .eq. 209)then
C               illegal value of TFIELDS
                status=216
        end if
 
900     continue
        if (status .gt. 0)then
            call ftpmsg('Failed to parse the required keywords in '//
     &       'the ASCII TABLE header (FTGTTB).')
        end if
        end
        subroutine ftgunt(iunit,keywrd,kunit,status)
 
C       read the unit string from the comment string from a header record
C
C       iunit   i  fortran input unit number
C       keywrd  c  keyword name
C       OUTPUT PARAMETERS:
C       kunit   c  output keyword units
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,kunit
        integer iunit,ii,status,ulen
        character value*35,comm*72
 
        if (status .gt. 0)return
 
        kunit = ' '
 
C       find the keyword and return value and comment as character strings
        call ftgkey(iunit,keywrd,value,comm,status)
 
        if (status .gt. 0)return
 
C       look for brackets enclosing the units string
        if (comm(1:1) .eq. '[')then
           ulen=2
           do 10 ii = 3,72
              if (comm(ii:ii) .eq. ']')go to 20
              ulen=ii
10         continue
           return
 
20        kunit=comm(2:ulen)
        end if
        end
        subroutine fthdef(ounit,moreky,status)
 
C       Header DEFinition
C       define the size of the current header unit; this simply lets
C       us determine where the data unit will start
C
C       ounit   i  Fortran I/O unit number
C       moreky  i  number of additional keywords to reserve space for
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,moreky,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,mkeys
 
        if (status .gt. 0)return
 
C       based on the number of keywords which have already been written,
C       plus the number of keywords to reserve space for, we then can
C       define where the data unit should start (it must start at the
C       beginning of a 2880-byte logical block).
 
        ibuff=bufnum(ounit)
 
        mkeys=max(moreky,0)
        dtstrt(ibuff)=((hdend(ibuff)+mkeys*80)/2880+1)*2880
        end
        subroutine fthpdn(ounit,nbytes,status)
 
C       shift the binary table heap down by nbyte bytes
 
C       ounit   i  fortran output unit number
C       nbytes  i  number of bytes by which to move the heap
C       status  i  returned error status (0=ok)
 
        integer ounit,nbytes,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer i,ibuff,ntodo,jpoint,nchar,tstat
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        if (heapsz(ibuff) .gt. 0)then
            ntodo=heapsz(ibuff)
 
C           set pointer to the end of the heap
            jpoint=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff)
 
10          nchar=min(ntodo,5760)
            jpoint=jpoint-nchar
 
C           move to the read start position
            call ftmbyt(ounit,jpoint,.false.,status)
 
C           read the heap
            call ftgcbf(ounit,nchar,buff,status)
 
C           move forward to the write start postion
            call ftmbyt(ounit,jpoint+nbytes,.true.,status)
 
C           write the heap
            call ftpcbf(ounit,nchar,buff,status)
 
C           check for error
            if (status .gt. 0)then
               call ftpmsg('Error while moving heap down (FTDNHP)')
               return
            end if
 
C           check for more data in the heap
            ntodo=ntodo-nchar
            if (ntodo .gt. 0)go to 10
 
C           now overwrite the old fill data with zeros
            do 20 i=1,5760
                buff(i:i)=char(0)
20          continue
 
            jpoint=dtstrt(ibuff)+theap(ibuff)
            call ftmbyt(ounit,jpoint,.false.,status)
 
            ntodo=nbytes
30          nchar=min(ntodo,5760)
            call ftpcbf(ounit,nchar,buff,status)
            ntodo=ntodo-nchar
            if (ntodo .gt. 0)go to 30
        end if
 
C       update the heap starting address
        theap(ibuff)=theap(ibuff)+nbytes
 
C       try updating the keyword value, if it exists
        tstat=status
        call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status)
        if (status .eq. 202)status=tstat
        end
        subroutine fthpup(ounit,nbytes,status)
 
C       shift the binary table heap up by nbytes bytes
 
C       ounit   i  fortran output unit number
C       nbytes  i  number of bytes by which to move the heap
C       status  i  returned error status (0=ok)
 
        integer ounit,nbytes,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer i,ibuff,ntodo,jpoint,nchar,tstat
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        if (heapsz(ibuff) .gt. 0)then
            ntodo=heapsz(ibuff)
 
C           set pointer to the start of the heap
            jpoint=dtstrt(ibuff)+theap(ibuff)
 
10          nchar=min(ntodo,5760)
 
C           move to the read start position
            call ftmbyt(ounit,jpoint,.false.,status)
 
C           read the heap
            call ftgcbf(ounit,nchar,buff,status)
 
C           move back to the write start postion
            call ftmbyt(ounit,jpoint-nbytes,.false.,status)
 
C           write the heap
            call ftpcbf(ounit,nchar,buff,status)
 
C           check for error
            if (status .gt. 0)then
               call ftpmsg('Error while moving heap up (FTUPHP)')
               return
            end if
 
C           check for more data in the heap
            ntodo=ntodo-nchar
            jpoint=jpoint+nchar
            if (ntodo .gt. 0)go to 10
 
C           now overwrite the old fill data with zeros
            do 20 i=1,5760
                buff(i:i)=char(0)
20          continue
 
            jpoint=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff)-nbytes
            call ftmbyt(ounit,jpoint,.false.,status)
 
            ntodo=nbytes
30          nchar=min(ntodo,5760)
            call ftpcbf(ounit,nchar,buff,status)
            ntodo=ntodo-nchar
            if (ntodo .gt. 0)go to 30
        end if
 
C       update the heap starting address
        theap(ibuff)=theap(ibuff)-nbytes
 
C       try updating the keyword value, if it exists
        tstat=status
        call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status)
        if (status .eq. 202)status=tstat
        end
        subroutine fti1i1(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*1 values to output i*1 values, doing optional
C       scaling and checking for null values
 
C       input   c*1 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  c*1 value in the input array that is used to indicated nulls
C       setval  c*1 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  c*1 returned array of values
C       status  i  output error status (0 = ok)
 
        character*1 input(*),chkval
        character*1 output(*),setval
        integer n,i,chktyp,status,itemp
        double precision scale,zero,dval
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                          itemp=ichar(input(i))
                          if (itemp .lt. 0)itemp=itemp+256
                          dval=(itemp-zero)/scale
C                         trap any values that overflow the I*1 range
                          if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                output(i)=char(nint(dval))
                          else if (dval .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                          else
                                status=-11
                                output(i)=char(0)
                          end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                   don't have to check for nulls
                    if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                    else
                        do 40 i=1,n
                            itemp=ichar(input(i))
                            if (itemp .lt. 0)itemp=itemp+256
                            dval=itemp*scale+zero
C                           trap any values that overflow the I*1 range
                          if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
40                      continue
                    end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                            output(i)=input(i)
                                        end if
50                              continue
                        else
                         do 60 i=1,n
                          if (input(i) .eq. chkval)then
                                    anynul=.true.
                                    if (chktyp .eq. 1)then
                                        output(i)=setval
                                    else
                                        flgray(i)=.true.
                                    end if
                          else
                            itemp=ichar(input(i))
                            if (itemp .lt. 0)itemp=itemp+256
                            dval=itemp*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
                          end if
60                       continue
                        end if
                end if
        end if
        end
        subroutine fti1i2(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*1 values to output i*2 values, doing optional
C       scaling and checking for null values
 
C       input   c*1 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  c*1 value in the input array that is used to indicated nulls
C       setval  i*2 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i*2 returned array of values
C       status  i  output error status (0 = ok)
 
        character*1 input(*),chkval
        integer*2 output(*),setval,mini2,maxi2
        integer n,i,chktyp,status,itemp
        double precision scale,zero,dval,i2max,i2min
        logical tofits,flgray(*),anynul,noscal
 
        parameter (maxi2=32767)
        parameter (mini2=-32768)
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=itemp
10                      continue
                else
                        do 20 i=1,n
                            itemp=ichar(input(i))
                            if (itemp .lt. 0)itemp=itemp+256
                            dval=(itemp-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i2max .and. dval.gt.i2min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i2max)then
                                status=-11
                                output(i)=maxi2
                            else
                                status=-11
                                output(i)=mini2
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                      itemp=ichar(input(i))
                                      if (itemp .lt. 0)itemp=itemp+256
                                      output(i)=itemp
30                              continue
                        else
                            do 40 i=1,n
                              itemp=ichar(input(i))
                              if (itemp .lt. 0)itemp=itemp+256
                              dval=itemp*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                      itemp=ichar(input(i))
                                      if (itemp .lt. 0)itemp=itemp+256
                                      output(i)=itemp
                                        end if
50                              continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              itemp=ichar(input(i))
                              if (itemp .lt. 0)itemp=itemp+256
                              dval=itemp*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine fti1i4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*1 values to output i*4 values, doing optional
C       scaling and checking for null values
 
C       input   c*1 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  c*1 value in the input array that is used to indicated nulls
C       setval  i   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i   returned array of values
C       status  i  output error status (0 = ok)
 
        character*1 input(*),chkval
        integer output(*),setval
        integer n,i,chktyp,status,itemp
        double precision scale,zero,dval,i4max,i4min
        logical tofits,flgray(*),anynul,noscal
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=itemp
10                      continue
                else
                        do 20 i=1,n
                            itemp=ichar(input(i))
                            if (itemp .lt. 0)itemp=itemp+256
                            dval=(itemp-zero)/scale
C                           trap any values that overflow the I*4 range
                            if (dval.lt.i4max .and. dval.gt.i4min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i4max)then
                                status=-11
                                output(i)=maxi4
                            else
                                status=-11
                                output(i)=mini4
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                      itemp=ichar(input(i))
                                      if (itemp .lt. 0)itemp=itemp+256
                                      output(i)=itemp
30                              continue
                        else
                            do 40 i=1,n
                              itemp=ichar(input(i))
                              if (itemp .lt. 0)itemp=itemp+256
                              dval=itemp*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                      itemp=ichar(input(i))
                                      if (itemp .lt. 0)itemp=itemp+256
                                      output(i)=itemp
                                        end if
50                              continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              itemp=ichar(input(i))
                              if (itemp .lt. 0)itemp=itemp+256
                              dval=itemp*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine fti1r4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*1 values to output r*4 values, doing optional
C       scaling and checking for null values
 
C       input   c*1 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  c*1 value in the input array that is used to indicated nulls
C       setval  r   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  r   returned array of values
 
        character*1 input(*),chkval
        real output(*),setval
        integer n,i,chktyp,status,itemp
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=itemp
10                      continue
                else
                        do 20 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=(itemp-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        itemp=ichar(input(i))
                                        if (itemp .lt. 0)itemp=itemp+256
                                        output(i)=itemp
30                              continue
                        else
                                do 40 i=1,n
                                  itemp=ichar(input(i))
                                  if (itemp .lt. 0)itemp=itemp+256
                                  output(i)=itemp*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                            itemp=ichar(input(i))
                                        if (itemp .lt. 0)itemp=itemp+256
                                            output(i)=itemp
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                  itemp=ichar(input(i))
                                  if (itemp .lt. 0)itemp=itemp+256
                                  output(i)=itemp*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine fti1r8(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*1 values to output r*8 values, doing optional
C       scaling and checking for null values
 
C       input   c*1 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  c*1 value in the input array that is used to indicated nulls
C       setval  d   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  d   returned array of values
 
        character*1 input(*),chkval
        double precision output(*),setval
        integer n,i,chktyp,status,itemp
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=itemp
10                      continue
                else
                        do 20 i=1,n
                                itemp=ichar(input(i))
                                if (itemp .lt. 0)itemp=itemp+256
                                output(i)=(itemp-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        itemp=ichar(input(i))
                                        if (itemp .lt. 0)itemp=itemp+256
                                        output(i)=itemp
30                              continue
                        else
                                do 40 i=1,n
                                  itemp=ichar(input(i))
                                  if (itemp .lt. 0)itemp=itemp+256
                                  output(i)=itemp*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                            itemp=ichar(input(i))
                                        if (itemp .lt. 0)itemp=itemp+256
                                            output(i)=itemp
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                  itemp=ichar(input(i))
                                  if (itemp .lt. 0)itemp=itemp+256
                                  output(i)=itemp*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine fti2c(ival,cval,status)
C       convert an integer value to a C*20 character string, right justified
        integer ival,status
        character*20 cval
 
        if (status .gt. 0)return
 
        write(cval,1000,err=900)ival
1000    format(i20)
        if (cval(1:1) .eq. '*')go to 900
        return
900     status=401
        call ftpmsg('Error in FTI2C converting integer to C*20 string.')
        end
        subroutine fti2i1(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*2 values to output i*1 values, doing optional
C       scaling and checking for null values
 
C       input   i*2 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i*2 value in the input array that is used to indicated nulls
C       setval  c*1 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  c*1 returned array of values
C       status  i  output error status (0 = ok)
 
        integer*2 input(*),chkval
        character*1 output(*),setval
        integer n,i,chktyp,itemp,status
        double precision scale,zero,dval
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C       have to use a temporary variable because of IBM mainframe
                            itemp=input(i)
C                           trap any values that overflow the I*1 range
                            if (itemp.le. 255 .and. itemp.ge. 0)then
                                output(i)=char(itemp)
                            else if (itemp .gt. 255)then
                                status=-11
                                output(i)=char(255)
                            else
                                status=-11
                                output(i)=char(0)
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                output(i)=char(nint(dval))
                            else if (dval .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                            else
                                status=-11
                                output(i)=char(0)
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                            do 30 i=1,n
C       have to use a temporary variable because of IBM mainframe
                                itemp=input(i)
C                               trap any values that overflow the I*1 range
                                if (itemp.le. 255 .and. itemp.ge. 0)then
                                    output(i)=char(itemp)
                                else if (itemp .gt. 255)then
                                    status=-11
                                    output(i)=char(255)
                                else
                                    status=-11
                                    output(i)=char(0)
                                end if
30                          continue
                        else
                          do 40 i=1,n
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
40                        continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                          do 50 i=1,n
                             if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                             else
C       have to use a temporary variable because of IBM mainframe
                                itemp=input(i)
C                               trap any values that overflow the I*1 range
                                if (itemp.le. 255 .and. itemp.ge. 0)then
                                    output(i)=char(itemp)
                                else if (itemp .gt. 255)then
                                    status=-11
                                    output(i)=char(255)
                                else
                                    status=-11
                                    output(i)=char(0)
                                end if
                             end if
50                        continue
                      else
                          do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                    anynul=.true.
                                    if (chktyp .eq. 1)then
                                        output(i)=setval
                                    else
                                        flgray(i)=.true.
                                    end if
                          else
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
                          end if
60                       continue
                    end if
                end if
        end if
        end
        subroutine fti2i2(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*2 values to output i*2 values, doing optional
C       scaling and checking for null values
 
C       input   i*2 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i*2 value in the input array that is used to indicated nulls
C       setval  i*2 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i*2 returned array of values
C       status  i  output error status (0 = ok)
 
C        integer*2 j (this was only needed to workaround the Microsoft bug)
 
        integer*2 input(*),output(*),chkval,setval,mini2,maxi2
        integer n,i,chktyp,status
        double precision scale,zero,dval,i2max,i2min
        logical tofits,flgray(*),anynul,noscal
 
        parameter (maxi2=32767)
        parameter (mini2=-32768)
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits)then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
 
C      The following workaround was removed Dec 1996.  Hopefully this
C      compiler bug is fixed in later versions, but in any case, it is more
C      important to remove this workaround to make the code more efficient
C      on other machines
C                       Have to use internal variable j to work around
C                       a bug in the Microsoft v5.0 compiler on IBM PCs
C                               j=input(i)
C                               output(i)=j
 
                               output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i2max .and. dval.gt.i2min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i2max)then
                                status=-11
                                output(i)=maxi2
                            else
                                status=-11
                                output(i)=mini2
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
C                               Have to use internal variable j to work around
C                               a bug in the Microsoft v5.0 compiler on IBM PCs
C                                        j=input(i)
C                                        output(i)=j
 
                                        output(i)=input(i)
30                              continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
C                               Have to use internal variable j to work around
C                               a bug in the Microsoft v5.0 compiler on IBM PCs
C                                                j=input(i)
C                                                output(i)=j
 
                                                output(i)=input(i)
                                        end if
50                              continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine fti2i4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*2 values to output i*4 values, doing optional
C       scaling and checking for null values
 
C       input   i*2 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i*2 value in the input array that is used to indicated nulls
C       setval  i   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i   returned array of values
C       status  i  output error status (0 = ok)
 
        integer*2 input(*),chkval
        integer output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval,i4max,i4min
        logical tofits,flgray(*),anynul,noscal
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i4max .and. dval.gt.i4min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i4max)then
                                status=-11
                                output(i)=maxi4
                            else
                                status=-11
                                output(i)=mini4
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                 anynul=.true.
                                 if (chktyp .eq. 1)then
                                      output(i)=setval
                                  else
                                      flgray(i)=.true.
                                  end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
                            end if
60                      continue
                     end if
                end if
        end if
        end
        subroutine fti2r4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*2 values to output r*4 values, doing optional
C       scaling and checking for null values
 
C       input   i*2 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i*2 value in the input array that is used to indicated nulls
C       setval  r   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  r   returned array of values
 
        integer*2 input(*),chkval
        real output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine fti2r8(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*2 values to output r*8 values, doing optional
C       scaling and checking for null values
 
C       input   i*2 input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i*2 value in the input array that is used to indicated nulls
C       setval  d   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  d   returned array of values
 
        integer*2 input(*),chkval
        double precision output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine fti4i1(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*4 values to output i*1 values, doing optional
C       scaling and checking for null values
 
C       input   i input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i value in the input array that is used to indicated nulls
C       setval  c*1 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  c*1 returned array of values
C       status  i  output error status (0 = ok)
 
        integer input(*),chkval
        character*1 output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                    do 10 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).le. 255 .and. input(i).ge. 0)then
                                output(i)=char(input(i))
                        else if (input(i) .gt. 255)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
10                  continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                output(i)=char(nint(dval))
                            else if (dval .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                            else
                                status=-11
                                output(i)=char(0)
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                   don't have to check for nulls
                    if (noscal)then
                      do 30 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).le. 255 .and. input(i).ge. 0)then
                                output(i)=char(input(i))
                        else if (input(i) .gt. 255)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
30                    continue
                    else
                        do 40 i=1,n
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
40                      continue
                    end if
                else
C                   must test for null values
                    if (noscal)then
                         do 50 i=1,n
                             if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                              else
C                               trap any values that overflow the I*1 range
                                if (input(i).le. 255 .and.
     &                              input(i).ge. 0)then
                                    output(i)=char(input(i))
                                else if (input(i) .gt. 255)then
                                    status=-11
                                    output(i)=char(255)
                                else
                                    status=-11
                                    output(i)=char(0)
                                end if
                             end if
50                       continue
                    else
                      do 60 i=1,n
                        if (input(i) .eq. chkval)then
                                    anynul=.true.
                                    if (chktyp .eq. 1)then
                                        output(i)=setval
                                    else
                                        flgray(i)=.true.
                                    end if
                         else
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
                         end if
60                     continue
                    end if
                end if
        end if
        end
        subroutine fti4i2(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*4 values to output i*2 values, doing optional
C       scaling and checking for null values
 
C       input   i  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i  value in the input array that is used to indicated nulls
C       setval  i*2 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i*2 returned array of values
C       status  i  output error status (0 = ok)
 
        integer input(*),chkval
        integer*2 output(*),setval
        integer n,i,chktyp,status,maxi2,mini2
        double precision scale,zero,dval,i2max,i2min
        logical tofits,flgray(*),anynul,noscal
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
        parameter (maxi2=32767)
        parameter (mini2=-32768)
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. maxi2 .and.
     &                          input(i) .ge. mini2)then
                                    output(i)=input(i)
                            else if (input(i) .gt. maxi2)then
                                    status=-11
                                    output(i)=maxi2
                            else
                                    status=-11
                                    output(i)=mini2
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i2max .and. dval.gt.i2min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i2max)then
                                status=-11
                                output(i)=maxi2
                            else
                                status=-11
                                output(i)=mini2
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                          do 30 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. maxi2 .and.
     &                          input(i) .ge. mini2)then
                                    output(i)=input(i)
                            else if (input(i) .gt. maxi2)then
                                    status=-11
                                    output(i)=maxi2
                            else
                                    status=-11
                                    output(i)=mini2
                            end if
30                        continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                           do 50 i=1,n
                              if (input(i) .eq. chkval)then
                                        anynul=.true.
                                        if (chktyp .eq. 1)then
                                                output(i)=setval
                                        else
                                                flgray(i)=.true.
                                        end if
                              else
C                               trap any values that overflow the I*2 range
                                if (input(i) .le. maxi2 .and.
     &                              input(i) .ge. mini2)then
                                        output(i)=input(i)
                                else if (input(i) .gt. maxi2)then
                                        status=-11
                                        output(i)=maxi2
                                else
                                        status=-11
                                        output(i)=mini2
                                end if
                              end if
50                         continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=dval
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine fti4i4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*4 values to output i*4 values, doing optional
C       scaling and checking for null values
 
C       input   i  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i   value in the input array that is used to indicated nulls
C       setval  i   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i   returned array of values
C       status  i  output error status (0 = ok)
 
        integer input(*),chkval
        integer output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval,i4max,i4min
        logical tofits,flgray(*),anynul,noscal
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i4max .and. dval.gt.i4min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i4max)then
                                status=-11
                                output(i)=maxi4
                            else
                                status=-11
                                output(i)=mini4
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                    else
                        do 60 i=1,n
                            if (input(i) .eq. chkval)then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=dval
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine fti4r4(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*4 values to output r*4 values, doing optional
C       scaling and checking for null values
 
C       input   i  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i  value in the input array that is used to indicated nulls
C       setval  r  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  r  returned array of values
 
        integer input(*),chkval
        real output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine fti4r8(input,n,scale,zero,tofits,
     &          chktyp,chkval,setval,flgray,anynul,output,status)
 
C       copy input i*4 values to output r*8 values, doing optional
C       scaling and checking for null values
 
C       input   i  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       chkval  i  value in the input array that is used to indicated nulls
C       setval  d  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  d  returned array of values
 
        integer input(*),chkval
        double precision output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (input(i) .eq. chkval)then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine ftibin(ounit,nrows,nfield,ttype,tform,tunit,
     &                    extnam,pcount,status)
 
C       insert an binary table extension following the current HDU
 
C       ounit   i  fortran output unit number
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array) (optional)
C       tform   c  format of each field (array)
C       tunit   c  units of each field (array) (optional)
C       extnam  c  name of table extension (optional)
C       pcount  i  size of special data area following the table (usually = 0)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,nrows,nfield,pcount,status
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,nhdu,i,savstr,nblock,hsize,nkey
 
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
 
C       close the current HDU to make sure END and fill values are written
        call ftchdu(ounit,status)
        if (status .gt. 0)return
 
C       save the starting address of the next HDU
        nhdu=chdu(ibuff)+1
        savstr=hdstrt(ibuff,nhdu)
 
C       count number of optional TUNITS keywords to be written
        nkey=0
        do 5 i=1,nfield
               if (tunit(i) .ne. ' ')nkey=nkey+1
5       continue
        if (extnam .ne. ' ')nkey=nkey+1
 
C       calc min size of header
        nblock=(9 + 2*nfield + nkey +35)/36
        hsize=nblock*2880
 
C       define a fake CHDU with a minimum header
        dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize
 
C       define the size of the new HDU (this modifies hdstrt(ibuff,nhdu))
        call ftbdef(ounit,nfield,tform,pcount,nrows,status)
 
C       use start of next HDU to calc. how big this new HDU is
        nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880
 
C       reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       insert the required number of blocks at the end of the real CHDU
C       (first define hdutyp so that the correct fill value will be used)
        hdutyp(ibuff)=2
        call ftiblk(ounit,nblock,1,status)
        if (status .gt. 0)return
 
C       increment the number of HDUs in the file and their starting address
        maxhdu(ibuff)=maxhdu(ibuff)+1
        do 10 i=maxhdu(ibuff),nhdu,-1
                hdstrt(ibuff,i+1)=hdstrt(ibuff,i)
10      continue
 
C       again, reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       flush the buffers holding data for the old HDU
        call ftflsh(ibuff,status)
 
C       recover common block space containing column descriptors for old HDU
        call ftfrcl(ounit,status)
 
C       move to the new (empty) HDU
        chdu(ibuff)=nhdu
 
C       set parameters describing an empty header
        hdutyp(ibuff)=2
        nxthdr(ibuff)=hdstrt(ibuff,nhdu)
        hdend(ibuff)= hdstrt(ibuff,nhdu)
        dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize
 
C       write the header keywords
        call ftphbn(ounit,nrows,nfield,ttype,tform,tunit,extnam,
     &              pcount,status)
 
C       define the structure of the new HDU
        call ftbdef(ounit,nfield,tform,pcount,nrows,status)
        end
        subroutine ftiblk(ounit,nblock,hdrdat,status)
 
C       insert a 2880-byte block at the end of the current header or data.
 
C       ounit   i  fortran output unit number
C       nblock  i  number of blocks to insert
C       hdrdat  i  insert space in header (0) or data (1)
C       status  i  returned error status (0=ok)
 
        integer ounit,nblock,hdrdat,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        character*2880 buff(2)
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin
        character*1 cfill
 
        if (status .gt. 0)return
        tstat=status
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
C       set the appropriate fill value
        if (hdrdat .eq. 0 .or. hdutyp(ibuff) .eq. 1)then
C               fill  header or ASCII table with space
                cfill=char(32)
        else
C               fill with Null (0) in image or bintable data area
                cfill=char(0)
        end if
 
C       find position in file to insert new block
        if (hdrdat .eq. 0)then
            ipoint=dtstrt(ibuff)
        else
            ipoint=hdstrt(ibuff,chdu(ibuff)+1)
        end if
 
 
        if (nblock .eq. 1 .and. hdrdat .eq. 0)then
C******************************************************************
C  Don't use this algoritm, even though it may be faster (but initial
C  tests showed it didn't make any difference on a SUN) because it is
C  less safe than the other more general algorithm.  If there is
C  not enough disk space available for the added block, this faster
C  algorithm won't fail until it tries to move the last block, thus leaving
C  the FITS file in a corrupted state.   The other more general
C  algorithm tries to add a new empty block to the file as the
C  first step.  If this fails, it still leaves the current FITS
C  file unmodified, which is better for the user.
C******************************************************************
C  (Note added later:)
C  Will use this algorithm anyway when inserting one block in a FITS
C  header because the more general algorithm results in a status=252 error
C  in cases where the number of rows in a table has not yet been defined
C******************************************************************
C           use this more efficient algorithm if just adding a single block
C           initialize the first buffer
            do 5 i=1,2880
               buff(1)(i:i)=cfill
5           continue
 
            in=2
            out=1
 
C           move to the read start position
10          call ftmbyt(ounit,ipoint,.false.,status)
 
C           read one 2880-byte FITS logical record into the input buffer
            call ftgcbf(ounit,2880,buff(in),status)
 
C           check for End-Of-File
            if (status .eq. 107)go to 20
 
C           move back to the write start postion
            call ftmbyt(ounit,ipoint,.false.,status)
 
C           write the 2880-byte FITS logical record stored in the output buffer
            call ftpcbf(ounit,2880,buff(out),status)
 
C           check for error during write (the file may not have write access)
            if (status .gt. 0)return
 
C           swap the input and output buffer pointers and move to next block
            tin=in
            in=out
            out=tin
            ipoint=ipoint+2880
 
C           now repeat the process until we reach the End-Of-File
            go to 10
 
C           we have reached the end of file; now append the last block
20          status=tstat
 
C           move back to the write start postion
            call ftmbyt(ounit,ipoint,.true.,status)
 
C           write the 2880-byte FITS logical record stored in the output buffer
            call ftpcbf(ounit,2880,buff(out),status)
 
        else
C           use this general algorithm for adding arbitrary number of blocks
 
C           first, find the end of file
            thdu=chdu(ibuff)
 
30          call ftmahd(ounit,maxhdu(ibuff)+1,i,status)
 
            if (status .eq. 107)then
                status=tstat
C               move back to the current extension
                call ftmahd(ounit,thdu,i,status)
                go to 100
            else if (status .le. 0)then
                go to 30
            else
                call ftpmsg('Error while seeking End of File (FTIBLK)')
                return
            end if
 
C           calculate number of 2880-byte blocks that have to be shifted down
100         continue
            nshift=(hdstrt(ibuff,maxhdu(ibuff)+1)-ipoint)/2880
            jpoint=hdstrt(ibuff,maxhdu(ibuff)+1)-2880
 
C           move all the blocks, one at a time, starting at end of file and
C           working back to the insert position
            do 110 i=1,nshift
 
C               move to the read start position
                call ftmbyt(ounit,jpoint,.false.,status)
 
C               read one 2880-byte FITS logical record
                call ftgcbf(ounit,2880,buff,status)
 
C               move forward to the write start postion
                call ftmbyt(ounit,jpoint+nblock*2880,.true.,status)
 
C               write the 2880-byte FITS logical record
                call ftpcbf(ounit,2880,buff,status)
 
C               check for error
                if (status .gt. 0)then
                    call ftpmsg('Error inserting empty FITS block(s) '//
     &              '(FTIBLK)')
                    return
                end if
                jpoint=jpoint-2880
110         continue
 
            do 120 i=1,2880
                buff(1)(i:i)=cfill
120         continue
 
C           move back to the write start postion
            call ftmbyt(ounit,ipoint,.true.,status)
 
            do 130 i=1,nblock
C               write the 2880-byte FITS logical record
                call ftpcbf(ounit,2880,buff,status)
130         continue
        end if
 
        if (hdrdat .eq. 0)then
C               recalculate the starting location of the current data unit
                dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock
        end if
 
C       recalculate the starting location of all subsequent HDUs
        do 140 i=chdu(ibuff)+1,maxhdu(ibuff)+1
                    hdstrt(ibuff,i)=hdstrt(ibuff,i)+2880*nblock
140     continue
        if (status .gt. 0)then
            call ftpmsg('Error inserting FITS block(s) (FTIBLK)')
        end if
        end
        subroutine fticls(iunit,fstcol,ncols,ttype,tform,status)
 
C     insert one or more new columns into an existing table
 
C     iunit   i  Fortran I/O unit number
C     fstcol  i  number (position) for the new column; 1 = first column
C                  any existing columns will be moved up NCOLS positions
C     ncols   I  number of columns to insert
C     ttype   c  array of column names (values for TTYPEn keyword)
C     tform   c  array of column formats (values for TFORMn keyword)
C     status  i  returned error status (0=ok)
 
      integer iunit,fstcol,ncols,status
      character*(*) ttype(*),tform(*)
 
C     COMMON BLOCK DEFINITIONS:--------------------------------------------
      integer nf,nb,ne
      parameter (nb = 20)
      parameter (nf = 3000)
      parameter (ne = 512)
      integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
      integer nxtfld
      logical wrmode
      common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
      integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
      integer theap
      double precision tscale,tzero
      common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C     END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
      integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt
      integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i
      character comm*70,tfm*30,keynam*8
 
      if (status .gt. 0)return
 
C     define the number of the buffer used for this file
      ibuff=bufnum(iunit)
 
C     test that the CHDU is an ASCII table or BINTABLE
      typhdu=hdutyp(ibuff)
      if (typhdu .ne. 1 .and. typhdu .ne. 2)then
              status=235
              call ftpmsg('Can only append column to TABLE or '//
     &        'BINTABLE extension (FTICOL)')
              return
      end if
 
C     check that the column number is valid
      tflds=tfield(ibuff)
      if (fstcol .lt. 1)then
          status=302
          return
      else if (fstcol .gt. tflds)then
          colnum=tflds+1
      else
          colnum=fstcol
      end if
 
C     parse the tform values and calc number of bytes to add to each row
C     make sure format characters are in upper case:
      delbyt=0
      do 5 i=1,ncols
          tfm=tform(i)
          call ftupch(tfm)
 
          if (typhdu .eq. 1)then
              call ftasfm(tfm,datcod,width,decims,status)
C             add one space between the columns
              delbyt=delbyt+width+1
          else
              call ftbnfm(tfm,datcod,repeat,width,status)
              if (datcod .eq. 1)then
C                 bit column; round up to a multiple of 8 bits
                  delbyt=delbyt+(repeat+7)/8
              else if (datcod .eq. 16)then
C                 ASCII string column
                  delbyt=delbyt+repeat
               else
C                numerical data type
                  delbyt=delbyt+(datcod/10)*repeat
              end if
          end if
5     continue
 
C     quit on error, or if column is zero byte wide (repeat=0)
      if (status .gt. 0 .or. delbyt .eq. 0)return
 
C     get current size of the table
      naxis1=rowlen(ibuff)
      call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
 
C     Calculate how many more FITS blocks (2880 bytes) need to be added
      size=theap(ibuff)+heapsz(ibuff)
      freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size
      nblock=(freesp+2879)/2880
 
C     insert the needed number of new FITS blocks at the end of the HDU
      if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status)
 
C     shift the heap down, and update pointers to start of heap
      size=delbyt*naxis2
      call fthpdn(iunit,size,status)
 
C     calculate byte position in the row where to insert the new column
      if (colnum .gt. tflds)then
          fstbyt=naxis1
      else
          fstbyt=tbcol(colnum+tstart(ibuff))
      end if
 
C     insert DELBYT bytes in every row, at byte position FSTBYT
      call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status)
 
      if (typhdu .eq. 1)then
C         adjust the TBCOL values of the existing columns
          do 10 i=1,tflds
              call ftkeyn('TBCOL',i,keynam,status)
              call ftgkyj(iunit,keynam,tbc,comm,status)
              if (tbc .gt. fstbyt)then
                   tbc=tbc+delbyt
                   call ftmkyj(iunit,keynam,tbc,'&',status)
              end if
10        continue
      end if
 
C     update the mandatory keywords
      call ftmkyj(iunit,'TFIELDS',tflds+ncols,'&',status)
      call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status)
 
C     increment the index value on any existing column keywords
      call ftkshf(iunit,colnum,tflds,ncols,status)
 
C     add the required keywords for the new columns
      do 15 i=1,ncols
          comm='label for field'
          call ftpkns(iunit,'TTYPE',colnum,1,ttype(i),comm,status)
 
          comm='format of field'
          tfm=tform(i)
          call ftupch(tfm)
          call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status)
 
          if (typhdu .eq. 1)then
              comm='beginning column of field '
              if (colnum .eq. tflds+1)then
C                 allow for the space between preceding column
                  tbc=fstbyt+2
C                 set tflds 0, so this branch will not be executed again
              else
                  tbc=fstbyt+1
              end if
              call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status)
 
C             increment the column starting position for the next column
              call ftasfm(tfm,datcod,width,decims,status)
C             add one space between the columns
              fstbyt=fstbyt+width+1
          end if
 
          colnum=colnum+1
15    continue
 
C     parse the header to initialize the new table structure
      call ftrdef(iunit,status)
        end
        subroutine fticol(iunit,numcol,ttype,tform,status)
 
C       insert a new column into an existing table
 
C       iunit   i  Fortran I/O unit number
C       numcol  i  number (position) for the new column; 1 = first column
C                  any existing columns will be moved up one position
C       ttype   c  name of column (value for TTYPEn keyword)
C       tform   c  column format (value for TFORMn keyword)
C       status  i  returned error status (0=ok)
 
        integer iunit,numcol,status
        character*(*) ttype,tform
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt
        integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i
        character comm*70,tfm*30,keynam*8
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       test that the CHDU is an ASCII table or BINTABLE
        typhdu=hdutyp(ibuff)
        if (typhdu .ne. 1 .and. typhdu .ne. 2)then
                status=235
                call ftpmsg('Can only append column to TABLE or '//
     &          'BINTABLE extension (FTICOL)')
                return
        end if
 
C       check that the column number is valid
        tflds=tfield(ibuff)
        if (numcol .lt. 1)then
            status=302
            return
        else if (numcol .gt. tflds)then
            colnum=tflds+1
        else
            colnum=numcol
        end if
 
C       parse the tform value and calc number of bytes to add to each row
C       make sure format characters are in upper case:
        tfm=tform
        call ftupch(tfm)
 
        if (typhdu .eq. 1)then
            call ftasfm(tfm,datcod,width,decims,status)
C           add one space between the columns
            delbyt=width+1
        else
            call ftbnfm(tfm,datcod,repeat,width,status)
            if (datcod .eq. 1)then
C               bit column; round up to a multiple of 8 bits
                delbyt=(repeat+7)/8
            else if (datcod .eq. 16)then
C               ASCII string column
                delbyt=repeat
            else
C               numerical data type
                delbyt=(datcod/10)*repeat
            end if
        end if
 
C       quit on error, or if column is zero byte wide (repeat=0)
        if (status .gt. 0 .or. delbyt .eq. 0)return
 
C       get current size of the table
        naxis1=rowlen(ibuff)
        call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
 
C       Calculate how many more FITS blocks (2880 bytes) need to be added
        size=theap(ibuff)+heapsz(ibuff)
        freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size
        nblock=(freesp+2879)/2880
 
C       insert the needed number of new FITS blocks at the end of the HDU
        if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status)
 
C       shift the heap down, and update pointers to start of heap
        size=delbyt*naxis2
        call fthpdn(iunit,size,status)
 
C       calculate byte position in the row where to insert the new column
        if (colnum .gt. tflds)then
            fstbyt=naxis1
        else
            fstbyt=tbcol(colnum+tstart(ibuff))
        end if
 
C       insert DELBYT bytes in every row, at byte position FSTBYT
        call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status)
 
        if (typhdu .eq. 1)then
C           adjust the TBCOL values of the existing columns
            do 10 i=1,tflds
                call ftkeyn('TBCOL',i,keynam,status)
                call ftgkyj(iunit,keynam,tbc,comm,status)
                if (tbc .gt. fstbyt)then
                     tbc=tbc+delbyt
                     call ftmkyj(iunit,keynam,tbc,'&',status)
                end if
10          continue
        end if
 
C       update the mandatory keywords
        call ftmkyj(iunit,'TFIELDS',tflds+1,'&',status)
        call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status)
 
C       increment the index value on any existing column keywords
        call ftkshf(iunit,colnum,tflds,1,status)
 
C       add the required keywords for the new column
        comm='label for field'
        call ftpkns(iunit,'TTYPE',colnum,1,ttype,comm,status)
 
        comm='format of field'
        call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status)
 
        if (typhdu .eq. 1)then
            comm='beginning column of field '
            if (colnum .eq. tflds+1)then
C               allow for the space between preceding column
                tbc=fstbyt+2
            else
                tbc=fstbyt+1
            end if
            call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status)
        end if
 
C       parse the header to initialize the new table structure
        call ftrdef(iunit,status)
        end
        subroutine ftiimg(ounit,bitpix,naxis,naxes,status)
 
C       insert an IMAGE extension following the current HDU
 
C       ounit   i  fortran output unit number
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       status  i  returned error status (0=ok)
 
        integer ounit,bitpix,naxis,naxes(*),status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,nhdu,i,savstr,nblock
 
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
 
        if (chdu(ibuff) .eq. 1)then
          if ( hdend(ibuff) .eq. hdstrt(ibuff,chdu(ibuff)) )then
C           Nothing has been written to the file yet, so write primary array
            call ftphpr(ounit,.true., bitpix,naxis,naxes,0,1,
     &                  .true.,status)
           return
          end if
        end if
 
C       close the current HDU to make sure END and fill values are written
        call ftchdu(ounit,status)
        if (status .gt. 0)return
 
C       save the starting address of the next HDU
        nhdu=chdu(ibuff)+1
        savstr=hdstrt(ibuff,nhdu)
 
C       define a fake CHDU with a one block header
        dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+2880
 
C       define the size of the new HDU (this modifies hdstrt(ibuff,nhdu))
        call ftpdef(ounit,bitpix,naxis,naxes,0,1,status)
 
C       use start of next HDU to calc. how big this new HDU is
        nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880
 
C       reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       insert the required number of blocks at the end of the real CHDU
C       (first define hdutyp so that the correct fill value will be used)
        hdutyp(ibuff)=0
        call ftiblk(ounit,nblock,1,status)
        if (status .gt. 0)return
 
C       increment the number of HDUs in the file and their starting address
        maxhdu(ibuff)=maxhdu(ibuff)+1
        do 10 i=maxhdu(ibuff),nhdu,-1
                hdstrt(ibuff,i+1)=hdstrt(ibuff,i)
10      continue
 
C       again, reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       flush the buffers holding data for the old HDU
        call ftflsh(ibuff,status)
 
C       recover common block space containing column descriptors for old HDU
        call ftfrcl(ounit,status)
 
C       move to the new (empty) HDU
        chdu(ibuff)=nhdu
 
C       set parameters describing an empty 1 block header
        hdutyp(ibuff)=0
        nxthdr(ibuff)=hdstrt(ibuff,nhdu)
        hdend(ibuff)= hdstrt(ibuff,nhdu)
        dtstrt(ibuff)=hdstrt(ibuff,nhdu)+2880
 
C       write the header keywords
        call ftphpr(ounit,.true.,bitpix,naxis,naxes,0,1,.true.,status)
 
C       define the structure of the new HDU
        call ftpdef(ounit,bitpix,naxis,naxes,0,1,status)
        end
        subroutine ftikyd(ounit,keywrd,dval,decim,comm,status)
 
C       insert a double E keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim
 
        character value*35,key*8,com*47
        character*80 record
        integer nkeys,keypos,vlen
 
        if (status .gt. 0)return
 
C       convert double to F format character string and construct the record
        call ftd2e(dval,decim,value,vlen,status)
        key=keywrd
        com=comm
        record=key//'= '//value(1:vlen)//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikye(ounit,keywrd,rval,decim,comm,status)
 
C       insert a real*4 E keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        integer ounit,status,decim
        real rval
 
        character value*20,key*8,com*47
        character*80 record
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
C       convert real to F format character string and construct the full record
        call ftr2e(rval,decim,value,status)
        key=keywrd
        com=comm
        record=key//'= '//value//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikyf(ounit,keywrd,rval,decim,comm,status)
 
C       insert a real*4 F keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        integer ounit,status,decim
        real rval
 
        character value*20,key*8,com*47
        character*80 record
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
C       convert real to F format character string and construct the full record
        call ftr2f(rval,decim,value,status)
        key=keywrd
        com=comm
        record=key//'= '//value//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikyg(ounit,keywrd,dval,decim,comm,status)
 
C       insert a double F keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        integer ounit,status,decim
        double precision dval
 
        character value*20,key*8,com*47
        character*80 record
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
C       convert double to F format character string and construct the record
        call ftd2f(dval,decim,value,status)
        key=keywrd
        com=comm
        record=key//'= '//value//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikyj(ounit,keywrd,intval,comm,status)
 
C       insert an integer keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       intval  i  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        integer ounit,status,intval
 
        character value*20,key*8,com*47
        character*80 record
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
C       convert integer to character string and construct the full record
        call fti2c(intval,value,status)
        key=keywrd
        com=comm
        record=key//'= '//value//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikyl(ounit,keywrd,logval,comm,status)
 
C       insert a logical keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       logval  l  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
 
        character*(*) keywrd,comm
        integer ounit,status
        logical logval
 
        character value*20,key*8,com*47
        character*80 record
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
C       convert logical to character string and construct the full record
        call ftl2c(logval,value,status)
        key=keywrd
        com=comm
        record=key//'= '//value//' / '//com
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,record,status)
        end
        subroutine ftikys(ounit,keywrd,strval,comm,status)
 
C       insert a string keyword into the header at the current position
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       strval  c  keyword value
C       comm    c  keyword comment
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, March 1993
C       Modifed 9/94 to call FTPKLS, supporting the OGIP long string convention
 
        character*(*) keywrd,comm,strval
        integer ounit,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        integer lenval,length,i,nspace,ibuff,nexthd,endhd,nkeys,keypos
 
        if (status .gt. 0)return
 
C       find how many keywords are required to write the string, in case it
C       cannot fit onto one keyword and has to be continued on multiple lines.
 
        lenval=len(strval)
        length=0
        do 10 i=lenval,1,-1
                if (strval(i:i) .ne. ' ')then
                        length=i
                        go to 20
                end if
10      continue
20      nspace=max(1,(length-2)/67+1)
 
C       save current pointer values
        ibuff=bufnum(ounit)
        endhd=hdend(ibuff)
        nexthd=nxthdr(ibuff)
 
C       insert enough spaces in the header at the current location
        call ftghps(ounit,nkeys,keypos,status)
 
        do 30 i=1,nspace
            call ftirec(ounit,keypos,' ',status)
30      continue
 
C       temporarily reset position of the end of header to force keyword
C       to be written at the current header position.
        hdend(ibuff)=nexthd
 
C       write the keyword (supporting the OGIP long string convention)
        call ftpkls(ounit,keywrd,strval,comm,status)
 
C       reset the next keyword pointer to follow the inserted keyword
        nxthdr(ibuff)=nexthd+80*nspace
 
C       reset the end-of-header pointer to its real location
        hdend(ibuff)=endhd+80*nspace
        end
        subroutine ftikyu(ounit,keywrd,comm,status)
 
C       insert a null-valued keyword to a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,comm
        integer ounit,status
        character keynam*8,card*80
        integer nkeys,keypos
 
        if (status .gt. 0)return
 
        keynam=keywrd
        card=keynam//'=                      / '//comm
 
        call ftghps(ounit,nkeys,keypos,status)
        call ftirec(ounit,keypos,card,status)
        end
        subroutine ftinit(funit,fname,block,status)
 
C       open a new FITS file with write access
C
C       funit   i  Fortran I/O unit number
C       fname   c  name of file to be opened
C       block   i  input record length blocking factor
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer funit,status,block,strlen,i
        character*(*) fname
 
        if (status .gt. 0)return
 
C       ignore any leading blanks in the file name
        strlen=len(fname)
        do 10 i=1,strlen
            if (fname(i:i) .ne. ' ')then
 
C               call the machine dependent routine which creates the file
                call ftopnx(funit,fname(i:),1,1,block,status)
                if (status .gt. 0)then
         call ftpmsg('FTINIT failed to create the following new file:')
         call ftpmsg(fname)
                    return
                end if
 
C               set column descriptors as undefined
                call ftfrcl(funit,-999)
 
C               set current column name buffer as undefined
                call ftrsnm
                return
            end if
10      continue
 
C       if we got here, then the input filename was all blanks
        status=105
        call ftpmsg('FTINIT: Name of file to create is blank.')
        end
        subroutine ftirec(ounit,pos,record,status)
 
C       insert a 80-char keyword record into the header at the pos-th keyword
C       position (i.e., immediately before the current keyword at position POS.
C
C       ounit   i  fortran output unit number
C       pos     i  keyword will be inserted at this position (1 = 1st keyword)
C       record  c*80  keyword record
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Jan 1995
 
        character*(*) record
        integer ounit,pos,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        character*80 outrec, inrec
        integer ibuff, fkey, lkey, i, nexthd, nkey
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
C       calculate number of existing keywords
        nkey=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80
 
        if (pos .eq. nkey+1)then
C               simply append the record to the header
                call ftprec(ounit,record,status)
                return
        else if (pos .lt. 1 .or. pos .gt.  nkey)then
                status=203
                return
        end if
 
        outrec=record
 
C       move to the insert position
        nexthd=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80
        call ftmbyt(ounit,nexthd,.false.,status)
        nxthdr(ibuff)=nexthd
 
C       calculated the first and last keyword to be rewritten
        fkey=pos
        lkey=fkey + (hdend(ibuff)-nexthd)/80 - 1
 
C       now sequentially read each keyword and overwrite it with the previous
        do 10 i=fkey,lkey
                call ftgrec(ounit,i,inrec,status)
                call ftmodr(ounit,outrec,status)
                outrec=inrec
10      continue
 
C       finally, write the last keyword
        call ftprec(ounit,outrec,status)
 
C       reset the next keyword pointer to follow the inserted keyword
        nxthdr(ibuff)=nexthd+80
        end
        subroutine ftirow(iunit,frow,nrows,status)
 
C       insert NROWS blank rows immediated after row FROW
 
C       iunit   i  Fortran I/O unit number
C       frow    i  row number after which the new rows will be inserted.
C                  Specify  0 to add rows to the beginning of the table.
C       nrows   i  number of rows to add to the table (must be greater than 0)
C       status  i  returned error status (0=ok)
 
        integer iunit,frow,nrows,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,naxis1,naxis2,size,freesp,nblock
        character comm*8
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       test that the CHDU is an ASCII table or BINTABLE
        if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then
                status=235
                call ftpmsg('Can only add rows to TABLE or BINTABLE '//
     &          'extension (FTIROW)')
                return
        end if
 
        if (nrows .lt. 0)then
                 status=306
                 call ftpmsg('Cannot insert negative number of ' //
     &           'rows in the table (FTIROW)')
                 return
        else if (nrows .eq. 0)then
                 return
        end if
 
C       get current size of the table
        call ftgkyj(iunit,'NAXIS1',naxis1,comm,status)
        call ftgkyj(iunit,'NAXIS2',naxis2,comm,status)
 
        if (frow .gt. naxis2)then
                status=307
                call ftpmsg('Insert position is greater than the '//
     &            'number of rows in the table (FTIROW)')
                return
        else if (frow .lt. 0)then
                status=307
                call ftpmsg('Insert starting row number is less than 0'
     &          //' (FTIROW)')
                return
        end if
 
C       Calculate how many more FITS blocks (2880 bytes) need to be added
        size=theap(ibuff)+heapsz(ibuff)
        freesp=((size+2879)/2880)*2880 - size
        size=naxis1*nrows-freesp
        nblock=(size+2879)/2880
 
C       insert the needed number of new FITS blocks
        if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status)
 
C       shift the heap down, and update pointers to start of heap
        size=naxis1*nrows
        call fthpdn(iunit,size,status)
 
C       shift the rows down
        call ftrwdn(iunit,frow,naxis2,nrows,status)
 
C       update the NAXIS2 keyword
        naxis2=naxis2+nrows
        call ftmkyj(iunit,'NAXIS2',naxis2,'&',status)
        end
        subroutine ftitab(ounit,rowlen,nrows,nfield,ttype,tbcol,
     &                    tform,tunit,extnam,status)
 
C       insert an ASCII table extension following the current HDU
 
C       ounit   i  fortran output unit number
C       rowlen  i  width of a row, in characters
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array) (optional)
C       tform   c  format of each field (array)
C       tunit   c  units of each field (array) (optional)
C       extnam  c  name of table extension (optional)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,rowlen,nrows,nfield,tbcol(*),status
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
 
        integer ibuff,nhdu,i,savstr,nblock,hsize,nkey
 
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
 
C       close the current HDU to make sure END and fill values are written
        call ftchdu(ounit,status)
        if (status .gt. 0)return
 
C       save the starting address of the next HDU
        nhdu=chdu(ibuff)+1
        savstr=hdstrt(ibuff,nhdu)
 
C       count number of optional TUNITS keywords to be written
        nkey=0
        do 5 i=1,nfield
               if (tunit(i) .ne. ' ')nkey=nkey+1
5       continue
        if (extnam .ne. ' ')nkey=nkey+1
 
C       calc min size of header
        nblock=(9 + 3*nfield + nkey +35)/36
        hsize=nblock*2880
 
C       define a fake CHDU with minimum header
        dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize
 
C       define the size of the new HDU (this modifies hdstrt(ibuff,nhdu))
        call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status)
 
C       use start of next HDU to calc. how big this new HDU is
        nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880
 
C       reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       insert the required number of blocks at the end of the real CHDU
C       (first define hdutyp so that the correct fill value will be used)
        hdutyp(ibuff)=1
        call ftiblk(ounit,nblock,1,status)
        if (status .gt. 0)return
 
C       increment the number of HDUs in the file and their starting address
        maxhdu(ibuff)=maxhdu(ibuff)+1
        do 10 i=maxhdu(ibuff),nhdu,-1
                hdstrt(ibuff,i+1)=hdstrt(ibuff,i)
10      continue
 
C       again, reset the start of the next HDU back to it original value
        hdstrt(ibuff,nhdu)=savstr
 
C       flush the buffers holding data for the old HDU
        call ftflsh(ibuff,status)
 
C       recover common block space containing column descriptors for old HDU
        call ftfrcl(ounit,status)
 
C       move to the new (empty) HDU
        chdu(ibuff)=nhdu
 
C       set parameters describing an empty header
        hdutyp(ibuff)=1
        nxthdr(ibuff)=hdstrt(ibuff,nhdu)
        hdend(ibuff)= hdstrt(ibuff,nhdu)
        dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize
 
C       write the header keywords
        call ftphtb(ounit,rowlen,nrows,nfield,ttype,tbcol,tform,tunit,
     &              extnam,status)
 
C       define the structure of the new HDU
        call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status)
 
        end
        subroutine ftkeyn(keywrd,nseq,keyout,status)
 
C       Make a keyword name by concatinating the root name and a
C       sequence number
 
C       keywrd  c  root keyword name
C       nseq    i  sequence number
C       OUTPUT PARAMETERS:
C       keyout  c  output concatinated keyword name
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        character*(*) keywrd,keyout
        integer nseq,status,nspace,i
        character value*20,work*8
 
        work=keywrd
 
C       find end of keyword string
        nspace=1
        do 10 i=1,8
                if (work(i:i) .eq. ' ')go to 15
                nspace=nspace+1
10      continue
15      continue
 
C       append sequence number to keyword root only if there is room
        if (nseq .lt. 0)then
C               illegal value
                go to 900
        else if (nseq .lt. 10 .and. nspace .le. 8)then
                write(work(nspace:nspace),1001,err=900)nseq
        else if (nseq .lt. 100 .and. nspace .le. 7)then
                write(work(nspace:nspace+1),1002,err=900)nseq
        else if (nseq .lt. 1000 .and. nspace .le. 6)then
                write(work(nspace:nspace+2),1003,err=900)nseq
        else if (nseq .lt. 10000 .and. nspace .le. 5)then
                write(work(nspace:nspace+3),1004,err=900)nseq
        else if (nseq .lt. 100000 .and. nspace .le. 4)then
                write(work(nspace:nspace+4),1005,err=900)nseq
        else if (nseq .lt. 1000000 .and. nspace .le. 3)then
                write(work(nspace:nspace+5),1006,err=900)nseq
        else if (nseq .lt. 10000000 .and. nspace .le. 2)then
                write(work(nspace:nspace+6),1007,err=900)nseq
        else
C               number too big to fit in keyword
                go to 900
        end if
 
1001    format(i1)
1002    format(i2)
1003    format(i3)
1004    format(i4)
1005    format(i5)
1006    format(i6)
1007    format(i7)
 
        keyout=work
        return
C       come here if error concatinating the seq. no. to the root string
900     continue
 
        if (status .gt. 0)return
        status=206
        write(value,1008)nseq
1008    format(i20)
        call ftpmsg('Could not concatinate the integer '//value//
     & ' to the root keyword named: '//work)
        end
        subroutine ftkshf(iunit,colmin,colmax,incre,status)
 
C       shift the index value on any existing column keywords
C       This routine will modify the name of any keyword that begins with 'T'
C       and has an index number in the range COLMIN - COLMAX, inclusive.
 
C       if incre is positive, then the index values will be incremented.
C       if incre is negative, then the kewords with index = COLMIN
C       will be deleted and the index of higher numbered keywords will
C       be decremented.
 
C       iunit   i  Fortran I/O unit number
C       colmin  i  starting column number to be incremented
C       colmax  i  maximum column number to be increment
C       incre   i  amount by which the index value should be shifted
C       status  i  returned error status (0=ok)
 
        integer iunit,colmin,colmax,incre,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,typhdu,tflds,nkeys,nmore,nrec,ival,tstat,i1
        character rec*80,newkey*8,q*4
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       test that the CHDU is an ASCII table or BINTABLE
        typhdu=hdutyp(ibuff)
        if (typhdu .ne. 1 .and. typhdu .ne. 2)then
                status=235
                call ftpmsg('Can only operate on TABLE or '//
     &          'BINTABLE extension (FTKSHF)')
                return
        end if
 
C       test column number limits
        tflds=tfield(ibuff)
        if (colmin .lt. 1 .or. colmax .lt. 1)then
             status=302
             return
        else if (colmin .gt. colmax .or. colmin .gt. tflds)then
             return
        end if
 
C       get the number of keywords in the header
        call ftghsp(iunit,nkeys,nmore,status)
 
C       go thru header starting with the 9th keyword looking for 'TxxxxNNN'
 
        nrec=9
100     call ftgrec(iunit,nrec,rec,status)
 
        if (rec(1:1) .eq. 'T')then
            q=rec(2:5)
            i1=6
 
C           search list of 5-character 'official' indexed keywords
            if ( q .eq. 'BCOL' .or. q .eq. 'FORM' .or. q .eq. 'TYPE'
     &      .or. q .eq. 'UNIT' .or. q .eq. 'NULL' .or. q .eq. 'SCAL'
     &      .or. q .eq. 'ZERO' .or. q .eq. 'DISP')go to 20
 
C           search list of 5-character 'local' indexed keywords
            if ( q .eq. 'LMIN' .or. q .eq. 'LMAX' .or. q .eq. 'DMIN'
     &      .or. q .eq. 'DMAX' .or. q .eq. 'CTYP' .or. q .eq. 'CRPX'
     &      .or. q .eq. 'CRVL' .or. q .eq. 'CDLT' .or. q .eq. 'CROT'
     &      .or. q .eq. 'CUNI')go to 20
 
            q=rec(1:4)
            i1=5
C           search list of 4-character 'official' indexed keywords
            if (q .eq. 'TDIM')go to 20
 
C           no match so go on to next keyword
            go to 90
 
20          continue
C           try reading the index number suffix
            tstat=0
            call ftc2ii(rec(i1:8),ival,tstat)
            if (tstat .eq. 0 .and. ival .ge. colmin .and.
     &          ival .le. colmax)then
                if (incre .le. 0 .and. ival .eq. colmin)then
C                   delete keyword related to this column
                    call ftdrec(iunit,nrec,status)
                    nkeys=nkeys-1
                    nrec=nrec-1
                else
                    ival=ival+incre
                    i1=i1-1
                    call ftkeyn(rec(1:i1),ival,newkey,status)
                    rec(1:8)=newkey
C                   modify the index number of this keyword
                    call ftmrec(iunit,nrec,rec,status)
                end if
            end if
        end if
 
90      nrec=nrec+1
        if (nrec .le. nkeys)go to 100
        end
        subroutine ftl2c(lval,cval,status)
C       convert a logical value to a C*20 right justified character string
        integer status
        logical lval
        character*20 cval
 
        if (status .gt. 0)return
 
        if (lval)then
                cval='                   T'
        else
                cval='                   F'
        end if
        end
        subroutine ftldrc(iunit,nrec,igneof,status)
 
C       low-level routine to load a specified record from a file into
C       a physical buffer, if it is not already loaded.  Reset all
C       pointers to make this the new current record for that file.
C       Update ages of all the physical buffers.
 
C       iunit   i  fortran unit number
C       nrec    i  direct access file record number to be loaded
C       igneof  l  ignore end of file error (107)?
C       status  i  output error status
 
        integer iunit,nrec,status
        logical igneof
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
        integer compid
        common/ftcpid/compid
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer i,lbuff,pbuff,ounit,olen,orec,a1,tstat
 
        if (status .gt. 0)return
 
        lbuff=bufnum(iunit)
 
C       check if record is already loaded in one of the physical buffers
        do 10 i=1,maxbuf
            if (logbuf(i) .eq. lbuff .and. recnum(i) .eq. nrec)then
C               found the desired record; don't have to read it
                pbuff=i
                go to 20
            end if
10      continue
 
C       the record is not already loaded, so we have to read it from disk.
C       First, decide which physical buffer into which to read it.
        call ftwhbf(lbuff,pbuff)
 
        if (modify(pbuff))then
C           old buffer has been modified, so we have to flush it to disk
            ounit=buflun(logbuf(pbuff))
            olen=reclen(logbuf(pbuff))
            orec=recnum(pbuff)
            call ftwrit(ounit,orec,olen,pbuff,status)
            modify(pbuff)=.false.
        end if
 
C       now read the record into the physical buffer
        olen=reclen(lbuff)
        tstat=0
        call ftread(iunit,nrec,olen,pbuff,tstat)
 
        if (.not. igneof .and. tstat .eq. 107)then
C           return if hit EOF and told not to ignore it
            status=107
            return
        else if (tstat .eq. 107)then
C           apparently hit end of file
 
            if (.not. wrmode(lbuff))then
C               just return if we don't have write access to the file
                return
            else
C               fill the new buffer with the desired value
                if (hdutyp(lbuff) .eq. 1)then
C                   ASCII table: fill buffer with blanks
                    call ftflbl(pbuff)
                else if (compid .ge. -1)then
C                   initialize buffer = 0 (except on Cray machines)
                    call ftflzr(pbuff)
                else
C                   call special routine for Cray machines, since words
C                   are twice as long (integers are 8-bytes long)
                    call ftzrcr(pbuff)
                end if
 
C               mark the new record as having been modified
                modify(pbuff)=.true.
            end if
        end if
 
C       define log. buffer and the record number contained in the phys. buffer
        logbuf(pbuff)=lbuff
        recnum(pbuff)=nrec
 
20      continue
C       this is now the current buffer for this logical buffer
        currnt(lbuff)=pbuff
        bytnum(lbuff)=0
 
C       find the current position of the buffer in the age index
        do 30 i=1,maxbuf
            if (pindex(i) .eq. pbuff)then
               a1=i
               go to 35
            end if
30      continue
 
35      continue
C       rebuild the indices giving the chronological ordering of the buffers
        do 40 i=a1,maxbuf-1
                pindex(i)=pindex(i+1)
40      continue
C       this buffer is now the youngest (= last in the index)
        pindex(maxbuf)=pbuff
        end
        subroutine ftmahd(iunit,extno,xtend,status)
 
C       Move to Absolute Header Data unit
C       move the i/o pointer to the specified HDU and initialize all
C       the common block parameters which describe the extension
 
C       iunit   i  fortran unit number
C       extno   i  number of the extension to point to.
C       xtend   i  returned type of extension:   0 = the primary HDU
C                                                1 = an ASCII table
C                                                2 = a binary table
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,extno,xtend,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,movto,tstat
 
        if (status .gt. 0)then
            return
        else if (extno .le. 0 .or. extno .ge. ne)then
            status=301
            return
        end if
 
        ibuff=bufnum(iunit)
 
C       check if we are already positioned to the correct HDU
        if (extno .eq. chdu(ibuff))then
C           just return the type of extension
            xtend=hdutyp(ibuff)
        else
 
C           now move to the extension, or the highest one we know about
10          movto=min(extno,maxhdu(ibuff)+1)
 
C           before closing out the CHDU, make sure the new extension exists
            call ftmbyt(iunit,hdstrt(ibuff,movto),.false.,status)
            if (status .gt. 0)return
 
C           close out the current HDU before moving to the new one
            call ftchdu(iunit,status)
            if (status .gt. 0)then
                call ftpmsg('FTMAHD could not close the'//
     &              ' current HDU before moving to the new HDU.')
                return
            end if
 
            call ftgext(iunit,movto,xtend,status)
            if (status .gt. 0)then
C               failed to move to new extension, so restore previous extension
                tstat=0
                call ftrhdu(iunit,movto,tstat)
                return
            end if
 
C           continue reading extensions until we get to the one we want
            if (movto .lt. extno)go to 10
        end if
        end
        subroutine ftmbyt(iunit,bytno,igneof,status)
 
C       move i/o pointer so that it is pointing to the byte number BYTNUM
C       in the FITS file.  Subsequent read or write operations will begin
C       at this point.
 
C       iunit   i  fortran unit number
C       bytno   i  number of the byte to point to.
C       igneof  l  ignore end-of-file (107) error?
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
C       rewritten Feb, 1995
 
        integer iunit,bytno,status
        logical igneof
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer lbuff,record,byten
 
        if (status .gt. 0)then
                return
        else if (bytno .lt. 0)then
C               error: negative byte number
                status=304
        else
                lbuff=bufnum(iunit)
 
C               calculate the record number and byte offset to move to
                record=bytno/reclen(lbuff)+1
                byten=mod(bytno,reclen(lbuff))
 
                if (record .ne. recnum(currnt(lbuff)))then
C                       not the current record, so load the new record;
                        call ftldrc(iunit,record,igneof,status)
                end if
                bytnum(lbuff)=byten
        end if
        end
        subroutine ftmcom(ounit,keywrd,comm,status)
 
C       modify a the comment string in a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       comm    c  new keyword comment (max of 72 characters long)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        character*(*) keywrd,comm
        integer ounit,status,lenval,ncomm
        character value*80,knam*8,cmnt*72
 
        if (status .gt. 0)return
 
        knam=keywrd
 
C       find the old keyword + value string
        call ftgcrd(ounit,knam,value,status)
        if (status .eq. 202)then
          call ftpmsg('FTMCOM Could not find the '//knam//' keyword.')
          return
        end if
 
        call ftprsv(value,lenval,status)
 
        cmnt=comm
 
C       find amount of space left for comment string (3 spaces needed for ' / ')
        ncomm=77-lenval
 
C       write the keyword record if there is space
        if (ncomm .gt. 0)then
          call ftmodr(ounit,
     &    value(1:lenval)//' / '//cmnt(1:ncomm),status)
        end if
        end
        subroutine ftmcrd(ounit,keywrd,card,status)
 
C       modify (overwrite) a given header record specified by keyword name.
C       This can be used to overwrite the name of the keyword as well as
C       the value and comment fields.
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       card    c  new 80-character card image to be written
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        character*(*) keywrd,card
        integer ounit,status
        character value*80
 
        if (status .gt. 0)return
 
C       find the old keyword string
        call ftgcrd(ounit,keywrd,value,status)
 
        value=card
 
C       make sure new keyword name is in upper case
        call ftupch(value(1:8))
 
C       test that keyword name contains only legal characters
        call fttkey(value(1:8),status)
 
C       write the new keyword record
        call ftmodr(ounit,value,status)
        end
        subroutine ftmkey(ounit,keywrd,value,comm,status)
 
C       modify an existing simple FITS keyword record with format:
C            "KEYWORD = VALUE / COMMENT"
C               VALUE is assumed to be 20 characters long
C               COMMENT is assumed to be 47 characters long
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       value   c  keyword value   (20 characters, cols. 11-30)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,value,comm
        integer ounit,status
        character key*8, val*20, com*47
 
        key=keywrd
        val=value
        com=comm
 
C       overwrite the preceeding 80 characters to the output buffer:
        call ftmodr(ounit,key//'= '//val//' / '//com,status)
        end
        subroutine ftmkyd(ounit,keywrd,dval,decim,comm,status)
 
C       modify a double precision value header record in E format
C       If it will fit, the value field will be 20 characters wide;
C       otherwise it will be expanded to up to 35 characters, left
C       justified.
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (max. 47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim,vlen
        character value*35,key*8,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
        key=keywrd
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert double precision to E format character string
        call ftd2e(dval,decim,value,vlen,status)
 
C       write the keyword record
        call ftmodr(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status)
        end
        subroutine ftmkye(ounit,keywrd,rval,decim,comm,status)
 
C       modify a real*4 value header record in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim
        character value*20,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert real to E format character string
        call ftr2e(rval,decim,value,status)
 
C       modify the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmkyf(ounit,keywrd,rval,decim,comm,status)
 
C       modify a real*4 value header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim
        character value*20,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert real to F format character string
        call ftr2f(rval,decim,value,status)
 
C       write the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmkyg(ounit,keywrd,dval,decim,comm,status)
 
C       modify a double precision value header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim
        character value*20,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert double precision to F format character string
        call ftd2f(dval,decim,value,status)
 
C       modify the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmkyj(ounit,keywrd,intval,comm,status)
 
C       modify an integer value header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       intval  i  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer ounit,status,intval
        character value*20,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert integer to character string
        call fti2c(intval,value,status)
 
C       modify the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmkyl(ounit,keywrd,logval,comm,status)
 
C       modify a logical value header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       logval  l  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer ounit,status
        logical logval
        character value*20,cmnt*48
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
C       convert logical to character string
        call ftl2c(logval,value,status)
 
C       modify the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmkys(ounit,keywrd,strval,comm,status)
 
C       modify a character string value header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       strval  c  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C       modifed 7/93 to support string keywords continued over multiple cards
C       modified 9/94 to support the OGIP long string convention
 
        character*(*) keywrd,strval,comm
        integer ounit,status
 
        integer clen,i,nvalue,ncomm
        character keynam*8,value*70,cmnt*48,bslash
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        if (status .gt. 0)return
 
C       check if the new value is too long to fit in a single 'card image'
        clen=len(strval)
        if (clen .le. 68)go to 20
 
        do 10 i=clen,69,-1
                if (strval(i:i) .ne. ' ')go to 100
10      continue
 
C       now check that the old keyword is not continued over multiple cards
C       read the (first line) of the existing keyword
 
20      call ftgkey(ounit,keywrd,value,cmnt,status)
        if (status .gt. 0)go to 900
 
C       is last character of the value a backslash or & ?
C       have to use 2 \\'s because the SUN compiler treats 1 \ as an escape
        bslash='\\'
        do 30 i=70,1,-1
                if (value(i:i) .ne. ' '.and. value(i:i).ne.'''')then
                    if (value(i:i) .eq. bslash .or.
     &                  value(i:i) .eq. '&')then
C                     backspace the current header pointer by one record
                      nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-80
                      go to 100
                    else
                      go to 40
                    end if
                end if
30      continue
 
C       OK, we can simply overwrite the old keyword with the new
40      continue
 
C       overwrite the old comment unless user supplied the magic value
        if (comm .ne. '&')then
                cmnt=comm
        end if
C       convert string to quoted character string (max length = 70 characters)
        call fts2c(strval,value,clen,status)
        if (status .gt. 0)go to 900
 
C       find amount of space left for comment string
C       (assume 10 char. for 'keyword = ', and 3 between value and comment)
C       which leaves 67 spaces for the value string + comment string
        nvalue=max(20,clen)
        ncomm=67-nvalue
 
C       write the keyword record
        keynam=keywrd
        if (ncomm .gt. 0)then
C         there is space for a comment
          call ftmodr(ounit,
     &    keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status)
        else
C         no room for a comment
          call ftmodr(ounit,
     &    keynam//'= '//value(1:nvalue)//'   ',status)
        end if
        go to 900
 
100     continue
 
C       Either the old or new keyword is continued over multiple
C       header card images, so have to use a less efficient way to modify
C       the keyword by completely deleting the old and inserting the new.
 
C       read the old comment, if we need to preserve it
        if (comm .eq. '&')then
                call ftgkys(ounit,keywrd,value,cmnt,status)
                if (status .gt. 0)go to 900
C               reset the current header pointer by 2 records to make
C               it faster (usually) to find and delete the keyword
                nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-160
        else
                cmnt=comm
        end if
 
C       delete the old keyword
        call ftdkey(ounit,keywrd,status)
        if (status .gt. 0)go to 900
 
C       insert the new keyword
        call ftikys(ounit,keywrd,strval,cmnt,status)
 
900     continue
        end
        subroutine ftmkyu(ounit,keywrd,comm,status)
 
C       modify a null-valued keyword
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,comm
        integer ounit,status
        character value*80,cmnt*80
 
        if (status .gt. 0)return
 
C       find the old keyword
        call ftgkey(ounit,keywrd,value,cmnt,status)
 
C       check for special symbol indicating that comment should not be changed
        if (comm .ne. '&')then
              cmnt=comm
        end if
 
        value = ' '
 
C       modify the keyword record
        call ftmkey(ounit,keywrd,value,cmnt,status)
        end
        subroutine ftmnam(ounit,oldkey,newkey,status)
 
C       modify (overwrite) the name of an existing keyword, preserving
C       the current value and comment fields
C
C       ounit   i  fortran output unit number
C       oldkey  c  old keyword name    ( 8 characters, cols.  1- 8)
C       newkey  c  new keyword name to be written
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        character*(*) oldkey,newkey
        integer ounit,status
        character card*80
 
        if (status .gt. 0)return
 
C       find the old keyword string
        call ftgcrd(ounit,oldkey,card,status)
 
        card(1:8)=newkey
 
C       make sure new keyword name is in upper case
        call ftupch(card(1:8))
 
C       test that keyword name contains only legal characters
        call fttkey(card(1:8),status)
 
C       write the new keyword record
        call ftmodr(ounit,card,status)
        end
        subroutine ftmodr(ounit,record,status)
 
C       modify the preceeding 80 character record in the FITS header
C
C       ounit   i  fortran output unit number
C       record  c  input 80 character header record
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) record
        character*80  rec
        integer ounit,status,ibuff
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        rec=record
 
C       make sure keyword name is in upper case
        call ftupch(rec(1:8))
 
C       test that keyword name contains only legal characters
        call fttkey(rec(1:8),status)
 
C       move the I/O pointer back to the beginning of the preceeding keyword
        call ftmbyt(ounit,nxthdr(ibuff)-80,.false.,status)
 
C       overwrite the 80 characters to the output buffer:
        call ftpcbf(ounit,80,rec,status)
        end
        subroutine ftmrec(ounit,nkey,record,status)
 
C       modify the nth keyword in the CHU, by replacing it with the
C       input 80 character string.
C
C       ounit   i  fortran output unit number
C       nkey    i  sequence number (starting with 1) of the keyword to read
C       record  c  80-character string to replace the record with
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,nkey,status
        character*(*) record
        character rec*80
 
C       find the old keyword; just use REC as a temporary variable
        call ftgrec(ounit,nkey,rec,status)
 
        rec=record
C       overwrite the keyword with the new record
        call ftmodr(ounit,rec,status)
        end
        subroutine ftmrhd(iunit,extmov,xtend,status)
 
C       Move Relative Header Data unit
C       move the i/o pointer to the specified HDU and initialize all
C       the common block parameters which describe the extension
 
C       iunit   i  fortran unit number
C       extmov  i  number of the extension to point to, relative to the CHDU
C       xtend   i  returned type of extension:   0 = the primary HDU
C                                                1 = an ASCII table
C                                                2 = a binary table
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991
 
        integer iunit,extmov,xtend,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,extno
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       calculate the absolute HDU number, then move to it
        extno=chdu(ibuff)+extmov
        call ftmahd(iunit,extno,xtend,status)
        end
        subroutine ftnkey(nseq,keywrd,keyout,status)
 
C       Make a keyword name by concatinating a sequence number and
C       the root name. (Sequence number is prepended to the name)
 
C       nseq    i  sequence number
C       keywrd  c  root keyword name
C       OUTPUT PARAMETERS:
C       keyout  c  output concatinated keyword name
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Aug 1994
 
        character*(*) keywrd,keyout
        integer nseq,status,nspace,i
        character value*20,work*8
 
        work=keywrd
 
C       find end of keyword string
        nspace=0
        do 10 i=8,1,-1
                if (work(i:i) .ne. ' ')go to 15
                nspace=nspace+1
10      continue
15      continue
 
C       prepend sequence number to keyword root only if there is room
        if (nseq .lt. 0)then
C               illegal value
                go to 900
        else if (nseq .lt. 10 .and. nspace .ge. 1)then
                write(keyout,1001,err=900)nseq,work(1:7)
        else if (nseq .lt. 100 .and. nspace .ge. 2)then
                write(keyout,1002,err=900)nseq,work(1:6)
        else if (nseq .lt. 1000 .and. nspace .ge. 3)then
                write(keyout,1003,err=900)nseq,work(1:5)
        else if (nseq .lt. 10000 .and. nspace .ge. 4)then
                write(keyout,1004,err=900)nseq,work(1:4)
        else if (nseq .lt. 100000 .and. nspace .ge. 5)then
                write(keyout,1005,err=900)nseq,work(1:3)
        else if (nseq .lt. 1000000 .and. nspace .ge. 6)then
                write(keyout,1006,err=900)nseq,work(1:2)
        else if (nseq .lt. 10000000 .and. nspace .ge. 7)then
                write(keyout,1007,err=900)nseq,work(1:1)
        else
C               number too big to fit in keyword
                go to 900
        end if
 
1001    format(i1,a7)
1002    format(i2,a6)
1003    format(i3,a5)
1004    format(i4,a4)
1005    format(i5,a3)
1006    format(i6,a2)
1007    format(i7,a1)
 
        return
C       come here if error concatinating the seq. no. to the root string
900     continue
 
        if (status .gt. 0)return
        status=206
        write(value,1008)nseq
1008    format(i20)
        call ftpmsg('Could not concatinate the integer '//value//
     & ' and the root keyword named: '//work)
        end
        subroutine ftnulc(input,np,chktyp,setval,flgray,anynul,
     &                    scaled,scale,zero)
 
C       check input complex array for nulls and apply scaling
C       if chktyp=1 then set the undefined pixel = SETVAL
C       if chktyp=2 then set the corresponding FLGRAY = .true.
 
C       When scaling complex data values,  both the real and imaginary
C       components of the value are scaled by SCALE, but the offset
C       given by ZERO is only applied to the real part of the complex number
 
C       input   r  input array of values
C       np      i  number of pairs of values
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  r  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       scaled  l  does data need to be scaled?
C       scale   d  scale factor
C       zero    d  offset
 
        real input(*),setval(2)
        integer np,i,chktyp,j
        double precision scale,zero
        logical flgray(*),anynul,scaled
        logical fttrnn
        external fttrnn
 
        if (chktyp .eq. 2)then
C               initialize the null flag values
                do 5 i=1,np
                        flgray(i)=.false.
5               continue
        end if
 
        j=1
        do 10 i=1,np
C               do the real part of the complex number
                if (chktyp .ne. 0 .and. fttrnn(input(j)))then
                    anynul=.true.
                    if (chktyp .eq. 1)then
C                               set both parts of the complex number to the
C                               specified special value
                                input(j)=setval(1)
                                input(j+1)=setval(2)
                    else
C                               set the corresponding flag value to true
                                flgray(i)=.true.
                    end if
                    j=j+2
                else if (scaled)then
                    input(j)=input(j)*scale+zero
                    j=j+1
 
C                   do the imaginary part of the complex number
                    if (chktyp .ne. 0 .and. fttrnn(input(j)))then
                            anynul=.true.
                            if (chktyp .eq. 1)then
C                               set both parts of the complex number to the
C                               specified special value
                                input(j-1)=setval(1)
                                input(j)=setval(2)
                            else
C                               set the corresponding flag value to true
                                flgray(i)=.true.
                            end if
                    else if (scaled)then
                        input(j)=input(j)*scale
                    end if
                    j=j+1
                else
                    j=j+2
                end if
10      continue
        end
        subroutine ftnulm(input,np,chktyp,setval,flgray,anynul,
     &                    scaled,scale,zero)
 
C       check input double complex array for nulls and apply scaling
C       if chktyp=1 then set the undefined pixel = SETVAL
C       if chktyp=2 then set the corresponding FLGRAY = .true.
 
C       When scaling complex data values,  both the real and imaginary
C       components of the value are scaled by SCALE, but the offset
C       given by ZERO is only applied to the real part of the complex number
 
C       input   d  input array of values
C       np      i  number of pairs of values
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  d  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       scaled  l  does data need to be scaled?
C       scale   d  scale factor
C       zero    d  offset
 
        double precision input(*),setval(2)
        integer np,i,chktyp,j
        double precision scale,zero
        logical flgray(*),anynul,scaled
        logical fttdnn
        external fttdnn
 
        if (chktyp .eq. 2)then
C               initialize the null flag values
                do 5 i=1,np
                        flgray(i)=.false.
5               continue
        end if
 
        j=1
        do 10 i=1,np
C               do the real part of the complex number
                if (chktyp .ne. 0 .and. fttdnn(input(j)))then
                    anynul=.true.
                    if (chktyp .eq. 1)then
C                               set both parts of the complex number to the
C                               specified special value
                                input(j)=setval(1)
                                input(j+1)=setval(2)
                    else
C                               set the corresponding flag value to true
                                flgray(i)=.true.
                    end if
                    j=j+2
                else if (scaled)then
                    input(j)=input(j)*scale+zero
                    j=j+1
 
C                   do the imaginary part of the complex number
                    if (chktyp .ne. 0 .and. fttdnn(input(j)))then
                            anynul=.true.
                            if (chktyp .eq. 1)then
C                               set both parts of the complex number to the
C                               specified special value
                                input(j-1)=setval(1)
                                input(j)=setval(2)
                            else
C                               set the corresponding flag value to true
                                flgray(i)=.true.
                            end if
                    else if (scaled)then
                        input(j)=input(j)*scale
                    end if
                    j=j+1
                else
                    j=j+2
                end if
10      continue
        end
        subroutine ftopen(funit,fname,rwmode,block,status)
 
C       open an existing FITS file with readonly or read/write access
C
C       funit   i  Fortran I/O unit number
C       fname   c  name of file to be opened
C       rwmode  i  file access mode: 0 = readonly; else = read and write
C       block   i  returned record length blocking factor
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer funit,rwmode,block,status,strlen,i,xtend
        character*(*) fname
 
        if (status .gt. 0)return
 
C       ignore any leading blanks in the file name
        strlen=len(fname)
        do 10 i=1,strlen
            if (fname(i:i) .ne. ' ')then
 
C               call the machine dependent routine which opens the file
                call ftopnx(funit,fname(i:),0,rwmode,block,status)
                if (status .gt. 0)then
                     call ftpmsg('FTOPEN failed to Find and/or Open'//
     &                         ' the following file:')
                     call ftpmsg(fname)
                     return
                end if
 
C               set column descriptors as undefined
                call ftfrcl(funit,-999)
 
C               determine the structure and size of the primary HDU
                call ftrhdu(funit,xtend,status)
                if (status .gt. 0)then
                  call ftpmsg('FTOPEN could not interpret primary '
     &              //'array header keywords of file:')
                  call ftpmsg(fname)
                  if (status .eq. 252)then
                      call ftpmsg('Is this a FITS file??')
                  end if
                end if
 
C               set current column name buffer as undefined
                call ftrsnm
                return
            end if
10      continue
 
C       if we got here, then the input filename was all blanks
        status=104
        call ftpmsg('FTOPEN: Name of file to open is blank.')
        return
 
        end
        subroutine ftopnx(funit,fname,oldnew,rwmode,block,status)
 
C       low-level, machine-dependent routine to create or 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
C       modified Feb 1995
 
        integer funit,oldnew,rwmode,block,status,i,ibuff,inital,size
        character*(*) fname
        logical igneof,found
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer pb
        parameter (pb = 20)
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
 
        integer compid
        common/ftcpid/compid
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        real rword
        double precision dword
 
        save inital
        data inital/0/
 
        if (status .gt. 0)return
 
        if (inital .eq. 0)then
C           first time through need to initialize pointers
            nxtfld=0
            maxbuf=pb
            do 2 i=1,nb
                buflun(i)=0
2           continue
            do 4 i=1,pb
                logbuf(i)=0
                recnum(i)=0
                modify(i)=.false.
                pindex(i)=i
4           continue
            inital=1
 
C           Determine at run time what type of machine we are running on.
C           Initialize a real and double value to arbitrary values.
            rword=1.1111111111
            dword=1.1111111111D+00
 
C           ftarch looks at the equivalent integer value
            call ftarch(rword,dword,compid)
        end if
 
C       check for valid unit number
        if (funit .lt. 1 .or. funit .gt. 199)then
                status=101
                return
        end if
 
C       find available logical buffer slot for this file
        do 10 i=1,nb
                if (buflun(i) .eq. 0)then
                        ibuff=i
                        go to 20
                end if
10      continue
 
C       error: no vacant logical buffer slots left
        status=102
        return
 
20      continue
 
        if (oldnew .eq. 0)then
            igneof = .false.
C           test if file exists
            inquire(file=fname,exist=found)
            if (.not. found)then
C               error: file doesn't exist??
                status=103
                return
            end if
        else
            igneof = .true.
        end if
 
        call ftopnf(funit,fname,oldnew,rwmode,block,size,status)
 
C       initialize the HDU parameters
        maxrec(ibuff)=size
 
        if (oldnew .eq. 1 .or. block .le. 1)then
C           new files always have a record length of 2880 bytes
            reclen(ibuff)=2880
        else
            reclen(ibuff)=block
        end if
 
        bufnum(funit)=ibuff
        chdu(ibuff)=1
        hdutyp(ibuff)=0
        maxhdu(ibuff)=1
        hdstrt(ibuff,1)=0
        hdend(ibuff)=0
        nxthdr(ibuff)=0
C       data start location is undefined
        dtstrt(ibuff)=-1000000000
 
        heapsz(ibuff)=0
        theap(ibuff)=0
        tfield(ibuff)=0
        rowlen(ibuff)=0
 
C       initialize the logical buffer parameters
        buflun(ibuff)=funit
        currnt(ibuff)=0
 
        if (rwmode .eq. 0)then
                wrmode(ibuff)=.false.
        else
                wrmode(ibuff)=.true.
        end if
 
C       load the first record of the file
        call ftldrc(funit,1,igneof,status)
        end
        subroutine ftp2db(ounit,group,dim1,nx,ny,array,status)
 
C       Write a 2-d image of byte values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   c*1  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        character*1 array(dim1,*)
        integer fpixel,row
 
        fpixel=1
        do 10 row = 1,ny
                call ftpprb(ounit,group,fpixel,nx,array(1,row),status)
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftp2dd(ounit,group,dim1,nx,ny,array,status)
 
C       Write a 2-d image of r*8 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   d  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        double precision array(dim1,*)
        integer fpixel,row
 
        fpixel=1
        do 10 row = 1,ny
                call ftpprd(ounit,group,fpixel,nx,array(1,row),status)
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftp2de(ounit,group,dim1,nx,ny,array,status)
 
C       Write a 2-d image of r*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   r  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        real array(dim1,*)
        integer fpixel,row
 
        fpixel=1
        do 10 row = 1,ny
                call ftppre(ounit,group,fpixel,nx,array(1,row),status)
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftp2di(ounit,group,dim1,nx,ny,array,status)
 
C       Write a 2-d image of i*2 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   i*2  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        integer*2 array(dim1,*)
        integer fpixel,row
 
        fpixel=1
        do 10 row = 1,ny
                call ftppri(ounit,group,fpixel,nx,array(1,row),status)
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftp2dj(ounit,group,dim1,nx,ny,array,status)
 
C       Write a 2-d image of i*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       nx      i  size of the image in the x direction
C       ny      i  size of the image in the y direction
C       array   i  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,nx,ny,status
        integer array(dim1,*)
        integer fpixel,row
 
        fpixel=1
        do 10 row = 1,ny
                call ftpprj(ounit,group,fpixel,nx,array(1,row),status)
                fpixel=fpixel+nx
10      continue
 
        end
        subroutine ftp3db(ounit,group,dim1,dim2,nx,ny,nz,array,status)
 
C       Write a 3-d cube of byte values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   c*1  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        character*1 array(dim1,dim2,*)
        integer fpixel,row,band
 
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
            call ftpprb(ounit,group,fpixel,nx,array(1,row,band),status)
            fpixel=fpixel+nx
10      continue
20      continue
 
        end
        subroutine ftp3dd(ounit,group,dim1,dim2,nx,ny,nz,array,status)
 
C       Write a 3-d cube of r*8 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   r*8  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        double precision array(dim1,dim2,*)
        integer fpixel,row,band
 
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
            call ftpprd(ounit,group,fpixel,nx,array(1,row,band),status)
            fpixel=fpixel+nx
10      continue
20      continue
 
        end
        subroutine ftp3de(ounit,group,dim1,dim2,nx,ny,nz,array,status)
 
C       Write a 3-d cube of r*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   r  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        real array(dim1,dim2,*)
        integer fpixel,row,band
 
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
            call ftppre(ounit,group,fpixel,nx,array(1,row,band),status)
            fpixel=fpixel+nx
10      continue
20      continue
 
        end
        subroutine ftp3di(ounit,group,dim1,dim2,nx,ny,nz,array,status)
 
C       Write a 3-d cube of i*2 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   i*2  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        integer*2 array(dim1,dim2,*)
        integer fpixel,row,band
 
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
            call ftppri(ounit,group,fpixel,nx,array(1,row,band),status)
            fpixel=fpixel+nx
10      continue
20      continue
 
        end
        subroutine ftp3dj(ounit,group,dim1,dim2,nx,ny,nz,array,status)
 
C       Write a 3-d cube of i*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       dim1    i  actual first dimension of ARRAY
C       dim2    i  actual second dimension of ARRAY
C       nx      i  size of the cube in the x direction
C       ny      i  size of the cube in the y direction
C       nz      i  size of the cube in the z direction
C       array   i  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,dim1,dim2,nx,ny,nz,status
        integer array(dim1,dim2,*)
        integer fpixel,row,band
 
        fpixel=1
        do 20 band=1,nz
        do 10 row = 1,ny
            call ftpprj(ounit,group,fpixel,nx,array(1,row,band),status)
            fpixel=fpixel+nx
10      continue
20      continue
 
        end
        subroutine ftpbit(setbit,wrbit,buffer)
 
C       encode the individual bits within the byte as specified by
C       the input logical array. The corresponding bit is set to
C       1 if the logical array element is true.  Only the bits
C       between begbit and endbit, inclusive, are set or reset;
C       the remaining bits, if any, remain unchanged.
 
C       setbit  l  input array of logical data values corresponding
C                  to the bits to be set in the output buffer
C                  TRUE means corresponding bit is to be set.
C       wrbit   l  input array of logical values indicating which
C                  bits in the byte are to be modified.  If FALSE,
C                  then the corresponding bit should remain unchanged.
C       buffer  i  output integer containing the encoded byte
C
C       written by Wm Pence, HEASARC/GSFC, May 1992
 
        integer buffer,tbuff,outbit
        logical setbit(8),wrbit(8)
 
        outbit=0
        tbuff=buffer
 
C       test each of the 8 bits, starting with the most significant
        if (tbuff .gt. 127)then
C           the bit is currently set in the word
            if (wrbit(1) .and. (.not.setbit(1)))then
C                only in this case do we reset the bit
            else
C               in all other cases we want the bit to be set
                outbit=outbit+128
            end if
            tbuff=tbuff-128
        else
C           bit is currently not set; set it only if requested to
            if (wrbit(1) .and. setbit(1))outbit=outbit+128
        end if
 
        if (tbuff .gt. 63)then
            if (wrbit(2) .and. (.not.setbit(2)))then
            else
                outbit=outbit+64
            end if
            tbuff=tbuff-64
        else
            if (wrbit(2) .and. setbit(2))outbit=outbit+64
        end if
 
        if (tbuff .gt. 31)then
            if (wrbit(3) .and. (.not.setbit(3)))then
            else
                outbit=outbit+32
            end if
            tbuff=tbuff-32
        else
            if (wrbit(3) .and. setbit(3))outbit=outbit+32
        end if
 
        if (tbuff .gt. 15)then
            if (wrbit(4) .and. (.not.setbit(4)))then
            else
                outbit=outbit+16
            end if
            tbuff=tbuff-16
        else
            if (wrbit(4) .and. setbit(4))outbit=outbit+16
        end if
 
        if (tbuff .gt. 7)then
            if (wrbit(5) .and. (.not.setbit(5)))then
            else
                outbit=outbit+8
            end if
            tbuff=tbuff-8
        else
            if (wrbit(5) .and. setbit(5))outbit=outbit+8
        end if
 
        if (tbuff .gt. 3)then
            if (wrbit(6) .and. (.not.setbit(6)))then
            else
                outbit=outbit+4
            end if
            tbuff=tbuff-4
        else
            if (wrbit(6) .and. setbit(6))outbit=outbit+4
        end if
 
        if (tbuff .gt. 1)then
            if (wrbit(7) .and. (.not.setbit(7)))then
            else
                outbit=outbit+2
            end if
            tbuff=tbuff-2
        else
            if (wrbit(7) .and. setbit(7))outbit=outbit+2
        end if
 
        if (tbuff .eq. 1)then
            if (wrbit(8) .and. (.not.setbit(8)))then
            else
                outbit=outbit+1
            end if
        else
            if (wrbit(8) .and. setbit(8))outbit=outbit+1
        end if
 
        buffer=outbit
        end
        subroutine ftpbnh(ounit,nrows,nfield,ttype,tform,tunit,
     &                    extnam,pcount,status)
 
C       OBSOLETE routine: should call ftphbn instead
 
        integer ounit,nrows,nfield,pcount,status
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
        call ftphbn(ounit,nrows,nfield,ttype,tform,tunit,
     &                    extnam,pcount,status)
        end
        subroutine ftpcbf(ounit,nchar,cbuff,status)
 
C       "Put Character BuFfer"
C       copy input buffer of characters to the output character buffer.
 
C       ounit   i  Fortran output unit number
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
C       modified Feb 1995
 
        integer ounit,nchar,status
        character*(*) cbuff
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer lbuff,pbuff,buflen,lastb,nleft,in1,nbyt,nrec
 
        if (status .gt. 0)return
 
        lbuff=bufnum(ounit)
        buflen=reclen(lbuff)
 
        if (nchar .lt. 0)then
C               error: negative number of bytes to write
                status=306
                return
        else if (.not. wrmode(lbuff))then
C           don't have write access to this file
            status=112
            return
        end if
 
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
 
        nleft=nchar
        in1=1
 
C       find the number of bytes that will fit in output buffer
200     pbuff=currnt(lbuff)
        lastb=bytnum(lbuff)
        nbyt=min(nleft,buflen-lastb)
        if (nbyt .gt. 0)then
C           append the input buffer to the output physical buffer
            go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &      19,20)pbuff
 
C               if got here, then pbuff is out of range
                status=101
                return
 
1               b1(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
2               b2(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
3               b3(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
4               b4(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
5               b5(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
6               b6(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
7               b7(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
8               b8(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
9               b9(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
10              b10(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
11              b11(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
12              b12(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
13              b13(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
14              b14(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
15              b15(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
16              b16(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
17              b17(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
18              b18(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
19              b19(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
20              b20(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
 
100         modify(pbuff)=.true.
            bytnum(lbuff)=bytnum(lbuff)+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if
 
C       process more bytes, if any
        if (nleft .gt. 0)then
          nrec=recnum(pbuff)+1
 
          if (nleft .gt. buflen)then
C           first, flush any current buffers to disk
            call ftflsh(lbuff,status)
 
C           write whole blocks directly to the FITS file by-passing buffers
150         write(ounit,rec=nrec,err=900)cbuff(in1:in1+buflen-1)
            in1=in1+buflen
            nleft=nleft-buflen
            bytnum(lbuff)=bytnum(lbuff)+buflen
            nrec=nrec+1
            if (nleft .gt. buflen)go to 150
 
C           Save maximum record written, for comparison in ftread
            maxrec(lbuff) = max(maxrec(lbuff), nrec-1)
          end if
 
C         load the next file record into a physical buffer
          call ftldrc(ounit,nrec,.true.,status)
          if (status .gt. 0)return
          go to 200
        end if
        return
 
C       come here if there was a disk write error of some sort
900     status=106
        end
        subroutine ftpcbo(ounit,gsize,ngroup,offset,cbuff,status)
 
C       "Put Character BuFfer with Offsets"
C       copy input buffer of characters to the output character buffer.
 
C       ounit   i  Fortran output unit number
C       gsize   i  size of each group of bytes
C       ngroup  i  number of groups to write
C       offset  i  size of gap between groups
C       cbuff   c  input character string
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996
 
        integer ounit,gsize,ngroup,offset,status
        character cbuff*(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,pb
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (pb = 20)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer lbuff,pbuff,buflen,lastb,nleft,in1,nbyt
        integer i,bytno,record,oldrec,incre
 
        if (status .gt. 0)return
 
        lbuff=bufnum(ounit)
 
        if (.not. wrmode(lbuff))then
C           don't have write access to this file
            status=112
            return
        end if
 
        buflen=reclen(lbuff)
        pbuff =currnt(lbuff)
        oldrec=recnum(pbuff)
C       lastb = position of last byte read or written in FITS buffer
        lastb =bytnum(lbuff)
        bytno =(oldrec-1) * buflen + lastb
C       in1   = position of first byte remaining in the input buffer
        in1   =1
        incre =gsize+offset
        nbyt  = 0
 
        do 500 i = 1,ngroup
 
C           nleft   = number of bytes left in the input buffer
            nleft=gsize
C           nbyt    = number of bytes to transfer from input to output
            nbyt=min(nleft,buflen-lastb)
            if (nbyt .eq. 0)go to 300
 
200         continue
C           append the input buffer to the output physical buffer
            go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &         19,20)pbuff
 
C               if got here, then pbuff is out of range
                status=101
                return
 
1               b1(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
2               b2(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
3               b3(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
4               b4(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
5               b5(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
6               b6(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
7               b7(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
8               b8(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
9               b9(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
10              b10(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
11              b11(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
12              b12(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
13              b13(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
14              b14(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
15              b15(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
16              b16(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
17              b17(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
18              b18(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
19              b19(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
                go to 100
20              b20(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
 
100         in1=in1+nbyt
            nleft=nleft-nbyt
 
C           process more bytes, if any
300         continue
            if (nleft .gt. 0)then
C               entire group did not fit in the buffer
C               load the next file record into a physical buffer
                oldrec=oldrec+1
                modify(pbuff)=.true.
                call ftldrc(ounit,oldrec,.true.,status)
                if (status .gt. 0)return
                pbuff=currnt(lbuff)
                lastb=0
                nbyt=nleft
                go to 200
            end if
 
            if (i .ne. ngroup)then
C               move to the position of the next group
                bytno=bytno+incre
                record=bytno/buflen+1
                lastb=mod(bytno,buflen)
 
                if (record .ne. oldrec)then
C                   not the current record, so load the new record;
                    modify(pbuff)=.true.
                    call ftldrc(ounit,record,.true.,status)
                    if (status .gt. 0)return
                    oldrec=record
                    pbuff=currnt(lbuff)
                end if
            end if
500     continue
 
        modify(pbuff)=.true.
        bytnum(lbuff)=lastb+nbyt
        end
        subroutine ftpcks(iunit,status)
 
C       Create or update the checksum keywords in the CHU.  These keywords
C       provide a checksum verification of the FITS HDU based on the ASCII
C       coded 1's complement checksum algorithm developed by Rob Seaman at NOAO.
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Sept, 1994
 
        integer iunit,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nf = 3000)
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        double precision sum,dsum,odsum
        integer ibuff,nrec,dd,mm,yy,dummy,i,tstat
        character datstr*8,string*16,comm*40,oldcks*16,datsum*20
        logical complm
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       generate current date string to put into the keyword comment
        call ftgsdt(dd,mm,yy,status)
        if (status .gt. 0)return
 
        datstr='  /  /  '
        write(datstr(1:2),1001)dd
        write(datstr(4:5),1001)mm
        write(datstr(7:8),1001)yy
1001    format(i2)
 
C       replace blank with leading 0 in each field if required
        if (datstr(1:1) .eq. ' ')datstr(1:1)='0'
        if (datstr(4:4) .eq. ' ')datstr(4:4)='0'
        if (datstr(7:7) .eq. ' ')datstr(7:7)='0'
 
C       get the checksum keyword, if it exists, otherwise initialize it
        tstat=status
        call ftgkys(iunit,'CHECKSUM',oldcks,comm,status)
        if (status .eq. 202)then
          status=tstat
          oldcks=' '
          comm='encoded HDU checksum updated on '//datstr
          call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status)
        end if
 
C       get the DATASUM keyword and convert it to a double precision value
C       if it exists, otherwise initialize it
        tstat=status
        call ftgkys(iunit,'DATASUM',datsum,comm,status)
        if (status .eq. 202)then
          status=tstat
          odsum=0.
C         set the CHECKSUM keyword as undefined
          oldcks=' '
          comm='data unit checksum updated on '//datstr
          call ftpkys(iunit,'DATASUM','         0',comm,status)
        else
C         decode the datasum into a double precision variable
          do 10 i=1,20
            if (datsum(i:i) .ne. ' ')then
                call ftc2dd(datsum(i:20),odsum,status)
                if (status .eq. 409)then
C                   couldn't read the keyword; assume it is out of date
                    status=tstat
                    odsum=-1.
                end if
                go to 15
            end if
10        continue
          odsum=0.
        end if
 
C       rewrite the header END card, and following blank fill
15      call ftwend(iunit,status)
        if (status .gt. 0)return
 
C       now re-read the required keywords to determine the structure
        call ftrhdu(iunit,dummy,status)
 
C       write the correct data fill values, if they are not already correct
        call ftpdfl(iunit,status)
 
C       calc. checksum of the data records; first, calc number of data records
        nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880
        dsum=0.
 
        if (nrec .gt. 0)then
C           move to the start of the data
            call ftmbyt(iunit,dtstrt(ibuff),.true.,status)
 
C           accumulate the 32-bit 1's complement checksum
            call ftcsum(iunit,nrec,dsum,status)
        end if
 
        if (dsum .ne. odsum)then
C               modify the DATASUM keyword with the correct value
                comm='data unit checksum updated on '//datstr
C               write the datasum into an I10 integer string
                write(datsum,2000)dsum
2000            format(f11.0)
                call ftmkys(iunit,'DATASUM',datsum(1:10),comm,status)
C               set the CHECKSUM keyword as undefined
                oldcks=' '
        end if
 
C       if DATASUM was correct, check if CHECKSUM is still OK
        if (oldcks .ne. ' ')then
 
C           move to the start of the header
            call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status)
 
C           accumulate the header checksum into the previous data checksum
            nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880
            sum=dsum
            call ftcsum(iunit,nrec,sum,status)
 
C           encode the COMPLEMENT of the checksum into a 16-character string
            complm=.true.
            call ftesum(sum,complm,string)
 
C           return if the checksum is correct
            if (string .eq. '0000000000000000')then
                return
            else if (oldcks .eq. '0000000000000000')then
C               update the CHECKSUM keyword value with the checksum string
                call ftmkys(iunit,'CHECKSUM',string,'&',status)
                return
            end if
        end if
 
C       Zero the checksum and compute the new value
        comm='encoded HDU checksum updated on '//datstr
        call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status)
 
C       move to the start of the header
        call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status)
 
C       accumulate the header checksum into the previous data checksum
        nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880
        sum=dsum
        call ftcsum(iunit,nrec,sum,status)
 
C       encode the COMPLEMENT of the checksum into a 16-character string
        complm=.true.
        call ftesum(sum,complm,string)
 
C       update the CHECKSUM keyword value with the checksum string
        call ftmkys(iunit,'CHECKSUM',string,'&',status)
        end
        subroutine ftpclb(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of unsigned byte data values to the
C       specified column of the table.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   i  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        character*1 array(*)
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        real rval
        logical tofits,lval,trans
        integer*2 i2val
        character sval*30,sform*13,snull*8,i1val*1,messge*80
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(ounit,colnum,frow,felem,nelem,1,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,ival,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
        i1=1
        ntodo=nelem
        rstart=0
C       the data are being scaled from internal format to FITS:
        tofits=.true.
 
C       see if we can write the raw input bytes, or whether we have to
C       copy data to temporary array prior to byteswapping or scaling
C       (Note that byteswapping is not a factor for byte data type).
        if (abs(tcode) .eq. 11 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
                  trans=.false.
        else
                  trans=.true.
        end if
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,repeat-estart,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp + rstart*lenrow + estart*incre
        call ftmbyt(ounit,bstart,.true.,status)
 
C       copy data to buffer, doing scaling and datatype conversion, if required
        if (tcode .eq. 11)then
C           column data type is B (byte)
            if (trans)then
C               convert the input data into a temporary buffer
                call fti1i1(array(i1),itodo,scale,zero,tofits,
     &              ival,i1val,i1val,lval,lval,chbuff,status)
C               do any machine dependent conversion and write the byte data
                call ftpi1b(ounit,itodo,incre,chbuff,status)
            else
C               directly write the input array
                call ftpi1b(ounit,itodo,incre,array(i1),status)
            end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
                call fti1i2(array(i1),itodo,scale,zero,tofits,
     &             ival,i1val,i2val,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*2 data
                call ftpi2b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
                call fti1i4(array(i1),itodo,scale,zero,tofits,
     &          ival,i1val,ival,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*4 data
                call ftpi4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
                call fti1r4(array(i1),itodo,scale,zero,tofits,
     &          ival,i1val,rval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*4 data
                call ftpr4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
                call fti1r8(array(i1),itodo,scale,zero,tofits,
     &          ival,i1val,dval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*8 data
                call ftpr8b(ounit,itodo,incre,buffer,status)
        else
C               this is an ASCII table column
                ival=ichar(array(i1))
                if (ival .lt. 0)ival=ival+256
                dval=(ival-zero)/scale
 
                if (sform(5:5) .eq. 'I')then
C                   column data type is integer
C                   trap any values that overflow the I*4 range
                    if (dval .lt. i4max .and. dval .gt. i4min)then
                        ival=nint(dval)
                    else if (ival .ge. i4max)then
                        status=-11
                        ival=maxi4
                    else
                        status=-11
                        ival=mini4
                    end if
 
C                   create the formated character string
                    write(sval,sform,err=900)ival
                else
C                   create the formated character string
                    write(sval,sform,err=900)dval
                end if
 
C               write the character string to the FITS file
                call ftpcbf(ounit,twidth,sval,status)
        end if
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLB).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                      estart=0
                      rstart=rstart+1
                end if
                go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while writing FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error writing formatted data value to ASCII table
        write(messge,1002)colnum,rstart+1
1002    format('Error writing column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to write value with format '//sform)
        status=313
        end
        subroutine ftpclc(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of single precision complex data values to the
C       specified column of the table.
C       The binary table column being written to must have datatype 'C'
C       and no datatype conversion will be perform if it is not.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   cmp  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
C       the input array is really complex data type
        real array(*)
        integer felemx, nelemx
 
C       simply multiply the number of elements by 2, and call ftpcle
C       Technically, this is not strictly correct because the data scaling
C       (with TSCALn and TZEROn) is applied differently to complex numbers.
C       In practice, complex number will probably never be scaled so
C       this complication will be ignored.
 
        felemx = (felem - 1) * 2 + 1
        nelemx  = nelem * 2
        call ftpcle(ounit,colnum,frow,felemx,nelemx,array,status)
 
        end
        subroutine ftpcld(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of double precision data values to the specified column
C       of the table.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   d  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        double precision array(*)
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype,ival
        integer bstart,i1,ntodo,itodo,rstart
        double precision scale,zero,dval
        real rval
        logical tofits,lval,trans
        integer*2 i2val
        character sval*30,sform*13,snull*8,i1val*1,messge*80
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
 
        character*1 chbuff(32000)
        common/ftheap/chbuff
        double precision buffer(4000)
        common/fttemp/buffer
        integer compid
        common/ftcpid/compid
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(ounit,colnum,frow,felem,nelem,1,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,ival,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
        i1=1
        ntodo=nelem
        rstart=0
C       the data are being scaled from internal format to FITS:
        tofits=.true.
 
C       see if we can write the raw input bytes, or whether we have to
C       copy data to temporary array prior to byteswapping or scaling
        if ((compid .eq. 0 .or. compid .eq. -1) .and.
     &      abs(tcode) .eq. 82 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
                  trans=.false.
        else
                  trans=.true.
        end if
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,repeat-estart,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp + rstart*lenrow + estart*incre
        call ftmbyt(ounit,bstart,.true.,status)
 
C       copy data to buffer, doing scaling and datatype conversion, if required
        if (tcode .eq. 82)then
C           column data type is D (R*8)
            if (trans)then
C               convert the input data into a temporary buffer
                call ftr8r8(array(i1),itodo,scale,zero,tofits,
     &              ival,dval,lval,lval,buffer,status)
C               do any machine dependent conversion and write the R*8 data
                call ftpr8b(ounit,itodo,incre,buffer,status)
            else
C               directly write the input array
                call ftpr8b(ounit,itodo,incre,array(i1),status)
            end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
                call ftr8i2(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*2 data
                call ftpi2b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
                call ftr8i4(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*4 data
                call ftpi4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
                call ftr8r4(array(i1),itodo,scale,zero,tofits,
     &          ival,rval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*4 data
                call ftpr4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
                call ftr8i1(array(i1),itodo,scale,zero,tofits,
     &          ival,i1val,lval,lval,chbuff,status)
C               do any machine dependent data conversion and write the byte data
                call ftpi1b(ounit,itodo,incre,chbuff,status)
        else
C               this is an ASCII table column
                dval=(array(i1)-zero)/scale
 
                if (sform(5:5) .eq. 'I')then
C                 column data type is integer
C                 trap any values that overflow the I*4 range
                  if (dval .lt. i4max .and. dval .gt. i4min)then
                      ival=nint(dval)
                  else if (dval .ge. i4max)then
                      status=-11
                      ival=maxi4
                  else
                      status=-11
                      ival=mini4
                  end if
 
C                 create the formated character string
                  write(sval,sform,err=900)ival
                else
C                 create the formated character string
                  write(sval,sform,err=900)dval
                end if
 
C               write the character string to the FITS file
                call ftpcbf(ounit,twidth,sval,status)
        end if
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLD).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                      estart=0
                      rstart=rstart+1
                end if
                go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while writing FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error writing formatted data value to ASCII table
        write(messge,1002)colnum,rstart+1
1002    format('Error writing column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to write value with format '//sform)
        status=313
        end
        subroutine ftpcle(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of real data values to the specified column of
C       the table.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   r  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        real array(*)
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        real rval
        logical tofits,lval,trans
        integer*2 i2val
        character sval*30,sform*13,snull*8,i1val*1,messge*80
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
 
        character*1 chbuff(32000)
        common/ftheap/chbuff
        real buffer(8000)
        common/fttemp/buffer
        integer compid
        common/ftcpid/compid
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(ounit,colnum,frow,felem,nelem,1,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,ival,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
        i1=1
        ntodo=nelem
        rstart=0
C       the data are being scaled from internal format to FITS:
        tofits=.true.
 
C       see if we can write the raw input bytes, or whether we have to
C       copy data to temporary array prior to byteswapping or scaling
        if ((compid .eq. 0 .or. compid .eq. -1) .and.
     &      abs(tcode) .eq. 42 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
                  trans=.false.
        else
                  trans=.true.
        end if
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,repeat-estart,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp + rstart*lenrow + estart*incre
        call ftmbyt(ounit,bstart,.true.,status)
 
C       copy data to buffer, doing scaling and datatype conversion, if required
        if (tcode .eq. 42)then
C           column data type is E (R*4)
            if (trans)then
C               convert the input data into a temporary buffer
                call ftr4r4(array(i1),itodo,scale,zero,tofits,
     &              ival,rval,lval,lval,buffer,status)
C               do any machine dependent conversion and write the R*4 data
                call ftpr4b(ounit,itodo,incre,buffer,status)
            else
C               directly write the input array
                call ftpr4b(ounit,itodo,incre,array(i1),status)
            end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
                call ftr4i2(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*2 data
                call ftpi2b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
                call ftr4i4(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*4 data
                call ftpi4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
                call ftr4r8(array(i1),itodo,scale,zero,tofits,
     &          ival,dval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*8 data
                call ftpr8b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
                call ftr4i1(array(i1),itodo,scale,zero,tofits,
     &          ival,i1val,lval,lval,chbuff,status)
C               do any machine dependent data conversion and write the byte data
                call ftpi1b(ounit,itodo,incre,chbuff,status)
        else
C               this is an ASCII table column
                dval=(array(i1)-zero)/scale
 
                if (sform(5:5) .eq. 'I')then
C                 column data type is integer
C                 trap any values that overflow the I*4 range
                  if (dval .lt. i4max .and. dval .gt. i4min)then
                      ival=nint(dval)
                  else if (dval .ge. i4max)then
                      status=-11
                      ival=maxi4
                  else
                      status=-11
                      ival=mini4
                  end if
 
C                 create the formated character string
                  write(sval,sform,err=900)ival
                else
C                 create the formated character string
                  write(sval,sform,err=900)dval
                end if
 
C               write the character string to the FITS file
                call ftpcbf(ounit,twidth,sval,status)
        end if
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLE).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                      estart=0
                      rstart=rstart+1
                end if
                go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while writing FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error writing formatted data value to ASCII table
        write(messge,1002)colnum,rstart+1
1002    format('Error writing column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to write value with format '//sform)
        status=313
        end
        subroutine ftpcli(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of integer*2 data values to the specified column of
C       the table.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   i*2  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        integer*2 array(*)
 
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        real rval
        logical tofits,lval,trans
        integer*2 i2val
        character sval*30,sform*13,snull*8,i1val*1,messge*80
 
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer*2 buffer(16000)
        common/fttemp/buffer
        integer compid
        common/ftcpid/compid
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(ounit,colnum,frow,felem,nelem,1,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,ival,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
        i1=1
        ntodo=nelem
        rstart=0
C       the data are being scaled from internal format to FITS:
        tofits=.true.
 
C       see if we can write the raw input bytes, or whether we have to
C       copy data to temporary array prior to byteswapping or scaling
        if ((compid .eq. 0) .and.
     &      abs(tcode) .eq. 21 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
                  trans=.false.
        else
                  trans=.true.
        end if
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,repeat-estart,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp + rstart*lenrow + estart*incre
        call ftmbyt(ounit,bstart,.true.,status)
 
C       copy data to buffer, doing scaling and datatype conversion, if required
        if (tcode .eq. 21)then
C           column data type is I (I*2)
            if (trans)then
C               convert the input data into a temporary buffer
                call fti2i2(array(i1),itodo,scale,zero,tofits,
     &              ival,i2val,i2val,lval,lval,buffer,status)
C               do any machine dependent conversion and write the I*2 data
                call ftpi2b(ounit,itodo,incre,buffer,status)
            else
C               directly write the input array
                call ftpi2b(ounit,itodo,incre,array(i1),status)
            end if
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
                call fti2i4(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,ival,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*4 data
                call ftpi4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
                call fti2r4(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,rval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*4 data
                call ftpr4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
                call fti2r8(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,dval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*8 data
                call ftpr8b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
                call fti2i1(array(i1),itodo,scale,zero,tofits,
     &          ival,i2val,i1val,lval,lval,chbuff,status)
C               do any machine dependent data conversion and write the byte data
                call ftpi1b(ounit,itodo,incre,chbuff,status)
        else
C               this is an ASCII table column
                dval=(array(i1)-zero)/scale
 
                if (sform(5:5) .eq. 'I')then
C                 column data type is integer
C                 trap any values that overflow the I*4 range
                  if (dval .lt. i4max .and. dval .gt. i4min)then
                      ival=nint(dval)
                  else if (dval .ge. i4max)then
                      status=-11
                      ival=maxi4
                  else
                      status=-11
                      ival=mini4
                  end if
 
C                 create the formated character string
                  write(sval,sform,err=900)ival
                else
C                 create the formated character string
                  write(sval,sform,err=900)dval
                end if
 
C               write the character string to the FITS file
                call ftpcbf(ounit,twidth,sval,status)
        end if
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLI).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                      estart=0
                      rstart=rstart+1
                end if
                go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while writing FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error writing formatted data value to ASCII table
        write(messge,1002)colnum,rstart+1
1002    format('Error writing column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to write value with format '//sform)
        status=313
        end
        subroutine ftpclj(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of integer data values to the specified column of
C       the table.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   i  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        integer array(*)
        integer ibuff,twidth,tcode,maxpix,startp
        integer estart,incre,repeat,lenrow,hdtype
        integer bstart,i1,ntodo,itodo,rstart,ival
        double precision scale,zero,dval
        real rval
        logical tofits,lval,trans
        integer*2 i2val
        character sval*30,sform*13,snull*8,i1val*1,messge*80
        double precision i4max,i4min
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
 
        character*1 chbuff(32000)
        common/ftheap/chbuff
        integer buffer(8000)
        common/fttemp/buffer
        integer compid
        common/ftcpid/compid
 
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        call ftgcpr(ounit,colnum,frow,felem,nelem,1,
     &   ibuff,scale,zero,sform,twidth,tcode,maxpix,startp,
     &   estart,incre,repeat,lenrow,hdtype,ival,snull,status)
 
        if (status .gt. 0 .or. nelem .eq. 0)return
 
        i1=1
        ntodo=nelem
        rstart=0
C       the data are being scaled from internal format to FITS:
        tofits=.true.
 
C       see if we can write the raw input bytes, or whether we have to
C       copy data to temporary array prior to byteswapping or scaling
        if ((compid .eq. 0 .or. compid .eq. -1) .and.
     &      abs(tcode) .eq. 41 .and.
     &      scale .eq. 1.D00 .and. zero .eq. 0.D00)then
                  trans=.false.
        else
                  trans=.true.
        end if
 
C       process as many contiguous pixels as possible, up to buffer size
20      itodo=min(ntodo,repeat-estart,maxpix)
 
C       move the i/o pointer to the start of the sequence of pixels
        bstart=startp + rstart*lenrow + estart*incre
        call ftmbyt(ounit,bstart,.true.,status)
 
C       copy data to buffer, doing scaling and datatype conversion, if required
        if (tcode .eq. 41)then
C           column data type is J (I*4)
            if (trans)then
C               convert the input data into a temporary buffer
                call fti4i4(array(i1),itodo,scale,zero,tofits,
     &              ival,ival,ival,lval,lval,buffer,status)
C               do any machine dependent conversion and write the I*4 data
                call ftpi4b(ounit,itodo,incre,buffer,status)
            else
C               directly write the input array
                call ftpi4b(ounit,itodo,incre,array(i1),status)
            end if
        else if (tcode .eq. 21)then
C               column data type is I (I*2)
                call fti4i2(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,i2val,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the I*2 data
                call ftpi2b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
                call fti4r4(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,rval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*4 data
                call ftpr4b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 82)then
C               column data type is D (R*8)
                call fti4r8(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,dval,lval,lval,buffer,status)
C               do any machine dependent data conversion and write the R*8 data
                call ftpr8b(ounit,itodo,incre,buffer,status)
        else if (tcode .eq. 11)then
C               column data type is B (byte)
                call fti4i1(array(i1),itodo,scale,zero,tofits,
     &          ival,ival,i1val,lval,lval,chbuff,status)
C               do any machine dependent data conversion and write the byte data
                call ftpi1b(ounit,itodo,incre,chbuff,status)
        else
C               this is an ASCII table column
                dval=(array(i1)-zero)/scale
 
                if (sform(5:5) .eq. 'I')then
C                 column data type is integer
C                 trap any values that overflow the I*4 range
                  if (dval .lt. i4max .and. dval .gt. i4min)then
                      ival=nint(dval)
                  else if (dval .ge. i4max)then
                      status=-11
                      ival=maxi4
                  else
                      status=-11
                      ival=mini4
                  end if
 
C                 create the formated character string
                  write(sval,sform,err=900)ival
                else
C                 create the formated character string
                  write(sval,sform,err=900)dval
                end if
 
C               write the character string to the FITS file
                call ftpcbf(ounit,twidth,sval,status)
        end if
 
        if (status .gt. 0)then
            write(messge,1001)i1,i1+itodo-1
1001        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLJ).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+itodo
                estart=estart+itodo
                if (estart .eq. repeat)then
                      estart=0
                      rstart=rstart+1
                end if
                go to 20
        end if
 
C       check for any overflows
        if (status .eq. -11)then
           status=412
           messge='Numerical overflow during type '//
     &            'conversion while writing FITS data.'
           call ftpmsg(messge)
        end if
        return
 
900     continue
C       error writing formatted data value to ASCII table
        write(messge,1002)colnum,rstart+1
1002    format('Error writing column',i4,', row',i9,
     &  ' of the ASCII Table.')
        call ftpmsg(messge)
        call ftpmsg('Tried to write value with format '//sform)
        status=313
        end
        subroutine ftpcll(ounit,colnum,frow,felem,nelem,lray,status)
 
C       write an array of logical values to the  specified column of the table.
C       The binary table column being written to must have datatype 'L'
C       and no datatype conversion will be perform if it is not.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       lray    l  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        logical lray(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*1 buffer(32000)
        common/ftheap/buffer
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,maxpix,i
        parameter (maxpix = 32000)
        character messge*80
        integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,tcode
        logical descrp
 
        if (status .gt. 0)return
 
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (nelem .eq. 0)then
C         just return if zero rows to write
          return
        end if
 
        ibuff=bufnum(ounit)
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
        if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        end if
 
        i1=1
        ntodo=nelem
        rstart=frow-1
        estart=felem-1
 
C       column must be logical data type
        tcode=tdtype(colnum+tstart(ibuff))
        if (tcode .eq. 14)then
                descrp=.false.
                repeat=trept(colnum+tstart(ibuff))
                if (felem .gt. repeat)then
C                  illegal element number
                   write(messge,1005)felem
1005               format(
     &       'Starting element number is greater than repeat: ',i10)
                   call ftpmsg(messge)
                   status = 308
                   return
                end if
        else if (tcode .eq. -14)then
                descrp=.true.
                repeat=nelem+estart
C               write the number of elements and the starting offset:
                call ftpdes(ounit,colnum,frow,repeat,
     &                              heapsz(ibuff),status)
C               move the i/o pointer to the start of the pixel sequence
                bstart=dtstrt(ibuff)+heapsz(ibuff)+
     &                          theap(ibuff)+estart
                call ftmbyt(ounit,bstart,.true.,status)
C               increment the empty heap starting address:
                heapsz(ibuff)=heapsz(ibuff)+repeat
        else
C               error illegal data type code
                status=310
                return
        end if
 
C       process as many contiguous pixels as possible
20      itodo=min(ntodo,repeat-estart,maxpix)
 
        if (.not. descrp)then
C           move the i/o pointer to the start of the sequence of pixels
            bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &      tbcol(colnum+tstart(ibuff))+estart
            call ftmbyt(ounit,bstart,.true.,status)
        end if
 
C       create the buffer of logical bytes
        do 10 i=1,itodo
                if (lray(i1))then
                        buffer(i)='T'
                else
                        buffer(i)='F'
                end if
                i1=i1+1
10      continue
 
C       write out the buffer
        call ftpcbf(ounit,itodo,buffer,status)
 
        if (status .gt. 0)then
            write(messge,1006)i1,i1+itodo-1
1006        format('Error writing elements',i9,' thru',i9,
     &         ' of input data array (FTPCLL).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                estart=estart+itodo
                if (estart .eq. repeat)then
                        estart=0
                        rstart=rstart+1
                end if
                go to 20
        end if
        end
        subroutine ftpclm(ounit,colnum,frow,felem,nelem,array,status)
 
C       write an array of double precision complex data values to the
C       specified column of the table.
C       The binary table column being written to must have datatype 'M'
C       and no datatype conversion will be perform if it is not.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   dcmp  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
C       array is really double precison complex
        double precision array(*)
        integer felemx, nelemx
 
C       simply multiply the number of elements by 2, and call ftpcld
C       Technically, this is not strictly correct because the data scaling
C       (with TSCALn and TZEROn) is applied differently to complex numbers.
C       In practice, complex number will probably never be scaled so
C       this complication will be ignored.
 
        felemx = (felem - 1) * 2 + 1
        nelemx  = nelem * 2
        call ftpcld(ounit,colnum,frow,felemx,nelemx,array,status)
 
        end
        subroutine ftpcls(ounit,colnum,frow,felem,nelem,sray,status)
 
C       write an array of character string values to the  specified column of
C       the table.
C       The binary or ASCII table column being written to must have datatype 'A'
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       sray    c  array of data values to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
        character*(*) sray(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,strlen,c1,c2,repeat,twidth
        integer ibuff,i1,ntodo,rstart,estart,nchars,clen,tcode
        character sbuff*80,blank*80,messge*80
        logical small,fill
 
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
 
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (nelem .eq. 0)then
C         just return if zero rows to write
          return
        end if
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
        if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        end if
 
        blank=' '
        i1=1
 
C       column must be character string data type
        tcode=tdtype(colnum+tstart(ibuff))
        if (tcode .eq. 16)then
C               for ASCII columns, TNULL actually stores the field width
                twidth=tnull(colnum+tstart(ibuff))
                ntodo=nelem
                rstart=frow-1
                repeat=trept(colnum+tstart(ibuff))
                estart=felem-1
                if (estart .ge. repeat)then
C                  illegal element number
                   write(messge,1005)felem
1005               format(
     &       'Starting element number is greater than repeat: ',i10)
                   call ftpmsg(messge)
                   status = 308
                   return
                end if
                bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
     &                 +tbcol(colnum+tstart(ibuff))+estart*twidth
        else if (tcode .eq. -16)then
C               this is a variable length descriptor field
C               the length of the output string is defined by nelem
                twidth=nelem
                ntodo=1
                repeat=1
C               write the number of string length and the starting offset:
                call ftpdes(ounit,colnum,frow,twidth,
     &                              heapsz(ibuff),status)
C               calc the i/o pointer position for the start of the string
                bstart=dtstrt(ibuff)+heapsz(ibuff)+theap(ibuff)
C               increment the empty heap starting address:
                heapsz(ibuff)=heapsz(ibuff)+twidth
        else
C               error: not a character string column
                status=309
                return
        end if
 
C       move the i/o pointer to the start of the sequence of pixels
        call ftmbyt(ounit,bstart,.true.,status)
 
C       is the input string short enough to completely fit in buffer?
        strlen=len(sray(1))
        if (strlen .gt. 80 .and. twidth .gt. 80)then
                small=.false.
        else
                small=.true.
        end if
 
C       do we need to pad the FITS string field with trailing blanks?
        if (twidth .gt. strlen)then
                fill=.true.
        else
                fill=.false.
        end if
 
C       process one string at a time
20      continue
        nchars=min(strlen,twidth)
        if (small)then
C               the whole input string fits in the temporary buffer
                sbuff=sray(i1)
C               output the string
                call ftpcbf(ounit,nchars,sbuff,status)
        else
C               have to write the string in several pieces
                c1=1
                c2=80
30              sbuff=sray(i1)(c1:c2)
C               output the string
                clen=c2-c1+1
                call ftpcbf(ounit,clen,sbuff,status)
                nchars=nchars-clen
                if (nchars .gt. 0)then
                        c1=c1+80
                        c2=min(c2+80,c1+nchars-1)
                        go to 30
                end if
        end if
 
C       pad any remaining space in the column with blanks
        if (fill)then
                nchars=twidth-strlen
40              clen=min(nchars,80)
                call ftpcbf(ounit,clen,blank,status)
                nchars=nchars-80
                if (nchars .gt. 0)go to 40
        end if
 
        if (status .gt. 0)then
            write(messge,1006)i1
1006        format('Error writing element',i9,
     &         ' of input string array (FTPCLS).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-1
        if (ntodo .gt. 0)then
C               increment the pointers
                i1=i1+1
                estart=estart+1
                if (estart .eq. repeat)then
                        estart=0
                        rstart=rstart+1
                        bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &                  tbcol(colnum+tstart(ibuff))
C                       move the i/o pointer
                        call ftmbyt(ounit,bstart,.true.,status)
                end if
                go to 20
        end if
        end
        subroutine ftpclu(ounit,colnum,frow,felem,nelem,status)
 
C       set elements of a table to be undefined
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,frow,felem,nelem,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
        character snull*500
        character*1 xdummy(31500)
        common/ftheap/snull,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bytpix,bstart,i4null(2),tcode,nchars,i,offset,nulval
        integer ibuff,ntodo,itodo,repeat,rstart,estart
        integer*2 i2null,i1
        integer rnull(2)
        logical descrp
        character*1 i1null
        character messge*80
 
        if (status .gt. 0)return
 
        if (frow .lt. 1)then
          write(messge,1001)frow
1001      format('Starting row number is out of range: ',i10)
          call ftpmsg(messge)
          status = 307
          return
        else if (felem .lt. 1)then
          write(messge,1002)felem
1002      format('Starting element number is out of range: ',i10)
          call ftpmsg(messge)
          status = 308
          return
        else if (nelem .lt. 0)then
          write(messge,1003)nelem
1003      format('Negative no. of elements to read or write: ',i10)
          call ftpmsg(messge)
          status = 306
          return
        else if (nelem .eq. 0)then
          return
        end if
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
        if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then
          write(messge,1004)colnum
1004      format('Specified column number is out of range: ',i10)
          call ftpmsg(messge)
          status = 302
          return
        end if
 
        tcode=tdtype(colnum+tstart(ibuff))
        bytpix=max(abs(tcode)/10,1)
 
        descrp=.false.
        ntodo=nelem
        rstart=frow-1
        estart=felem-1
        i1=1
 
        if (tcode .eq. 16)then
C               this is an ASCII field
                repeat=trept(colnum+tstart(ibuff))
                if (felem .gt. repeat)then
C                  illegal element number
                   write(messge,1005)felem
1005               format(
     &       'Starting element number is greater than repeat: ',i10)
                   call ftpmsg(messge)
                   status = 308
                   return
                end if
                if (cnull(colnum+tstart(ibuff))(1:1) .eq. char(1))then
C                       error: null value has not been defined
                        status=314
                call ftpmsg('Null value string for ASCII table'//
     &          ' column has not yet been defined (FTPCLU).')
                        return
                end if
C               the TNULL parameter stores the width of the character field
                bytpix=tnull(colnum+tstart(ibuff))
        else
C               this is a binary table
                nulval=tnull(colnum+tstart(ibuff))
 
                if (tcode .gt. 0)then
                        if (hdutyp(ibuff) .eq. 0)then
C                           if this is a primary array or image extension, then
C                           set repeat as large as needed to write all
C                           the pixels.  This prevents an error message if
C                           array size is not yet known.  The actual array
C                           dimension must be defined by the NAXISn keywords
C                           before closing this HDU.
                            repeat=estart+nelem
                        else
                            repeat=trept(colnum+tstart(ibuff))
                        end if
 
                        if (felem .gt. repeat)then
C                           illegal element number
                            write(messge,1004)felem
                            call ftpmsg(messge)
                            status = 308
                            return
                        end if
 
 
                else
C                       this is a variable length descriptor column
                        descrp=.true.
                        tcode=-tcode
C                       read the number of elements and the starting offset:
                        call ftgdes(ounit,colnum,frow,repeat,
     &                              offset,status)
                        if (ntodo+estart .gt. repeat)then
C                               error:  tried to write past end of record
                                status=319
                                return
                        end if
 
C                       move the i/o pointer to the start of the pixel sequence
                        bstart=dtstrt(ibuff)+offset+
     &                          theap(ibuff)+estart*bytpix
                        call ftmbyt(ounit,bstart,.true.,status)
                end if
 
                if (tcode.eq.11 .or. tcode.eq.21 .or. tcode.eq.41)then
                        if (nulval .eq. 123454321)then
C                               error: null value has not been defined
                                status=314
                call ftpmsg('Null value for integer'//
     &          ' column has not yet been defined (FTPCLU).')
                                return
                        end if
                else
C                       set the floating point Not-a-Number values
                        do 10 i=1,2
                          rnull(i) = -1
10                      continue
                end if
 
        end if
 
C       process as many contiguous pixels as possible
20      itodo=min(ntodo,repeat-estart)
 
        if (.not. descrp)then
C           move the i/o pointer to the start of the sequence of pixels
            bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)
     &             +tbcol(colnum+tstart(ibuff))+estart*bytpix
            call ftmbyt(ounit,bstart,.true.,status)
        end if
 
C       write the appropriate null value to the pixels
        if (tcode .eq. 21)then
C               column data type is I (I*2)
                do 5 i=1,itodo
                        i2null=nulval
                        call ftpi2b(ounit,1,0,i2null,status)
5               continue
        else if (tcode .eq. 41)then
C               column data type is J (I*4)
                do 15 i=1,itodo
                        i4null(1)=nulval
                        call ftpi4b(ounit,1,0,i4null,status)
15              continue
        else if (tcode .eq. 42)then
C               column data type is E (R*4)
                do 25 i=1,itodo
                        call ftpbyt(ounit,4,rnull,status)
25              continue
        else if (tcode .eq. 82 .or. tcode .eq. 83)then
C               column data type is D (R*8), or C complex 2 x R*4
                do 35 i=1,itodo
                        call ftpbyt(ounit,8,rnull,status)
35              continue
        else if (tcode .eq. 16)then
C               this is an ASCII table column
                snull=cnull(colnum+tstart(ibuff))
C               write up to 500 characters in the column, remainder unchanged
C               (500 is the maximum size string allowed in IBM AIX compiler)
                nchars=min(bytpix,500)
                do 45 i=1,itodo
                        call ftpcbf(ounit,nchars,snull,status)
45              continue
        else if (tcode .eq. 11)then
C               column data type is B (byte)
                i1null=char(nulval)
                do 55 i=1,itodo
                        call ftpcbf(ounit,1,i1null,status)
55              continue
        else if (tcode .eq. 163)then
C               column data type is double complex (M)
                do 65 i=1,itodo*2
                        call ftpbyt(ounit,8,rnull,status)
65              continue
        else if (tcode .eq. 14)then
C               column data type is logical (L)
                i4null(1)=0
                do 85 i=1,itodo
                        call ftpbyt(ounit,1,i4null,status)
85              continue
        end if
 
 
        if (status .gt. 0)then
            write(messge,1006)i1,i1+itodo-1
1006        format('Error writing NULL elements',i9,' thru',i9,
     &         ' (FTPCLU).')
            call ftpmsg(messge)
            return
        end if
 
C       find number of pixels left to do, and quit if none left
        ntodo=ntodo-itodo
        i1 = i1 + itodo
        if (ntodo .gt. 0)then
C               increment the pointers
                estart=estart+itodo
                if (estart .eq. repeat)then
                        estart=0
                        rstart=rstart+1
                end if
                go to 20
        end if
        end
        subroutine ftpclx(iunit,colnum,frow,fbit,nbit,lray,status)
 
C       write an array of logical values to a specified bit or byte
C       column of the binary table.   If the LRAY parameter is .true.,
C       then the corresponding bit is set to 1, otherwise it is set
C       to 0.
C       The binary table column being written to must have datatype 'B'
C       or 'X'.
 
C       iunit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       fbit    i  first bit within the row to write
C       nbit    i  number of bits to write
C       lray    l  array of logical data values corresponding to the bits
C                        to be written
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Mar 1992
C       modified by Wm Pence May 1992 to remove call to system dependent
C                                     bit testing and setting routines.
 
        integer iunit,colnum,frow,fbit,nbit,status
        logical lray(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer bstart,offset,tcode,fbyte,bitloc,ndone,tstat
        integer ibuff,i,ntodo,repeat,rstart,estart,buffer
        logical descrp,wrbit(8),setbit(8)
        character*1 cbuff
        character crow*9
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
        tcode=tdtype(colnum+tstart(ibuff))
 
C       check input parameters
        if (nbit .le. 0)then
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                write(crow,2000)frow
2000            format(i9)
                call ftpmsg('Starting row number for table write '//
     &          'request is out of range:'//crow//' (FTPCLX).')
                return
        else if (fbit .lt. 1)then
C               illegal element number
                status=308
                write(crow,2000)fbit
                call ftpmsg('Starting element number for write '//
     &          'request is out of range:'//crow//' (FTPCLX).')
                return
        end if
 
        fbyte=(fbit+7)/8
        bitloc=fbit-(fbit-1)/8*8
        ndone=0
        ntodo=nbit
        rstart=frow-1
        estart=fbyte-1
 
        if (tcode .eq. 11)then
                descrp=.false.
C               N.B: REPEAT is the number of bytes, not number of bits
                repeat=trept(colnum+tstart(ibuff))
                if (fbyte .gt. repeat)then
C                               illegal element number
                                status=308
                                write(crow,2000)fbit
                    call ftpmsg('Starting element number for write '//
     &              'request is out of range:'//crow//' (FTPCLX).')
                                return
                end if
C               calc the i/o pointer location to start of sequence of pixels
                bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &          tbcol(colnum+tstart(ibuff))+estart
        else if (tcode .eq. -11)then
C               this is a variable length descriptor column
                descrp=.true.
C               only bit arrays (tform = 'X') are supported for variable
C               length arrays.  REPEAT is the number of BITS in the array.
                repeat=fbit+nbit-1
                offset=heapsz(ibuff)
C               write the number of elements and the starting offset:
                call ftpdes(iunit,colnum,frow,repeat,
     &                              offset,status)
C               calc the i/o pointer location to start of sequence of pixels
                bstart=dtstrt(ibuff)+offset+
     &                          theap(ibuff)+estart
C               increment the empty heap starting address (in bytes):
                repeat=(repeat+7)/8
                heapsz(ibuff)=heapsz(ibuff)+repeat
        else
C               column must be byte or bit data type
                status=310
                return
        end if
 
C       move the i/o pointer to the start of the pixel sequence
        call ftmbyt(iunit,bstart,.true.,status)
        tstat=0
 
C       read the next byte (we may only be modifying some of the bits)
20      call ftgcbf(iunit,1,cbuff,status)
        if (status .eq. 107)then
C            hit end of file trying to read the byte, so just set byte = 0
             status=tstat
             cbuff=char(0)
        end if
 
        buffer=ichar(cbuff)
        if (buffer .lt. 0)buffer=buffer+256
C       move back, to be able to overwrite the byte
        call ftmbyt(iunit,bstart,.true.,status)
 
C       reset flags indicating which bits are to be set
        wrbit(1)=.false.
        wrbit(2)=.false.
        wrbit(3)=.false.
        wrbit(4)=.false.
        wrbit(5)=.false.
        wrbit(6)=.false.
        wrbit(7)=.false.
        wrbit(8)=.false.
 
C       flag the bits that are to be set
        do 10 i=bitloc,8
                wrbit(i)=.true.
                ndone=ndone+1
                if(lray(ndone))then
                        setbit(i)=.true.
                else
                        setbit(i)=.false.
                end if
                if (ndone .eq. ntodo)go to 100
10      continue
 
C       set or reset the bits within the byte
        call ftpbit(setbit,wrbit,buffer)
 
C       write the new byte
        cbuff=char(buffer)
        call ftpcbf(iunit,1,cbuff,status)
 
C       not done, so get the next byte
        bstart=bstart+1
        if (.not. descrp)then
                estart=estart+1
                if (estart .eq. repeat)then
C                       move the i/o pointer to the next row of pixels
                        estart=0
                        rstart=rstart+1
                        bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+
     &                         tbcol(colnum+tstart(ibuff))+estart
                        call ftmbyt(iunit,bstart,.true.,status)
                end if
        end if
        bitloc=1
        go to 20
 
100     continue
C       set or reset the bits within the byte
        call ftpbit(setbit,wrbit,buffer)
 
C       write the new byte
        cbuff=char(buffer)
        call ftpcbf(iunit,1,cbuff,status)
        end
        subroutine ftpcnb(ounit,colnum,frow,felem,nelem,array,nulval,
     &                    status)
 
C       write array of character*1 (byte) pixels to the specified column
C       of a table.  Any input pixels equal to the value of NULVAL will
C       be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   c*1  array of data values to be written
C       nulval  c*1  pixel value used to represent an undefine pixel
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,colnum,frow,felem,nelem,status
        character*1 array(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
C       get the column repeat count and calculate the absolute position within
C       the column of the first element to be written
        repeat=trept(colnum+tstart(ibuff))
        first=(frow-1)*repeat+felem-1
 
        ngood=0
        nbad=0
        do 10 i=1,nelem
            if (array(i) .ne. nulval)then
                ngood=ngood+1
                if (nbad .gt. 0)then
C                   write the previous consecutive set of null pixels
                    fstelm=i-nbad+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
                    nbad=0
                end if
            else
                nbad=nbad+1
                if (ngood .gt. 0)then
C                   write the previous consecutive set of good pixels
                    fstelm=i-ngood+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclb(ounit,colnum,fstrow,fstelm,ngood,
     &                          array(i-ngood),status)
                    ngood=0
                end if
            end if
10      continue
 
C       finished;  now just write the last set of pixels
        if (nbad .gt. 0)then
C           write the consecutive set of null pixels
            fstelm=i-nbad+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
        else
C           write the consecutive set of good pixels
            fstelm=i-ngood+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclb(ounit,colnum,fstrow,fstelm,ngood,
     &                  array(i-ngood),status)
        end if
        end
        subroutine ftpcnd(ounit,colnum,frow,felem,nelem,array,nulval,
     &                    status)
 
C       write array of double precision pixels to the specified column
C       of a table.  Any input pixels equal to the value of NULVAL will
C       be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   d  array of data values to be written
C       nulval  d  pixel value used to represent an undefine pixel
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,colnum,frow,felem,nelem,status
        double precision array(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
C       get the column repeat count and calculate the absolute position within
C       the column of the first element to be written
        repeat=trept(colnum+tstart(ibuff))
        first=(frow-1)*repeat+felem-1
 
        ngood=0
        nbad=0
        do 10 i=1,nelem
            if (array(i) .ne. nulval)then
                ngood=ngood+1
                if (nbad .gt. 0)then
C                   write the previous consecutive set of null pixels
                    fstelm=i-nbad+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
                    nbad=0
                end if
            else
                nbad=nbad+1
                if (ngood .gt. 0)then
C                   write the previous consecutive set of good pixels
                    fstelm=i-ngood+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpcld(ounit,colnum,fstrow,fstelm,ngood,
     &                          array(i-ngood),status)
                    ngood=0
                end if
            end if
10      continue
 
C       finished;  now just write the last set of pixels
        if (nbad .gt. 0)then
C           write the consecutive set of null pixels
            fstelm=i-nbad+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
        else
C           write the consecutive set of good pixels
            fstelm=i-ngood+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpcld(ounit,colnum,fstrow,fstelm,ngood,
     &                  array(i-ngood),status)
        end if
        end
        subroutine ftpcne(ounit,colnum,frow,felem,nelem,array,nulval,
     &                    status)
 
C       write array of floating point pixels to the specified column
C       of a table.  Any input pixels equal to the value of NULVAL will
C       be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   r  array of data values to be written
C       nulval  r  pixel value used to represent an undefine pixel
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,colnum,frow,felem,nelem,status
        real array(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
C       get the column repeat count and calculate the absolute position within
C       the column of the first element to be written
        repeat=trept(colnum+tstart(ibuff))
        first=(frow-1)*repeat+felem-1
 
        ngood=0
        nbad=0
        do 10 i=1,nelem
            if (array(i) .ne. nulval)then
                ngood=ngood+1
                if (nbad .gt. 0)then
C                   write the previous consecutive set of null pixels
                    fstelm=i-nbad+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
                    nbad=0
                end if
            else
                nbad=nbad+1
                if (ngood .gt. 0)then
C                   write the previous consecutive set of good pixels
                    fstelm=i-ngood+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpcle(ounit,colnum,fstrow,fstelm,ngood,
     &                          array(i-ngood),status)
                    ngood=0
                end if
            end if
10      continue
 
C       finished;  now just write the last set of pixels
        if (nbad .gt. 0)then
C           write the consecutive set of null pixels
            fstelm=i-nbad+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
        else
C           write the consecutive set of good pixels
            fstelm=i-ngood+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpcle(ounit,colnum,fstrow,fstelm,ngood,
     &                  array(i-ngood),status)
        end if
        end
        subroutine ftpcni(ounit,colnum,frow,felem,nelem,array,nulval,
     &                    status)
 
C       write array of integer*2 pixels to the specified column
C       of a table.  Any input pixels equal to the value of NULVAL will
C       be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   i*2  array of data values to be written
C       nulval  i*2  pixel value used to represent an undefine pixel
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,colnum,frow,felem,nelem,status
        integer*2 array(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
C       get the column repeat count and calculate the absolute position within
C       the column of the first element to be written
        repeat=trept(colnum+tstart(ibuff))
        first=(frow-1)*repeat+felem-1
 
        ngood=0
        nbad=0
        do 10 i=1,nelem
            if (array(i) .ne. nulval)then
                ngood=ngood+1
                if (nbad .gt. 0)then
C                   write the previous consecutive set of null pixels
                    fstelm=i-nbad+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
                    nbad=0
                end if
            else
                nbad=nbad+1
                if (ngood .gt. 0)then
C                   write the previous consecutive set of good pixels
                    fstelm=i-ngood+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpcli(ounit,colnum,fstrow,fstelm,ngood,
     &                          array(i-ngood),status)
                    ngood=0
                end if
            end if
10      continue
 
C       finished;  now just write the last set of pixels
        if (nbad .gt. 0)then
C           write the consecutive set of null pixels
            fstelm=i-nbad+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
        else
C           write the consecutive set of good pixels
            fstelm=i-ngood+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpcli(ounit,colnum,fstrow,fstelm,ngood,
     &                  array(i-ngood),status)
        end if
        end
        subroutine ftpcnj(ounit,colnum,frow,felem,nelem,array,nulval,
     &                    status)
 
C       write array of integer pixels to the specified column
C       of a table.  Any input pixels equal to the value of NULVAL will
C       be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       frow    i  first row to write
C       felem   i  first element within the row to write
C       nelem   i  number of elements to write
C       array   i  array of data values to be written
C       nulval  i  pixel value used to represent an undefine pixel
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,colnum,frow,felem,nelem,status
        integer array(*),nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
 
C       get the column repeat count and calculate the absolute position within
C       the column of the first element to be written
        repeat=trept(colnum+tstart(ibuff))
        first=(frow-1)*repeat+felem-1
 
        ngood=0
        nbad=0
        do 10 i=1,nelem
            if (array(i) .ne. nulval)then
                ngood=ngood+1
                if (nbad .gt. 0)then
C                   write the previous consecutive set of null pixels
                    fstelm=i-nbad+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
                    nbad=0
                end if
            else
                nbad=nbad+1
                if (ngood .gt. 0)then
C                   write the previous consecutive set of good pixels
                    fstelm=i-ngood+first
C                   calculate the row and element of the first pixel to write
                    fstrow=(fstelm-1)/repeat+1
                    fstelm=fstelm-(fstrow-1)*repeat
                    call ftpclj(ounit,colnum,fstrow,fstelm,ngood,
     &                          array(i-ngood),status)
                    ngood=0
                end if
            end if
10      continue
 
C       finished;  now just write the last set of pixels
        if (nbad .gt. 0)then
C           write the consecutive set of null pixels
            fstelm=i-nbad+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status)
        else
C           write the consecutive set of good pixels
            fstelm=i-ngood+first
            fstrow=(fstelm-1)/repeat+1
            fstelm=fstelm-(fstrow-1)*repeat
            call ftpclj(ounit,colnum,fstrow,fstelm,ngood,
     &                  array(i-ngood),status)
        end if
        end
        subroutine ftpcom(ounit,commnt,status)
 
C       write a COMMENT record to the FITS header
C
C       ounit   i  fortran output unit number
C       commnt c  input comment string
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,status,strlen,actlen,i,nkeys,c1,c2
        character*(*) commnt
        character*80  rec
 
        if (status .gt. 0)return
 
C       find the length of the string, and write it out 70 characters at a time
        nkeys=1
        strlen=len(commnt)
        actlen=strlen
        do 10 i=strlen,1,-1
                if (commnt(i:i) .ne. ' ')then
                        actlen=i
                        go to 20
                end if
10      continue
 
20      c1=1
        c2=min(actlen,70)
        nkeys=(actlen-1)/70+1
        do 30 i=1,nkeys
                rec='COMMENT   '//commnt(c1:c2)
                call ftprec(ounit,rec,status)
                c1=c1+70
                c2=min(actlen,c2+70)
30      continue
        end
        subroutine ftpdat(ounit,status)
 
C       write the current date to the DATE keyword in the ounit CHU
C
C       ounit   i  fortran output unit number
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Jan 1992
 
        integer ounit,status,dd,mm,yy
        character datstr*8
 
C       call the system dependent routine to get the current date
        call ftgsdt(dd,mm,yy,status)
        if (status .gt. 0)return
 
        datstr='  /  /  '
        write(datstr(1:2),1001)dd
        write(datstr(4:5),1001)mm
        write(datstr(7:8),1001)yy
1001    format(i2)
 
C       replace blank with leading 0 in each field if required
        if (datstr(1:1) .eq. ' ')datstr(1:1)='0'
        if (datstr(4:4) .eq. ' ')datstr(4:4)='0'
        if (datstr(7:7) .eq. ' ')datstr(7:7)='0'
 
C       update the DATE keyword
        call ftukys(ounit,'DATE',datstr,
     &             'FITS file creation date (dd/mm/yy)',status)
        end
        subroutine ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount,
     &                    status)
 
C       Primary data DEFinition
C       define the structure of the primary data unit or an IMAGE extension
C
C       ounit   i  Fortran I/O unit number
C       bitpix  i  bits per pixel value
C       naxis   i  number of data axes
C       naxes   i  length of each data axis (array)
C       pcount  i  number of group parameters
C       gcount  i  number of 'random groups'
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,ttype,bytlen,npix,i,pcnt,gcnt
        character caxis*20
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
        if (dtstrt(ibuff) .lt. 0)then
C               freeze the header at its current size
                call fthdef(ounit,0,status)
                if (status .gt. 0)return
        end if
 
C       check for error conditions
        if (naxis .lt. 0)then
                status=212
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPDEF '
     &          //'is illegal.')
 
        else if (pcount .lt. 0)then
                status=214
        else if (gcount .lt. 0)then
                status=215
        else
                go to 5
        end if
        return
 
C       test that bitpix has a legal value and set the datatype code value
5       if (bitpix .eq. 8)then
                ttype=11
                bytlen=1
        else if (bitpix .eq. 16)then
                ttype=21
                bytlen=2
        else if (bitpix .eq. 32)then
                ttype=41
                bytlen=4
        else if (bitpix .eq. -32)then
                ttype=42
                bytlen=4
        else if (bitpix .eq. -64)then
                ttype=82
                bytlen=8
        else
C               illegal value of bitpix
                status=211
                return
        end if
 
C       calculate the number of pixels in the array
        if (naxis .eq. 0)then
C               no data
                npix=0
                gcnt=0
                pcnt=0
        else
C               make sure that the gcount is not zero
                gcnt=max(gcount,1)
                pcnt=pcount
                npix=1
                do 10 i=1,naxis
                        if (naxes(i) .ge. 0)then
C       The convention used by 'random groups' with NAXIS1 = 0 is not
C       directly supported here.  If one wants to write a 'random group'
C       FITS file, then one should call FTPDEF with naxes(1) = 1, but
C       then write the required header keywords (with FTPHPR) with
C       naxes(1) = 0.
                                npix=npix*naxes(i)
                        else if (naxes(i) .lt. 0)then
                                status=213
                                return
                        end if
10              continue
        end if
C       the next HDU begins in the next logical block after the data
        hdstrt(ibuff,chdu(ibuff)+1)=
     &          dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880
 
C       the primary array is actually interpreted as a binary table.  There
C       are two columns: the first column contains the
C       group parameters, if any, and the second column contains the
C       primary array of data.  Each group is a separate row in the table.
C       The scaling and null values are set to the default values.
 
        hdutyp(ibuff)=0
        tfield(ibuff)=2
 
        if (nxtfld + 2 .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
        else
                tstart(ibuff)=nxtfld
                nxtfld=nxtfld+2
                tdtype(1+tstart(ibuff))=ttype
                tdtype(2+tstart(ibuff))=ttype
                trept(1+tstart(ibuff))=pcnt
                trept(2+tstart(ibuff))=npix
C               choose a special value to represent the absence of a blank value
                tnull(1+tstart(ibuff))=123454321
                tnull(2+tstart(ibuff))=123454321
                tscale(1+tstart(ibuff))=1.
                tscale(2+tstart(ibuff))=1.
                tzero(1+tstart(ibuff))=0.
                tzero(2+tstart(ibuff))=0.
                tbcol(1+tstart(ibuff))=0
                tbcol(2+tstart(ibuff))=pcnt*bytlen
                rowlen(ibuff)=(pcnt+npix)*bytlen
        end if
 
C       initialize the fictitious heap starting address (immediately following
C       the array data) and a zero length heap.  This is used to find the
C       end of the data when checking the fill values in the last block.
        heapsz(ibuff)=0
        theap(ibuff)=(pcnt+npix)*bytlen*gcnt
        end
        subroutine ftpdes(ounit,colnum,rownum,nelem,offset,status)
 
C       write the descriptor values to a binary table.  This is only
C       used for column which have TFORMn = 'P', i.e., for variable
C       length arrays.
 
C       ounit   i  fortran unit number
C       colnum  i  number of the column to write to
C       rownum  i  number of the row to write
C       nelem   i  input number of elements
C       offset  i  input byte offset of the first element
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1991
 
        integer ounit,colnum,rownum,nelem,offset,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart,iray(2)
 
        if (status .gt. 0)return
        if (rownum .lt. 1)then
C               error: illegal row number
                status=307
                return
        end if
 
        ibuff=bufnum(ounit)
 
C       check that this is really a 'P' type column
        if (tdtype(colnum+tstart(ibuff)) .ge. 0)then
                status=317
                return
        end if
 
C       move to the specified column and row:
        bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff)
     &         +tbcol(colnum+tstart(ibuff))
        call ftmbyt(ounit,bstart,.true.,status)
 
C       now write the number of elements and the offset to the table:
        iray(1)=nelem
        iray(2)=offset
        call ftpi4b(ounit,2,0,iray,status)
        end
        subroutine ftpdfl(iunit,status)
 
C       Write the Data Unit Fill values if they are not already correct
C       Fill the data unit with zeros or blanks depending on the type of HDU
C       from the end of the data to the end of the current FITS 2880 byte block
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1994
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nf = 3000)
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character *2880 chbuff
        character*1 chfill,xdummy(29119)
        common/ftheap/chbuff,chfill,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,filpos,nfill,i,tstat
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check if the data unit is null
 
        if (theap(ibuff) .eq. 0)return
 
        filpos=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff)
        nfill=(filpos+2879)/2880*2880-filpos
 
C       return if there are no fill bytes
        if (nfill .eq. 0)return
 
C       set the correct fill value to be checked
        if (hdutyp(ibuff) .eq. 1)then
C              this is an ASCII table; should be filled with blanks
               chfill=char(32)
        else
               chfill=char(0)
        end if
 
C       move to the beginning of the fill bytes and read them
        tstat=status
        call ftmbyt(iunit,filpos,.true.,status)
        call ftgcbf(iunit,nfill,chbuff,status)
 
        if (status .gt. 0)then
C           fill bytes probably haven't been written yet so have to write them
            status=tstat
            go to 100
        end if
 
C       check if all the fill values are correct
        do 10 i=1,nfill
            if (chbuff(i:i) .ne. chfill)go to 100
10      continue
 
C       fill bytes were correct, so just return
        return
 
100     continue
 
C       fill the buffer with the correct fill value
        do 20 i=1,nfill
               chbuff(i:i)=chfill
20      continue
 
C       move to the beginning of the fill bytes
        call ftmbyt(iunit,filpos,.true.,status)
 
C       write all the fill bytes
        call ftpcbf(iunit,nfill,chbuff,status)
 
        if (status .gt. 0)then
           call ftpmsg('Error writing Data Unit fill bytes (FTPDFL).')
        end if
        end
        subroutine ftpgpb(ounit,group,fparm,nparm,array,status)
 
C       Write an array of group parmeters into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter to be written (starting with 1)
C       nparm   i  number of group parameters to be written
C       array   b  the array of group parameters to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,fparm,nparm,status,row
 
        character*1 array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpclb(ounit,1,row,fparm,nparm,array,status)
        end
        subroutine ftpgpd(ounit,group,fparm,nparm,array,status)
 
C       Write an array of group parmeters into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter to be written (starting with 1)
C       nparm   i  number of group parameters to be written
C       array   d  the array of group parameters to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,fparm,nparm,status,row
        double precision array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcld(ounit,1,row,fparm,nparm,array,status)
        end
        subroutine ftpgpe(ounit,group,fparm,nparm,array,status)
 
C       Write an array of group parmeters into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter to be written (starting with 1)
C       nparm   i  number of group parameters to be written
C       array   r  the array of group parameters to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,fparm,nparm,status,row
        real array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcle(ounit,1,row,fparm,nparm,array,status)
        end
        subroutine ftpgpi(ounit,group,fparm,nparm,array,status)
 
C       Write an array of group parmeters into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter to be written (starting with 1)
C       nparm   i  number of group parameters to be written
C       array   i*2  the array of group parameters to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,fparm,nparm,status,row
        integer*2 array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcli(ounit,1,row,fparm,nparm,array,status)
        end
        subroutine ftpgpj(ounit,group,fparm,nparm,array,status)
 
C       Write an array of group parmeters into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       fparm   i  the first group parameter to be written (starting with 1)
C       nparm   i  number of group parameters to be written
C       array   i  the array of group parameters to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,fparm,nparm,status,row
        integer array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpclj(ounit,1,row,fparm,nparm,array,status)
        end
        subroutine ftphbn(ounit,nrows,nfield,ttype,tform,tunit,
     &                    extnam,pcount,status)
 
C       write required standard header keywords for a binary table extension
C
C       ounit   i  fortran output unit number
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array) (optional)
C       tform   c  format of each field (array)
C       tunit   c  units of each field (array) (optional)
C       extnam  c  name of table extension (optional)
C       pcount  i  size of special data area following the table (usually = 0)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,nrows,nfield,pcount,status
        integer i,lenrow,dtype,rcount,xbcol,length,width
        integer nkeys,nmore
        character*(*) ttype(*),tform(*),tunit(*),extnam
        character comm*48,tfm*40
 
        if (status .gt. 0)return
 
        call ftghsp(ounit,nkeys,nmore,status)
        if (nkeys .ne. 0)then
C            some keywords have already been written
             status=201
             return
        end if
 
        comm='binary table extension'
        call ftpkys(ounit,'XTENSION','BINTABLE',comm,status)
 
        comm='8-bit bytes'
        call ftpkyj(ounit,'BITPIX',8,comm,status)
 
        comm='2-dimensional binary table'
        call ftpkyj(ounit,'NAXIS',2,comm,status)
 
        if (status .gt. 0)return
 
C       calculate the total width of each row, in bytes
        lenrow=0
        do 10 i=1,nfield
C               get the numerical datatype and repeat count of the field
                call ftbnfm(tform(i),dtype,rcount,width,status)
                if (dtype .eq. 1)then
C                       treat Bit datatype as if it were a Byte datatype
                        dtype=11
                        rcount=(rcount+7)/8
                end if
C               get the width of the field
                call ftgtbc(1,dtype,rcount,xbcol,length,status)
                lenrow=lenrow+length
10      continue
 
        comm='width of table in bytes'
        call ftpkyj(ounit,'NAXIS1',lenrow,comm,status)
 
        if (status .gt. 0)return
 
        if (nrows .ge. 0)then
                comm='number of rows in table'
                call ftpkyj(ounit,'NAXIS2',nrows,comm,status)
        else
                status=218
        end if
 
        if (status .gt. 0)return
 
        if (pcount .ge. 0)then
                comm='size of special data area'
                call ftpkyj(ounit,'PCOUNT',pcount,comm,status)
        else
                status=214
        end if
 
        comm='one data group (required keyword)'
        call ftpkyj(ounit,'GCOUNT',1,comm,status)
 
        comm='number of fields in each row'
        call ftpkyj(ounit,'TFIELDS',nfield,comm,status)
 
        if (status .gt. 0)return
 
        do 20 i=1,nfield
            if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then
                comm='label for field '
                write(comm(17:19),1000)i
1000            format(i3)
                call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status)
            end if
 
            comm='data format of field'
C           make sure format characters are in upper case:
            tfm=tform(i)
            call ftupch(tfm)
 
C           Add datatype to the comment string:
            call ftbnfm(tfm,dtype,rcount,width,status)
            if (dtype .eq. 21)then
                comm(21:)=': 2-byte INTEGER'
            else if(dtype .eq. 41)then
                comm(21:)=': 4-byte INTEGER'
            else if(dtype .eq. 42)then
                comm(21:)=': 4-byte REAL'
            else if(dtype .eq. 82)then
                comm(21:)=': 8-byte DOUBLE'
            else if(dtype .eq. 16)then
                comm(21:)=': ASCII Character'
            else if(dtype .eq. 14)then
                comm(21:)=': 1-byte LOGICAL'
            else if(dtype .eq. 11)then
                comm(21:)=': BYTE'
            else if(dtype .eq. 1)then
                comm(21:)=': BIT'
            else if(dtype .eq. 83)then
                comm(21:)=': COMPLEX'
            else if(dtype .eq. 163)then
                comm(21:)=': DOUBLE COMPLEX'
            else if(dtype .lt. 0)then
                comm(21:)=': variable length array'
            end if
 
            call ftpkns(ounit,'TFORM',i,1,tfm,comm,status)
 
            if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then
                comm='physical unit of field'
                call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status)
            end if
            if (status .gt. 0)return
20      continue
 
        if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then
                comm='name of this binary table extension'
                call ftpkys(ounit,'EXTNAME',extnam,comm,status)
        end if
        end
        subroutine ftphis(ounit,histry,status)
 
C       write a HISTORY record to the FITS header
C
C       ounit   i  fortran output unit number
C       histry  c  input history string
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,status,strlen,actlen,i,nkeys,c1,c2
        character*(*) histry
        character*80  rec
 
        if (status .gt. 0)return
 
C       find the length of the string, and write it out 70 characters at a time
        nkeys=1
        strlen=len(histry)
        actlen=strlen
        do 10 i=strlen,1,-1
                if (histry(i:i) .ne. ' ')then
                        actlen=i
                        go to 20
                end if
10      continue
 
20      c1=1
        c2=min(actlen,70)
        nkeys=(actlen-1)/70+1
        do 30 i=1,nkeys
                rec='HISTORY   '//histry(c1:c2)
                call ftprec(ounit,rec,status)
                c1=c1+70
                c2=min(actlen,c2+70)
30      continue
        end
        subroutine ftphpr(ounit,simple,bitpix,naxis,naxes,
     &                    pcount,gcount,extend,status)
 
C       write required primary header keywords
C
C       ounit   i  fortran output unit number
C       simple  l  does file conform to FITS standard?
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       pcount  i  number of group parameters
C       gcount  i  number of random groups
C       extend  l  may extensions be present in the FITS file?
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status,i,ibuff
        character comm*50,caxis*20,clen*3
        logical simple,extend
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
        if ( hdend(ibuff) .ne. hdstrt(ibuff,chdu(ibuff)) )then
C            some keywords have already been written
             status=201
             return
        end if
 
        if (chdu(ibuff) .eq. 1)then
            if (simple)then
                comm='file does conform to FITS standard'
            else
                comm='file does not conform to FITS standard'
            end if
            call ftpkyl(ounit,'SIMPLE',simple,comm,status)
        else
            comm='IMAGE extension'
            call ftpkys(ounit,'XTENSION','IMAGE',comm,status)
        end if
 
C       test for legal value of bitpix
        call fttbit(bitpix,status)
        comm='number of bits per data pixel'
        call ftpkyj(ounit,'BITPIX',bitpix,comm,status)
        if (status .gt. 0)go to 900
 
        if (naxis .ge. 0 .and. naxis .le. 999)then
                comm='number of data axes'
                call ftpkyj(ounit,'NAXIS',naxis,comm,status)
        else
C               illegal value of naxis
                status=212
                write(caxis,1000)naxis
1000            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPHPR '
     &          //'is illegal.')
                go to 900
        end if
 
        comm='length of data axis'
        do 10 i=1,naxis
                if (naxes(i) .ge. 0)then
                        if (i .le. 9)then
                          write(comm(21:21),1001)i
                        else if (i .le. 99)then
                          write(comm(21:22),1002)i
                        else
                          write(comm(21:23),1003)i
                        end if
1001                    format(i1)
1002                    format(i2)
1003                    format(i3)
                        call ftpknj(ounit,'NAXIS',i,1,naxes(i),comm,
     &                              status)
                else
C                       illegal NAXISnnn keyword value
                        status=213
                        write(clen,1003)i
                        write(caxis,1000)naxes(i)
        call ftpmsg('In call to FTPHPR, axis '//clen//
     &  ' has illegal negative size: '//caxis)
                        go to 900
                end if
10      continue
 
        if (chdu(ibuff) .eq. 1)then
C               only write the EXTEND keyword to primary header if true
                if (extend)then
                        comm='FITS dataset may contain extensions'
                        call ftpkyl(ounit,'EXTEND',extend,comm,status)
                end if
 
C               write the PCOUNT and GCOUNT values if nonstandard
                if (pcount .gt. 0 .or. gcount .gt. 1)then
                    comm='random group records are present'
                    call ftpkyl(ounit,'GROUPS',.true.,comm,status)
                    comm='number of random group parameters'
                    call ftpkyj(ounit,'PCOUNT',pcount,comm,status)
                    comm='number of random groups'
                    call ftpkyj(ounit,'GCOUNT',gcount,comm,status)
                end if
 
                call ftpcom(ounit,'FITS (Flexible Image Transport '//
     & 'System) format defined in Astronomy and',status)
                call ftpcom(ounit,'Astrophysics Supplement Series '//
     & 'v44/p363, v44/p371, v73/p359, v73/p365.',status)
                call ftpcom(ounit,'Contact the NASA Science '//
     & 'Office of Standards and Technology for the',status)
                call ftpcom(ounit,'FITS Definition document '//
     & '#100 and other FITS information.',status)
 
        else
                comm='required keyword; must = 0'
                call ftpkyj(ounit,'PCOUNT',pcount,comm,status)
                comm='required keyword; must = 1'
                call ftpkyj(ounit,'GCOUNT',gcount,comm,status)
        end if
 
900     continue
        end
        subroutine ftphps(ounit,bitpix,naxis,naxes,status)
 
C       write required primary header keywords
C
C       ounit   i  fortran output unit number
C       simple  l  does file conform to FITS standard?
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       pcount  i  number of group parameters
C       gcount  i  number of random groups
C       extend  l  may extensions be present in the FITS file?
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,bitpix,naxis,naxes(*),status
 
        call ftphpr(ounit,.true.,bitpix,naxis,naxes,
     &                    0,1,.true.,status)
        end
        subroutine ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol,
     &  tform,tunit,extnam,status)
 
C       write required standard header keywords for an ASCII table extension
C
C       ounit   i  fortran output unit number
C       ncols   i  number of columns in the table
C       nrows   i  number of rows in the table
C       nfield  i  number of fields in the table
C       ttype   c  name of each field (array) (optional)
C       tbcol   i  beginning column of each field (array)
C       tform   c  Fortran-77 format of each field (array)
C       tunit   c  units of each field (array) (optional)
C       extnam  c  name of table extension (optional)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,ncols,nrows,nfield,tbcol(*),status,i
        integer nkeys,nmore
        character*(*) ttype(*),tform(*),tunit(*),extnam
        character comm*48,tfm*20
 
        if (status .gt. 0)return
 
        call ftghsp(ounit,nkeys,nmore,status)
        if (nkeys .ne. 0)then
C            some keywords have already been written
             status=201
             return
        end if
 
        comm='ASCII table extension'
        call ftpkys(ounit,'XTENSION','TABLE',comm,status)
 
        comm='8-bit ASCII characters'
        call ftpkyj(ounit,'BITPIX',8,comm,status)
 
        comm='2-dimensional ASCII table'
        call ftpkyj(ounit,'NAXIS',2,comm,status)
 
        if (status .gt. 0)return
 
        if (ncols .ge. 0)then
                comm='width of table in characters'
                call ftpkyj(ounit,'NAXIS1',ncols,comm,status)
        else
C               illegal table width
                status=217
        call ftpmsg('ASCII table has negative width (NAXIS1) in'//
     &  ' call to FTPHTB')
                return
        end if
 
        if (status .gt. 0)return
 
        if (nrows .ge. 0)then
                comm='number of rows in table'
                call ftpkyj(ounit,'NAXIS2',nrows,comm,status)
        else
C               illegal number of rows in table
                status=218
        call ftpmsg('ASCII table has negative number of rows in'//
     &  ' call to FTPHTB')
        end if
 
        if (status .gt. 0)return
 
        comm='no group parameters (required keyword)'
        call ftpkyj(ounit,'PCOUNT',0,comm,status)
 
        comm='one data group (required keyword)'
        call ftpkyj(ounit,'GCOUNT',1,comm,status)
 
        if (status .gt. 0)return
 
        if (nfield .ge. 0)then
                comm='number of fields in each row'
                call ftpkyj(ounit,'TFIELDS',nfield,comm,status)
        else
C               illegal number of fields
                status=216
        call ftpmsg('ASCII table has negative number of fields in'//
     &  ' call to FTPHTB')
        end if
 
        if (status .gt. 0)return
 
        do 10 i=1,nfield
            if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then
                comm='label for field '
                write(comm(17:19),1000)i
1000            format(i3)
                call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status)
            end if
 
            comm='beginning column of field '
            write(comm(27:29),1000)i
            call ftpknj(ounit,'TBCOL',i,1,tbcol(i),comm,status)
 
            comm='Fortran-77 format of field'
C           make sure format characters are in upper case:
            tfm=tform(i)
            call ftupch(tfm)
            call ftpkns(ounit,'TFORM',i,1,tfm,comm,status)
 
            if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then
                comm='physical unit of field'
                call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status)
            end if
        if (status .gt. 0)return
10      continue
 
        if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then
                comm='name of this ASCII table extension'
                call ftpkys(ounit,'EXTNAME',extnam,comm,status)
        end if
        end
        subroutine ftpi1b(ounit,nvals,incre,chbuff,status)
 
C       Write an array of Integer*1 bytes to the output FITS file.
 
        integer nvals,incre,ounit,status,offset
        character*1 chbuff(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       chbuff  c*1 array of input byte values
C       status  i  output error status
 
        if (incre .le. 1)then
                call ftpcbf(ounit,nvals,chbuff,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-1
                call ftpcbo(ounit,1,nvals,offset,chbuff,status)
        end if
        end
        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,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
 
        integer*2 temp(4)
        integer ierr,cray2ieg,remain
        integer compid
        common/ftcpid/compid
        character ctemp*1
 
        if (compid .eq. 0)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. -1)then
C           SUN F90 compiler maps I*2 -> I*4; have to pack bytes
            call ftpki2(i2vals,nvals,ctemp)
        else if (compid .ge. 1)then
C           little endian machine (e.g. DEC, VAX, or PC) must be byte swapped
            call ftswby(i2vals,nvals)
        else
C           must be a CRAY
C           convert from cray I*8 to IEEE I*2
C           there is a bug in cray2ieg if the number of values to convert
C           is  1 less than a  multiple of 4 2-byte words.  (3, 7, 11, etc)
            remain=nvals-nvals/4*4
            if (remain .eq. 3)then
              if (nvals .gt. 3)then
                ierr= cray2ieg(7,nvals-3,i2vals,0,i2vals,1,' ')
              end if
              temp(3)=i2vals(nvals)
              temp(2)=i2vals(nvals-1)
              temp(1)=i2vals(nvals-2)
              ierr=cray2ieg(7,4,i2vals(nvals/4+1),0,temp,1,' ')
            else
              ierr=cray2ieg(7,nvals,i2vals,0,i2vals,1,' ')
            end if
        end if
 
        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
                call ftpbyo(ounit,2,nvals,offset,i2vals,status)
        end if
        end
        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,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
 
        integer compid
        common/ftcpid/compid
 
        integer cray2ieg,neven,ierr
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .ge. 1)then
C           little endian machine (e.g. DEC, VAX, or PC) must be byte swapped
            call ftswi4(i4vals,nvals)
        else
C         must be a CRAY
C         there is a bug in cray2ieg if the number of values to convert
C         is not a multiple of 8 bytes.
          neven=nvals/2*2
          if (neven .gt. 0)then
              ierr= cray2ieg(1,neven,i4vals,0,i4vals,1,' ')
          end if
 
          if (neven .ne. nvals)then
C           have to do the remaining odd word separately
            ierr= cray2ieg(1,1,i4vals(nvals/2+1),0,i4vals(nvals),1,' ')
          end if
        end if
 
        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
                call ftpbyo(ounit,4,nvals,offset,i4vals,status)
        end if
        end
        subroutine ftpini(iunit,status)
 
C       initialize the parameters defining the structure of the primary data
 
C       iunit   i  Fortran I/O unit number
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bitpix,naxis,naxes(99),pcnt,gcnt,ttype
        integer blank,bytlen,npix,i,nblank,tstat
        double precision bscale,bzero
        logical simple,extend,groups
        character*8 comm
 
        if (status .gt. 0)return
        groups=.false.
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       store the type of HDU (0=primary array or image extension)
        hdutyp(ibuff)=0
 
C       temporarily set the location of the end of the header to a huge number
        hdend(ibuff)=2000000000
        hdstrt(ibuff,chdu(ibuff)+1)=2000000000
 
C       get the standard header keywords
        tstat=status
        call ftgphx(iunit,99,simple,bitpix,naxis,naxes,
     &        pcnt,gcnt,extend,bscale,bzero,blank,nblank,status)
 
        if (status .eq. 251)then
C               ignore 'unknown extension type' error, and go on
                status=tstat
        else if (status .gt. 0)then
                return
        end if
 
        if (naxis .gt. 99)then
C               the image array has too many dimensions for me to handle
                status=111
        call ftpmsg('This FITS image has too many dimensions (FTPINI)')
                return
        end if
 
C       the 'END' record is 80 bytes before the current position, ignoring
C       any trailing blank keywords just before the END keyword.
        hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1)
 
C       the data unit begins at the beginning of the next logical block
        dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880
 
C       test for the presence of 'random groups' structure
        if (naxis .gt. 0 .and. naxes(1) .eq. 0)then
                tstat=status
                call ftgkyl(iunit,'GROUPS',groups,comm,status)
                if (status .gt. 0)then
                        status=tstat
                        groups=.false.
                end if
        end if
 
C       test  bitpix and set the datatype code value
        if (bitpix .eq. 8)then
                ttype=11
                bytlen=1
        else if (bitpix .eq. 16)then
                ttype=21
                bytlen=2
        else if (bitpix .eq. 32)then
                ttype=41
                bytlen=4
        else if (bitpix .eq. -32)then
                ttype=42
                bytlen=4
        else if (bitpix .eq. -64)then
                ttype=82
                bytlen=8
        end if
 
C       calculate the size of the primary array
        if (naxis .eq. 0)then
                npix=0
        else
                if (groups)then
C                       NAXIS1 = 0 is a special flag for 'random groups'
                        npix=1
                else
                        npix=naxes(1)
                end if
 
                do 10 i=2,naxis
                        npix=npix*naxes(i)
10              continue
        end if
 
C       now we know everything about the array; just fill in the parameters:
C       the next HDU begins in the next logical block after the data
        hdstrt(ibuff,chdu(ibuff)+1)=
     &  dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880
 
C       initialize the fictitious heap starting address (immediately following
C       the array data) and a zero length heap.  This is used to find the
C       end of the data when checking the fill values in the last block.
        heapsz(ibuff)=0
        theap(ibuff)=(pcnt+npix)*bytlen*gcnt
 
C       quit if there is no data
        if (naxis .eq. 0)then
                tfield(ibuff)=0
                rowlen(ibuff)=0
                go to 900
        end if
 
C       the primary array is actually interpreted as a binary table.  There
C       are two columns: the first column contains the
C       group parameters, if any, and the second column contains the
C       primary array of data.  Each group is in a separate row of the table.
 
        tfield(ibuff)=2
        if (nxtfld + 2 .gt. nf)then
C               too many columns open at one time; exceeded array dimensions
                status=111
        else
                tstart(ibuff)=nxtfld
                nxtfld=nxtfld+2
                tdtype(1+tstart(ibuff))=ttype
                tdtype(2+tstart(ibuff))=ttype
                trept(1+tstart(ibuff))=pcnt
                trept(2+tstart(ibuff))=npix
                tnull(1+tstart(ibuff))=blank
                tnull(2+tstart(ibuff))=blank
                tscale(1+tstart(ibuff))=1.
                tscale(2+tstart(ibuff))=bscale
                tzero(1+tstart(ibuff))=0.
                tzero(2+tstart(ibuff))=bzero
                tbcol(1+tstart(ibuff))=0
                tbcol(2+tstart(ibuff))=pcnt*bytlen
                rowlen(ibuff)=(pcnt+npix)*bytlen
        end if
 
900     continue
        end
        subroutine ftpkey(ounit,keywrd,value,comm,status)
 
C       write a simple FITS keyword record with format:
C            "KEYWORD = VALUE / COMMENT"
C               VALUE is assumed to be 20 characters long
C               COMMENT is assumed to be 47 characters long
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       value   c  keyword value   (20 characters, cols. 11-30)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,value,comm
        integer ounit,status
        character key*8, val*20, com*47
 
        key=keywrd
        val=value
        com=comm
 
C       append the 80 characters to the output buffer:
        call ftprec(ounit,key//'= '//val//' / '//com,status)
        end
        subroutine ftpki2(i2vals,nvals,temp)
 
C       pack array of 4-byte integers into sequence of 2-byte integers
C       This routine is only currently used on the SUN Solaris F90
C       which does not directly support integer*2 variables and instead
C       maps them into integer*4 variables.
 
        integer nvals,ii,jj
        integer*2 temp
        character*1 i2vals(nvals*4)
 
        jj = 2
        do 10 ii = 4,nvals*4,4
             i2vals(jj-1) = i2vals(ii - 1)
             i2vals(jj)   = i2vals(ii)
             jj = jj +2
10      continue
 
        end
        subroutine ftpkls(ounit,keywrd,strval,comm,status)
 
C       write a character string value to a header record, supporting
C       the OGIP long string convention.  If the keyword string value
C       is longer than 68 characters (which is the maximum that will fit
C       on a single 80 character keyword record) then the value string will
C       be continued over multiple keywords.  This OGIP convention uses the
C       '&' character at the end of a string to indicate that it is continued
C       on the next keyword.  The name of all the continued keywords is
C       'CONTINUE'.
C
C       The FTPLSW subroutine should be called prior to using this
C       subroutine, to write a warning message in the header
C       describing how the convention works.
 
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       strval  c  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Sept 1994
 
        character*(*) keywrd,comm,strval
        integer ounit,status,lenval,ncomm,nvalue
        integer clen,i,strlen,nseg,c1,c2
        character value*70,keynam*10,cmnt*48
 
        if (status .gt. 0)return
 
        keynam=keywrd
        keynam(9:10)='= '
        cmnt=comm
 
C       find the number of characters in the input string
        clen=len(strval)
        do 10 i=clen,1,-1
                if (strval(i:i) .ne. ' ')then
                        strlen=i
                        go to 20
                end if
10      continue
        strlen=1
 
C       calculate the number of keywords needed to write the whole string
20      nseg=max(1,(strlen-2)/67+1)
 
        c1=1
        do 30 i=1,nseg
                c2=min(c1+67,strlen)
C               convert string to quoted character string
 
C        fts2c was modified on 29 Nov 1994, so this code is no longer needed
C                (remember to declare character*70 ctemp if this code is used)
C                if (i .gt. 1 .and. strval(c1:c1) .eq. ' ')then
CC                   have to preserve leading blanks on continuation cards
C                    ctemp='A'//strval(c1+1:c2)
C                    call fts2c(ctemp,value,lenval,status)
CC                   now reset the first character of the string back to a blank
C                    value(2:2)=' '
C                else
 
                    call fts2c(strval(c1:c2),value,lenval,status)
 
C                end if
 
                if (i .ne. nseg .and. lenval .ne. 70)then
C                       if the string is continued, preserve trailing blanks
                        value(lenval:69)=' '
                        value(70:70)=''''
                        lenval=70
                end if
 
C               overwrite last character with a '&' if string is continued.
                if (i .lt. nseg)then
                        value(69:69)='&'
                end if
 
C               find amount of space left for comment string (assume
C               10 char. for 'keyword = ', and 3 between value and comment)
C               which leaves 67 spaces for the value + comment strings
 
                nvalue=max(20,lenval)
                ncomm=67-nvalue
 
C               write the keyword record
                if (ncomm .gt. 0)then
C                       there is space for a comment
                        call ftprec(ounit,keynam//
     &                  value(1:nvalue)//' / '//cmnt(1:ncomm),status)
                else
C                       no room for a comment
                        call ftprec(ounit,keynam//
     &                  value(1:nvalue)//'   ',status)
                end if
 
C               initialize for the next segment of the string, if any
                c1=c1+67
                keynam='CONTINUE  '
30      continue
        end
        subroutine ftpknd(ounit,keywrd,nstart,nkey,dval,decim,comm,
     &                    status)
 
C       write an array of real*8 values to header records in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       dval    d  array of keyword values
C       decim   i  number of decimal places to display in the value field
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,decim,ounit,status,i,j
        double precision dval(*)
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                  call ftpkyd(ounit,keynam,dval(i),decim,comm1,status)
                else
                  call ftpkyd(ounit,keynam,dval(i),decim,comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpkne(ounit,keywrd,nstart,nkey,rval,decim,comm,
     &                    status)
 
C       write an array of real*4 values to header records in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       rval    r  array of keyword values
C       decim   i  number of decimal places to display in the value field
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,decim,ounit,status,i,j
        real rval(*)
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                  call ftpkye(ounit,keynam,rval(i),decim,comm1,status)
                else
                  call ftpkye(ounit,keynam,rval(i),decim,comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpknf(ounit,keywrd,nstart,nkey,rval,decim,comm,
     &                    status)
 
C       write an array of real*4 values to header records in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       rval    r  array of keyword values
C       decim   i  number of decimal places to display in the value field
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,decim,ounit,status,i,j
        real rval(*)
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                  call ftpkyf(ounit,keynam,rval(i),decim,comm1,status)
                else
                  call ftpkyf(ounit,keynam,rval(i),decim,comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpkng(ounit,keywrd,nstart,nkey,dval,decim,comm,
     &                    status)
 
C       write an array of real*8 values to header records in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       dval    d  array of keyword values
C       decim   i  number of decimal places to display in the value field
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,decim,ounit,status,i,j
        double precision dval(*)
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                  call ftpkyg(ounit,keynam,dval(i),decim,comm1,status)
                else
                  call ftpkyg(ounit,keynam,dval(i),decim,comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpknj(ounit,keywrd,nstart,nkey,intval,comm,
     &                    status)
 
C       write an array of integer values to header records
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       intval  i  array of keyword values
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,ounit,status,intval(*),i,j
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                   call ftpkyj(ounit,keynam,intval(i),comm1,status)
                else
                   call ftpkyj(ounit,keynam,intval(i),comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpknl(ounit,keywrd,nstart,nkey,logval,comm,
     &                    status)
 
C       write an array of logical values to header records
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       logval  l  array of keyword values
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm(*)
        integer nstart,nkey,ounit,status,i,j
        logical logval(*)
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
C       (if the last non-blank character is '&', then it is to be repeated)
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                  call ftpkyl(ounit,keynam,logval(i),comm1,status)
                else
                  call ftpkyl(ounit,keynam,logval(i),comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpkns(ounit,keywrd,nstart,nkey,strval,comm,
     &                    status)
 
C       write an array of character string values to header records
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       nstart  i  starting sequence number (usually 1)
C       nkey    i  number of keywords to write
C       strval  c  array of keyword values
C       comm    c  array of keyword comments (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,strval(*),comm(*)
        integer nstart,nkey,ounit,status,i,j
        character keynam*8,comm1*48
        logical repeat
 
        if (status .gt. 0)return
 
C       check if the first comment string is to be repeated for all keywords
        call ftcrep(comm(1),comm1,repeat)
 
        j=nstart
        do 10 i=1,nkey
C               construct keyword name:
                call ftkeyn(keywrd,j,keynam,status)
 
C               write the keyword record
                if (repeat)then
                   call ftpkys(ounit,keynam,strval(i),comm1,status)
                else
                   call ftpkys(ounit,keynam,strval(i),comm(i),status)
                end if
                if (status .gt. 0)return
                j=j+1
10      continue
        end
        subroutine ftpkyd(ounit,keywrd,dval,decim,comm,status)
 
C       write a double precision value to a header record in E format
C       If it will fit, the value field will be 20 characters wide;
C       otherwise it will be expanded to up to 35 characters, left
C       justified.
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (max. 47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim,vlen
        character value*35,key*8,cmnt*48
 
        key=keywrd
        cmnt=comm
 
C       convert double precision to E format character string
        call ftd2e(dval,decim,value,vlen,status)
 
C       write the keyword record
        call ftprec(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status)
        end
        subroutine ftpkye(ounit,keywrd,rval,decim,comm,status)
 
C       write a real*4 value to a header record in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim
        character value*20
 
C       convert real to E format character string
        call ftr2e(rval,decim,value,status)
 
C       write the keyword record
        call ftpkey(ounit,keywrd,value,comm,status)
        end
        subroutine ftpkyf(ounit,keywrd,rval,decim,comm,status)
 
C       write a real*4 value to a header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim
        character value*20
 
C       convert real to F format character string
        call ftr2f(rval,decim,value,status)
 
C       write the keyword record
        call ftpkey(ounit,keywrd,value,comm,status)
        end
        subroutine ftpkyg(ounit,keywrd,dval,decim,comm,status)
 
C       write a double precision value to a header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim
        character value*20
 
C       convert double precision to F format character string
        call ftd2f(dval,decim,value,status)
 
C       write the keyword record
        call ftpkey(ounit,keywrd,value,comm,status)
        end
        subroutine ftpkyj(ounit,keywrd,intval,comm,status)
 
C       write an integer value to a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       intval  i  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer ounit,status,intval
        character value*20
 
C       convert integer to character string
        call fti2c(intval,value,status)
 
C       write the keyword record
        call ftpkey(ounit,keywrd,value,comm,status)
        end
        subroutine ftpkyl(ounit,keywrd,logval,comm,status)
 
C       write a logical value to a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       logval  l  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keywrd,comm
        integer ounit,status
        logical logval
        character value*20
 
C       convert logical to character string
        call ftl2c(logval,value,status)
 
C       write the keyword record
        call ftpkey(ounit,keywrd,value,comm,status)
        end
        subroutine ftpkys(ounit,keywrd,strval,comm,status)
 
C       write a character string value to a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       strval  c  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C       modified 6/93 to handle long string values by continuing the
C       string onto subsequent comment keywords (with a blank keyword name)
 
C       Modified again in 9/94 to remove support for long string values;
C       Now, one must call ftpkls to write a long string values.
 
        character*(*) keywrd,comm,strval
        integer ounit,status,lenval,ncomm,nvalue
        character strtmp*68,value*70,keynam*8,cmnt*48
 
        if (status .gt. 0)return
 
        strtmp=strval
        keynam=keywrd
        cmnt=comm
 
C       convert string to quoted character string (max length = 70 characters)
        call fts2c(strtmp,value,lenval,status)
 
C       find amount of space left for comment string
C       (assume 10 char. for 'keyword = ', and 3 between value and comment)
C       which leaves 67 spaces for the value string + comment string
        nvalue=max(20,lenval)
        ncomm=67-nvalue
 
C       write the keyword record
        if (ncomm .gt. 0)then
C         there is space for a comment
          call ftprec(ounit,
     &    keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status)
        else
C         no room for a comment
          call ftprec(ounit,
     &    keynam//'= '//value(1:nvalue)//'   ',status)
        end if
        end
        subroutine ftpkyt(ounit,keywrd,jval,dval,comm,status)
 
C       concatinate a integer value with a double precision fraction
C       and write it to the FITS header along with the comment string
C       The value will be displayed in F28.16 format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       jval    i  integer part of the keyword value
C       dval    d  fractional part of the keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Sept 1992
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,jval,status,dlen,i,fchar
        character dstr*35,jstr*20,key*8,cmnt*48
 
        if (status .gt. 0)return
 
        if (dval .ge. 1.0  .or. dval .lt.  0.)then
                status = 402
        end if
 
        key=keywrd
        cmnt=comm
 
C       convert integer to C*20 character string
        call fti2c(jval,jstr,status)
 
C       ignore leading spaces
        fchar=10
        do 10 i=10,20
          if (jstr(i:i) .ne. ' ')then
             fchar = i
             go to 20
          end if
10      continue
20      continue
 
C       convert double precision to E23.16 format character string
        call ftd2e(dval,15,dstr,dlen,status)
 
C       write the concatinated keyword record
        call ftprec(ounit,key//'= '//jstr(fchar:20)//'.'//
     1   dstr(1:1)//dstr(3:17)//' / '//cmnt,status)
        end
        subroutine ftpkyu(ounit,keywrd,comm,status)
 
C       write a null-valued keyword to a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,comm
        integer ounit,status
        character keynam*8,card*80
 
        if (status .gt. 0)return
 
        keynam=keywrd
        card=keynam//'=                      / '//comm
 
        call ftprec(ounit,card,status)
        end
        subroutine ftplsw(ounit,status)
 
C       Put Long String Warning:
C       write the LONGSTRN keyword and a few COMMENT keywords to the header
C       (if they don't already exist) to warn users that this FITS file
C       may use the OGIP long string convention.
 
C       This subroutine should be called whenever FTPKLS is called.
 
        integer ounit,status,tstat
        character value*8,comm*8
 
        if (status .gt. 0)return
 
        tstat=status
        call ftgkys(ounit,'LONGSTRN',value,comm,status)
        if (status .eq. 0)then
C             The keyword already exists so just exit
              return
         end if
 
         status=tstat
         call ftpkys(ounit,'LONGSTRN','OGIP 1.0',
     &   'The HEASARC Long String Convention may be used.',status)
 
         call ftpcom(ounit,
     & 'This FITS file may contain long string keyword values that are'
     &  ,status)
           call ftpcom(ounit,
     & 'continued over multiple keywords.  The HEASARC convention uses'
     &  //' the &',status)
            call ftpcom(ounit,
     & 'character at the end of each substring which is then continued'
     &  ,status)
            call ftpcom(ounit,
     & 'on the next keyword which has the name CONTINUE.'
     &  ,status)
        end
        subroutine ftpmsg(text)
 
C       put error message onto stack.
        character*(*) text
        call ftxmsg(1,text)
        end
        subroutine ftpnul(ounit,blank,status)
 
C       Primary Null value definition
C       Define the null value for an integer primary array.
C
C       ounit   i  Fortran I/O unit number
C       blank   i  the value to be use to signify undefined data
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,blank,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,ngroup
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
        if (status .gt. 0)return
 
C       test for proper HDU type
        if (hdutyp(ibuff) .ne. 0)then
            status=233
            return
        end if
 
C       the primary array is actually interpreted as a binary table.  There
C       are two columns for each group: the first column contains the
C       group parameters, if any, and the second column contains the
C       primary array of data.
 
        ngroup=tfield(ibuff)/2
        do 10 i=1,ngroup
                tnull(i*2+tstart(ibuff))=blank
10      continue
        end
        subroutine ftppnb(ounit,group,felem,nelem,array,nulval,status)
 
C       Write an array of c*1 (byte) values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same as the
C       array being written).  Any input pixels equal to the value of NULVAL
C       will be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   c*1  the array of values to be written
C       nulval  c*1  pixel value used to represent an undefine pixel
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,group,felem,nelem,status,row
        character*1 array(*),nulval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcnb(ounit,2,row,felem,nelem,array,nulval,status)
        end
        subroutine ftppnd(ounit,group,felem,nelem,array,nulval,status)
 
C       Write an array of double precision values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same as the
C       array being written).  Any input pixels equal to the value of NULVAL
C       will be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   d  the array of values to be written
C       nulval  d  pixel value used to represent an undefine pixel
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,group,felem,nelem,status,row
        double precision array(*),nulval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcnd(ounit,2,row,felem,nelem,array,nulval,status)
        end
        subroutine ftppne(ounit,group,felem,nelem,array,nulval,status)
 
C       Write an array of real values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same as the
C       array being written).  Any input pixels equal to the value of NULVAL
C       will be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   r  the array of values to be written
C       nulval  r  pixel value used to represent an undefine pixel
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,group,felem,nelem,status,row
        real array(*),nulval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcne(ounit,2,row,felem,nelem,array,nulval,status)
        end
        subroutine ftppni(ounit,group,felem,nelem,array,nulval,status)
 
C       Write an array of i*2 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same as the
C       array being written).  Any input pixels equal to the value of NULVAL
C       will be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   i*2  the array of values to be written
C       nulval  i*2  pixel value used to represent an undefine pixel
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,group,felem,nelem,status,row
        integer*2 array(*),nulval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcni(ounit,2,row,felem,nelem,array,nulval,status)
        end
        subroutine ftppnj(ounit,group,felem,nelem,array,nulval,status)
 
C       Write an array of i values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same as the
C       array being written).  Any input pixels equal to the value of NULVAL
C       will be replaced by the appropriate null value in the output FITS file.
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   i  the array of values to be written
C       nulval  i  pixel value used to represent an undefine pixel
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1994
 
        integer ounit,group,felem,nelem,status,row
        integer array(*),nulval
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcnj(ounit,2,row,felem,nelem,array,nulval,status)
        end
        subroutine ftpprb(ounit,group,felem,nelem,array,status)
 
C       Write an array of byte values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   b  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
 
        character*1 array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpclb(ounit,2,row,felem,nelem,array,status)
        end
        subroutine ftpprd(ounit,group,felem,nelem,array,status)
 
C       Write an array of r*8 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   d  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
        double precision array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcld(ounit,2,row,felem,nelem,array,status)
        end
        subroutine ftppre(ounit,group,felem,nelem,array,status)
 
C       Write an array of r*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   r  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
        real array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcle(ounit,2,row,felem,nelem,array,status)
        end
        subroutine ftpprh(ounit,simple,bitpix,naxis,naxes,
     &                    pcount,gcount,extend,status)
 
C       OBSOLETE routine: should call ftphpr instead
 
        integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status
        logical simple,extend
 
        call ftphpr(ounit,simple,bitpix,naxis,naxes,
     &                    pcount,gcount,extend,status)
        end
        subroutine ftppri(ounit,group,felem,nelem,array,status)
 
C       Write an array of i*2 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   i*2  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
        integer*2 array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpcli(ounit,2,row,felem,nelem,array,status)
        end
        subroutine ftpprj(ounit,group,felem,nelem,array,status)
 
C       Write an array of i*4 values into the primary array.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being written).
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be written
C       array   i  the array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
        integer array(*)
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpclj(ounit,2,row,felem,nelem,array,status)
        end
        subroutine ftppru(ounit,group,felem,nelem,status)
 
C       set elements of the primary array equal to the undefined value
 
C       ounit   i  Fortran output unit number
C       group   i  number of the data group, if any
C       felem   i  the first pixel to be written (this routine treats
C                  the primary array a large one dimensional array of
C                  values, regardless of the actual dimensionality).
C       nelem   i  number of data elements to be set to undefined
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,group,felem,nelem,status,row
 
C       the primary array is represented as a binary table:
C               each group of the primary array is a row in the table,
C               where the first column contains the group parameters
C               and the second column contains the image itself
        row=max(group,1)
        call ftpclu(ounit,2,row,felem,nelem,status)
        end
        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,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
 
        integer compid
        common/ftcpid/compid
 
        integer i,neven,ierr,cray2ieg
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. 1)then
C           little endian machine (e.g. DEC or PC) must be byte swapped
            call ftswi4(r4vals,nvals)
        else if (compid .ge. 2)then
C           convert from VAX format to IEEE
            do 5 i=1,nvals
                    r4vals(i)=r4vals(i)*0.25
5           continue
            call ftswby(r4vals,nvals*2)
        else
C         must be a CRAY
C         there is a bug in cray2ieg if the number of values to convert
C         is not a multiple of 8 bytes.
          neven=nvals/2*2
          ierr= cray2ieg(2,neven,r4vals,0,r4vals,1,' ')
          if (neven .ne. nvals)then
C           have to do the remaining odd word separately
            ierr= cray2ieg(2,1,r4vals(nvals/2+1),0,r4vals(nvals),1,' ')
          end if
        end if
 
        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
                call ftpbyo(ounit,4,nvals,offset,r4vals,status)
        end if
        end
        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,offset
        double precision r8vals(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       r8vals  d  array of input real*8 values
C       status  i  output error status
 
        integer compid
        common/ftcpid/compid
 
        integer i,ierr,cray2ieg
 
        if (compid .eq. 0 .or. compid .eq. -1)then
C           big endian machine (e.g., SUN) doesn't need byte swapping
        else if (compid .eq. 1)then
C           little endian machine (e.g. DEC or PC) must be byte swapped
            call ftswi8(r8vals,nvals)
        else if (compid .eq. 2)then
C           convert from VAX format to IEEE
            call ieevpd(r8vals,r8vals,nvals)
        else if (compid .eq. 3)then
C           convert from Alpha VMS format to IEEE
            do 5 i=1,nvals
                    r8vals(i)=r8vals(i)*0.25
5           continue
            call ftswby(r8vals,nvals*4)
        else
C           must be a CRAY
            ierr= cray2ieg(3,nvals,r8vals,0,r8vals,1,' ')
        end if
 
        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
            call ftpbyo(ounit,8,nvals,offset,r8vals,status)
        end if
        end
        subroutine ftprec(ounit,record,status)
 
C       write a 80 character record to the FITS header
C
C       ounit   i  fortran output unit number
C       record  c  input 80 character header record
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) record
        character*80  rec
        integer ounit,status,ibuff
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
 
        if (status .gt. 0)return
 
C       get the number of the data buffer used for this unit
        ibuff=bufnum(ounit)
 
        if (dtstrt(ibuff) .gt. 0
     &    .and.(dtstrt(ibuff)-hdend(ibuff)) .le. 80)then
C               not enough room in the header for another keyword
 
C               try getting more header space
                call ftiblk(ounit,1,0,status)
                if (status .gt. 0)then
                        go to 900
                end if
        end if
 
        rec=record
 
C       make sure keyword name is in upper case
        call ftupch(rec(1:8))
 
C       test that keyword name contains only legal characters
        call fttkey(rec(1:8),status)
 
C       test that the rest of the record contains only legal values
        call fttrec(rec(9:80),status)
 
C       position the I/O pointer to the end of the header
        call ftmbyt(ounit,hdend(ibuff),.true.,status)
 
C       append the 80 characters to the output buffer:
        call ftpcbf(ounit,80,rec,status)
        if (status .gt. 0)go to 900
 
C       increment the pointer to the last header record
        hdend(ibuff)=hdend(ibuff)+80
 
C       the following statement was added in v4.00 and removed again
C       in v4.09.  There appears to be no good reason to reset the
C       'next keyword' pointer after appending a new keyword to the
C       header, since this effectively just resets the pointer to the
C       beginning of the header.
C        nxthdr(ibuff)=hdend(ibuff)
 
900     continue
        end
        subroutine ftprsv(keyin,lenval,status)
 
C       find the total length of the keyword+value string in a keyword record
 
C       keyrec  c  80 column header record
C       OUTPUT PARAMETERS:
C       lenval  i  output length of keyword+value string
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keyin
        integer lenval,status,j,c1
        character*80 keyrec
 
        if (status .gt. 0)return
 
        keyrec=keyin
        if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY '
     &  .or. keyrec(1:8).eq.'END     ' .or. keyrec(1:8).eq.'        ')
     &  then
C           this is a COMMENT or HISTORY record, with no value
             lenval=8
        else if (keyrec(9:10) .eq. '= ')then
C           this keyword has a value field; now find the first character:
            do 10 j=10,80
                if (keyrec(j:j) .ne. ' ')then
                        c1=j
                        go to 15
                end if
10          continue
C           error: value is blank
            status=204
            call ftpmsg('The keyword '//keyrec(1:8)//
     &      ' has no value string after the equal sign:')
            call ftpmsg(keyrec)
            return
 
15          if (keyrec(c1:c1) .eq. '''')then
C               This is a string value.
C               Work forward to find a single quote.  Two single quotes
C               in succession is to be interpreted as a literal single
C               quote character as part of the character string, not as
C               the end of the character string.  Everything to the right
C               of the closing quote is assumed to be the comment.
                do 20 j=c1+1,80
                    if (keyrec(j:j) .eq. '''')then
                        if (j.lt.80 .and. keyrec(j+1:j+1).eq.'''')then
C                               found 2 successive quote characters; this is
C                               interpreted as a literal quote character
                        else
                                lenval=max(30,j)
                                go to 30
                        end if
                    end if
20              continue
C               error: no closing quote character
                status=205
            call ftpmsg('The following Keyword value string has '//
     &            'no closing quote:')
            call ftpmsg(keyrec)
                return
            else
C               This is either an integer, floating point, or logical value.
C               Extract the first token as the value; remainder = comment
                do 25 j=c1,80
                    if (keyrec(j:j) .eq. ' ')then
                        lenval=j-1
                        go to 30
                    end if
25              continue
C               the first token went all the way to column 80:
                lenval=80
            end if
        else
C               illegal keyword record format; must have '= ' in columns 9-10
C                status=210
C            Modified July 1993:  this is actually not an error.  The
C            keyword should simply be interpreted as a comment.
             lenval=8
        end if
30      continue
        end
        subroutine ftpscl(ounit,bscale,bzero,status)
 
C       Primary SCaLing factor definition
C       Define the scaling factor for the primary header data.
C
C       ounit   i  Fortran I/O unit number
C       bscale  d  scaling factor
C       bzero   d  scaling zero point
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,status
        double precision bscale,bzero
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,i,ngroup
 
        if (status .gt. 0)return
 
        if (bscale .eq. 0.)then
C               illegal bscale value
                status=322
                return
        end if
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
        if (status .gt. 0)return
 
C       test for proper HDU type
        if (hdutyp(ibuff) .ne. 0)then
            status=233
            return
        end if
 
C       the primary array is actually interpreted as a binary table.  There
C       are two columns for each group: the first column contains the
C       group parameters, if any, and the second column contains the
C       primary array of data.
        ngroup=tfield(ibuff)/2
        do 10 i=1,ngroup
                tscale(i*2+tstart(ibuff))=bscale
                tzero(i*2+tstart(ibuff))=bzero
10      continue
        end
        subroutine ftpssb(iunit,group,naxis,naxes,fpixel,lpixel,
     &                    array,status)
 
C       Write a subsection of byte values to the primary array.
C       A subsection is defined to be any contiguous rectangular
C       array of pixels within the n-dimensional FITS data file.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran input unit number
C       group   i  number of the data group to be written, if any
C       naxis   i  number of data axes in the FITS array
C       naxes   i  (array) size of each FITS axis
C       fpixel  i  (array) the first pixel in each dimension to be included
C                  in the subsection (first pixel = 1)
C       lpixel  i  (array) the last pixel in each dimension to be included
C                  in the subsection
C       array   c*1  array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status
        character*1 array(*)
        integer fpix(7),irange(7),dimen(7),astart,pstart
        integer off2,off3,off4,off5,off6,off7
        integer st10,st20,st30,st40,st50,st60,st70
        integer st1,st2,st3,st4,st5,st6,st7
        integer i,i1,i2,i3,i4,i5,i6,i7
        character caxis*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 7)then
C               this routine only supports up to 7 dimensions
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSB '
     &          //'is illegal.')
                return
        end if
 
C       calculate the sizes and number of loops to perform in each dimension
        do 10 i=1,7
             fpix(i)=1
             irange(i)=1
             dimen(i)=1
10      continue
 
        do 20 i=1,naxis
             fpix(i)=fpixel(i)
             irange(i)=lpixel(i)-fpixel(i)+1
             dimen(i)=naxes(i)
20      continue
        i1=irange(1)
 
C       compute the pixel offset between each dimension
        off2=     dimen(1)
        off3=off2*dimen(2)
        off4=off3*dimen(3)
        off5=off4*dimen(4)
        off6=off5*dimen(5)
        off7=off6*dimen(6)
 
        st10=fpix(1)
        st20=(fpix(2)-1)*off2
        st30=(fpix(3)-1)*off3
        st40=(fpix(4)-1)*off4
        st50=(fpix(5)-1)*off5
        st60=(fpix(6)-1)*off6
        st70=(fpix(7)-1)*off7
 
C       store the initial offset in each dimension
        st1=st10
        st2=st20
        st3=st30
        st4=st40
        st5=st50
        st6=st60
        st7=st70
 
        astart=1
 
        do 170 i7=1,irange(7)
        do 160 i6=1,irange(6)
        do 150 i5=1,irange(5)
        do 140 i4=1,irange(4)
        do 130 i3=1,irange(3)
        pstart=st1+st2+st3+st4+st5+st6+st7
        do 120 i2=1,irange(2)
                call ftpprb(iunit,group,pstart,i1,
     &              array(astart),status)
                astart=astart+i1
                pstart=pstart+off2
120     continue
        st2=st20
        st3=st3+off3
130     continue
        st3=st30
        st4=st4+off4
140     continue
        st4=st40
        st5=st5+off5
150     continue
        st5=st50
        st6=st6+off6
160     continue
        st6=st60
        st7=st7+off7
170     continue
        end
        subroutine ftpssd(iunit,group,naxis,naxes,fpixel,lpixel,
     &                    array,status)
 
C       Write a subsection of double precision values to the primary array.
C       A subsection is defined to be any contiguous rectangular
C       array of pixels within the n-dimensional FITS data file.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran input unit number
C       group   i  number of the data group to be written, if any
C       naxis   i  number of data axes in the FITS array
C       naxes   i  (array) size of each FITS axis
C       fpixel  i  (array) the first pixel in each dimension to be included
C                  in the subsection (first pixel = 1)
C       lpixel  i  (array) the last pixel in each dimension to be included
C                  in the subsection
C       array   d  array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status
        double precision array(*)
        integer fpix(7),irange(7),dimen(7),astart,pstart
        integer off2,off3,off4,off5,off6,off7
        integer st10,st20,st30,st40,st50,st60,st70
        integer st1,st2,st3,st4,st5,st6,st7
        integer i,i1,i2,i3,i4,i5,i6,i7
        character caxis*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 7)then
C               this routine only supports up to 7 dimensions
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSD '
     &          //'is illegal.')
                return
        end if
 
C       calculate the sizes and number of loops to perform in each dimension
        do 10 i=1,7
             fpix(i)=1
             irange(i)=1
             dimen(i)=1
10      continue
 
        do 20 i=1,naxis
             fpix(i)=fpixel(i)
             irange(i)=lpixel(i)-fpixel(i)+1
             dimen(i)=naxes(i)
20      continue
        i1=irange(1)
 
C       compute the pixel offset between each dimension
        off2=     dimen(1)
        off3=off2*dimen(2)
        off4=off3*dimen(3)
        off5=off4*dimen(4)
        off6=off5*dimen(5)
        off7=off6*dimen(6)
 
        st10=fpix(1)
        st20=(fpix(2)-1)*off2
        st30=(fpix(3)-1)*off3
        st40=(fpix(4)-1)*off4
        st50=(fpix(5)-1)*off5
        st60=(fpix(6)-1)*off6
        st70=(fpix(7)-1)*off7
 
C       store the initial offset in each dimension
        st1=st10
        st2=st20
        st3=st30
        st4=st40
        st5=st50
        st6=st60
        st7=st70
 
        astart=1
 
        do 170 i7=1,irange(7)
        do 160 i6=1,irange(6)
        do 150 i5=1,irange(5)
        do 140 i4=1,irange(4)
        do 130 i3=1,irange(3)
        pstart=st1+st2+st3+st4+st5+st6+st7
        do 120 i2=1,irange(2)
                call ftpprd(iunit,group,pstart,i1,
     &              array(astart),status)
                astart=astart+i1
                pstart=pstart+off2
120     continue
        st2=st20
        st3=st3+off3
130     continue
        st3=st30
        st4=st4+off4
140     continue
        st4=st40
        st5=st5+off5
150     continue
        st5=st50
        st6=st6+off6
160     continue
        st6=st60
        st7=st7+off7
170     continue
        end
        subroutine ftpsse(iunit,group,naxis,naxes,fpixel,lpixel,
     &                    array,status)
 
C       Write a subsection of real values to the primary array.
C       A subsection is defined to be any contiguous rectangular
C       array of pixels within the n-dimensional FITS data file.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran input unit number
C       group   i  number of the data group to be written, if any
C       naxis   i  number of data axes in the FITS array
C       naxes   i  (array) size of each FITS axis
C       fpixel  i  (array) the first pixel in each dimension to be included
C                  in the subsection (first pixel = 1)
C       lpixel  i  (array) the last pixel in each dimension to be included
C                  in the subsection
C       array   r  array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status
        real array(*)
        integer fpix(7),irange(7),dimen(7),astart,pstart
        integer off2,off3,off4,off5,off6,off7
        integer st10,st20,st30,st40,st50,st60,st70
        integer st1,st2,st3,st4,st5,st6,st7
        integer i,i1,i2,i3,i4,i5,i6,i7
        character caxis*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 7)then
C               this routine only supports up to 7 dimensions
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSE '
     &          //'is illegal.')
                return
        end if
 
C       calculate the sizes and number of loops to perform in each dimension
        do 10 i=1,7
             fpix(i)=1
             irange(i)=1
             dimen(i)=1
10      continue
 
        do 20 i=1,naxis
             fpix(i)=fpixel(i)
             irange(i)=lpixel(i)-fpixel(i)+1
             dimen(i)=naxes(i)
20      continue
        i1=irange(1)
 
C       compute the pixel offset between each dimension
        off2=     dimen(1)
        off3=off2*dimen(2)
        off4=off3*dimen(3)
        off5=off4*dimen(4)
        off6=off5*dimen(5)
        off7=off6*dimen(6)
 
        st10=fpix(1)
        st20=(fpix(2)-1)*off2
        st30=(fpix(3)-1)*off3
        st40=(fpix(4)-1)*off4
        st50=(fpix(5)-1)*off5
        st60=(fpix(6)-1)*off6
        st70=(fpix(7)-1)*off7
 
C       store the initial offset in each dimension
        st1=st10
        st2=st20
        st3=st30
        st4=st40
        st5=st50
        st6=st60
        st7=st70
 
        astart=1
 
        do 170 i7=1,irange(7)
        do 160 i6=1,irange(6)
        do 150 i5=1,irange(5)
        do 140 i4=1,irange(4)
        do 130 i3=1,irange(3)
        pstart=st1+st2+st3+st4+st5+st6+st7
        do 120 i2=1,irange(2)
                call ftppre(iunit,group,pstart,i1,
     &              array(astart),status)
                astart=astart+i1
                pstart=pstart+off2
120     continue
        st2=st20
        st3=st3+off3
130     continue
        st3=st30
        st4=st4+off4
140     continue
        st4=st40
        st5=st5+off5
150     continue
        st5=st50
        st6=st6+off6
160     continue
        st6=st60
        st7=st7+off7
170     continue
        end
        subroutine ftpssi(iunit,group,naxis,naxes,fpixel,lpixel,
     &                    array,status)
 
C       Write a subsection of integer*2 values to the primary array.
C       A subsection is defined to be any contiguous rectangular
C       array of pixels within the n-dimensional FITS data file.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran input unit number
C       group   i  number of the data group to be written, if any
C       naxis   i  number of data axes in the FITS array
C       naxes   i  (array) size of each FITS axis
C       fpixel  i  (array) the first pixel in each dimension to be included
C                  in the subsection (first pixel = 1)
C       lpixel  i  (array) the last pixel in each dimension to be included
C                  in the subsection
C       array   i*2  array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status
        integer*2 array(*)
        integer fpix(7),irange(7),dimen(7),astart,pstart
        integer off2,off3,off4,off5,off6,off7
        integer st10,st20,st30,st40,st50,st60,st70
        integer st1,st2,st3,st4,st5,st6,st7
        integer i,i1,i2,i3,i4,i5,i6,i7
        character caxis*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 7)then
C               this routine only supports up to 7 dimensions
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSI '
     &          //'is illegal.')
                return
        end if
 
C       calculate the sizes and number of loops to perform in each dimension
        do 10 i=1,7
             fpix(i)=1
             irange(i)=1
             dimen(i)=1
10      continue
 
        do 20 i=1,naxis
             fpix(i)=fpixel(i)
             irange(i)=lpixel(i)-fpixel(i)+1
             dimen(i)=naxes(i)
20      continue
        i1=irange(1)
 
C       compute the pixel offset between each dimension
        off2=     dimen(1)
        off3=off2*dimen(2)
        off4=off3*dimen(3)
        off5=off4*dimen(4)
        off6=off5*dimen(5)
        off7=off6*dimen(6)
 
        st10=fpix(1)
        st20=(fpix(2)-1)*off2
        st30=(fpix(3)-1)*off3
        st40=(fpix(4)-1)*off4
        st50=(fpix(5)-1)*off5
        st60=(fpix(6)-1)*off6
        st70=(fpix(7)-1)*off7
 
C       store the initial offset in each dimension
        st1=st10
        st2=st20
        st3=st30
        st4=st40
        st5=st50
        st6=st60
        st7=st70
 
        astart=1
 
        do 170 i7=1,irange(7)
        do 160 i6=1,irange(6)
        do 150 i5=1,irange(5)
        do 140 i4=1,irange(4)
        do 130 i3=1,irange(3)
        pstart=st1+st2+st3+st4+st5+st6+st7
        do 120 i2=1,irange(2)
                call ftppri(iunit,group,pstart,i1,
     &              array(astart),status)
                astart=astart+i1
                pstart=pstart+off2
120     continue
        st2=st20
        st3=st3+off3
130     continue
        st3=st30
        st4=st4+off4
140     continue
        st4=st40
        st5=st5+off5
150     continue
        st5=st50
        st6=st6+off6
160     continue
        st6=st60
        st7=st7+off7
170     continue
        end
        subroutine ftpssj(iunit,group,naxis,naxes,fpixel,lpixel,
     &                    array,status)
 
C       Write a subsection of integer values to the primary array.
C       A subsection is defined to be any contiguous rectangular
C       array of pixels within the n-dimensional FITS data file.
C       Data conversion and scaling will be performed if necessary
C       (e.g, if the datatype of the FITS array is not the same
C       as the array being read).
 
C       iunit   i  Fortran input unit number
C       group   i  number of the data group to be written, if any
C       naxis   i  number of data axes in the FITS array
C       naxes   i  (array) size of each FITS axis
C       fpixel  i  (array) the first pixel in each dimension to be included
C                  in the subsection (first pixel = 1)
C       lpixel  i  (array) the last pixel in each dimension to be included
C                  in the subsection
C       array   i  array of values to be written
C       status  i  returned error stataus
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1992
 
        integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status
        integer array(*)
        integer fpix(7),irange(7),dimen(7),astart,pstart
        integer off2,off3,off4,off5,off6,off7
        integer st10,st20,st30,st40,st50,st60,st70
        integer st1,st2,st3,st4,st5,st6,st7
        integer i,i1,i2,i3,i4,i5,i6,i7
        character caxis*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 7)then
C               this routine only supports up to 7 dimensions
                status=320
                write(caxis,1001)naxis
1001            format(i20)
                call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSJ '
     &          //'is illegal.')
                return
        end if
 
C       calculate the sizes and number of loops to perform in each dimension
        do 10 i=1,7
             fpix(i)=1
             irange(i)=1
             dimen(i)=1
10      continue
 
        do 20 i=1,naxis
             fpix(i)=fpixel(i)
             irange(i)=lpixel(i)-fpixel(i)+1
             dimen(i)=naxes(i)
20      continue
        i1=irange(1)
 
C       compute the pixel offset between each dimension
        off2=     dimen(1)
        off3=off2*dimen(2)
        off4=off3*dimen(3)
        off5=off4*dimen(4)
        off6=off5*dimen(5)
        off7=off6*dimen(6)
 
        st10=fpix(1)
        st20=(fpix(2)-1)*off2
        st30=(fpix(3)-1)*off3
        st40=(fpix(4)-1)*off4
        st50=(fpix(5)-1)*off5
        st60=(fpix(6)-1)*off6
        st70=(fpix(7)-1)*off7
 
C       store the initial offset in each dimension
        st1=st10
        st2=st20
        st3=st30
        st4=st40
        st5=st50
        st6=st60
        st7=st70
 
        astart=1
 
        do 170 i7=1,irange(7)
        do 160 i6=1,irange(6)
        do 150 i5=1,irange(5)
        do 140 i4=1,irange(4)
        do 130 i3=1,irange(3)
        pstart=st1+st2+st3+st4+st5+st6+st7
        do 120 i2=1,irange(2)
                call ftpprj(iunit,group,pstart,i1,
     &              array(astart),status)
                astart=astart+i1
                pstart=pstart+off2
120     continue
        st2=st20
        st3=st3+off3
130     continue
        st3=st30
        st4=st4+off4
140     continue
        st4=st40
        st5=st5+off5
150     continue
        st5=st50
        st6=st6+off6
160     continue
        st6=st60
        st7=st7+off7
170     continue
        end
        subroutine ftpsvc(keyin,value,comm,status)
 
C       parse the header record to find value and comment strings
 
C       keyrec  c  80 column header record
C       OUTPUT PARAMETERS:
C       value   c  output keyword value string
C       comm    c  output keyword comment string
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        character*(*) keyin,value,comm
        character*80 keyrec,keytmp,ctemp
        integer status,j,k,c1
 
        if (status .gt. 0)return
 
        keyrec=keyin
        if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY '
     &  .or. keyrec(1:8).eq.'END     ' .or. keyrec(1:8).eq.'        ')
     &  then
C           this is a COMMENT or HISTORY record, with no value
            value=' '
            comm=keyrec(9:80)
        else if (keyrec(9:10) .eq. '= ')then
C           this keyword has a value field; now find the first character:
            do 10 j=10,80
                if (keyrec(j:j) .ne. ' ')then
                        c1=j
                        go to 15
                end if
10          continue
 
C       the absence of a value string is legal, and simply indicates
C       that the keyword value is undefined.  Don't write an error
C       message in this case.
 
C            status=204
C            call ftpmsg('The keyword '//keyrec(1:8)//
C     &      ' has no value string after the equal sign:')
C            call ftpmsg(keyrec)
 
            value=' '
            comm=' '
            return
 
15          if (keyrec(c1:c1) .eq. '/')then
C               keyword has no defined value (has a null value)
                value=' '
                ctemp=keyrec(c1:80)
            else if (keyrec(c1:c1) .eq. '''')then
C               This is a string value.
C               Work forward to find a single quote.  Two single quotes
C               in succession is to be interpreted as a literal single
C               quote character as part of the character string, not as
C               the end of the character string.  Everything to the right
C               of the closing quote is assumed to be the comment.
C               First, copy input to temporary string variable
                keytmp=keyrec
                do 20 j=c1+1,80
                    if (keytmp(j:j) .eq. '''')then
                        if (j.lt.80 .and. keytmp(j+1:j+1).eq.'''')then
C                               found 2 successive quote characters; this is
C                               interpreted as a literal quote character; remove
C                               one of the quotes from the string, and continue
C                               searching for the closing quote character:
                                do 18 k=j+2,80
                                    keytmp(k-1:k-1)=keytmp(k:k)
18                              continue
                                keytmp(80:80)=' '
                        else
                                value=keytmp(c1:j)
                                if (j .lt. 80)then
                                        ctemp=keytmp(j+1:80)
                                else
                                        ctemp=' '
                                end if
                                go to 30
                        end if
                    end if
20              continue
C               error: no closing quote character
                status=205
            call ftpmsg('The following Keyword value string has '//
     &            'no closing quote:')
            call ftpmsg(keyrec)
                return
            else
C               This is either an integer, floating point, or logical value.
C               Extract the first token as the value; remainder = comment
                do 25 j=c1,80
                    if (keyrec(j:j) .eq. ' ')then
                        value=keyrec(c1:j-1)
                        ctemp=keyrec(j+1:80)
                        go to 30
                    end if
25              continue
C               the first token went all the way to column 80:
                value=keyrec(c1:80)
                ctemp=' '
            end if
 
30          comm=' '
C           look for first character in the comment string
            do 40 j=1,78
                if (ctemp(j:j).ne.' ')then
                        if (ctemp(j:j).eq.'/')then
C                            ignore first space, if it exists
                             if (ctemp(j+1:j+1) .eq. ' ')then
                                comm=ctemp(j+2:80)
                             else
                                comm=ctemp(j+1:80)
                             end if
                        else
                                comm=ctemp(j:80)
                        end if
                        go to 50
                end if
40          continue
        else
C           illegal keyword record format; must have '= ' in columns 9-10
C           status=210
C           Modified July 1993:  this is actually not an error.  The
C           keyword should simply be interpreted as a comment.
            value=' '
            comm=keyrec(9:80)
        end if
50      continue
        end
        subroutine ftptbb(iunit,frow,fchar,nchars,value,status)
 
C       write a consecutive string of bytes to an ascii or binary
C       table. This will span multiple rows of the table if NCHARS+FCHAR is
C       greater than the length of a row.
 
C       iunit   i  fortran unit number
C       frow    i  starting row number (1st row = 1)
C       fchar   i  starting byte in the row to write (1st character=1)
C       nchars  i  number of bytes to write (can span multiple rows)
C       value   i  array of bytes to write
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1991
 
        integer iunit,frow,fchar,nchars,status
        integer value(*)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check for errors
        if (nchars .le. 0)then
C               zero or negative number of character requested
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                return
        else if (fchar .lt. 1)then
C               error: illegal starting character
                status=308
                return
        end if
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status)
 
C       move the i/o pointer to the start of the sequence of characters
        bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1
        call ftmbyt(iunit,bstart,.true.,status)
 
C       put the string of bytes
        call ftpbyt(iunit,nchars,value,status)
        end
        subroutine ftptbh(ounit,ncols,nrows,nfield,ttype,tbcol,
     &  tform,tunit,extnam,status)
 
C       OBSOLETE routine: should call ftphtb instead
 
        integer ounit,ncols,nrows,nfield,tbcol(*),status
        character*(*) ttype(*),tform(*),tunit(*),extnam
 
        call ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol,
     &  tform,tunit,extnam,status)
        end
        subroutine ftptbs(iunit,frow,fchar,nchars,svalue,status)
 
C       write a consecutive string of characters to an ascii or binary
C       table. This will span multiple rows of the table if NCHARS+FCHAR is
C       greater than the length of a row.
 
C       iunit   i  fortran unit number
C       frow    i  starting row number (1st row = 1)
C       fchar   i  starting character/byte in the row to write (1st character=1)
C       nchars  i  number of characters/bytes to write (can span multiple rows)
C       svalue  c  string of characters to write
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1991
 
        integer iunit,frow,fchar,nchars,status
        character*(*) svalue
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,bstart
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       check for errors
        if (nchars .le. 0)then
C               zero or negative number of character requested
                return
        else if (frow .lt. 1)then
C               error: illegal first row number
                status=307
                return
        else if (fchar .lt. 1)then
C               error: illegal starting character
                status=308
                return
        end if
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status)
 
C       move the i/o pointer to the start of the sequence of characters
        bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1
        call ftmbyt(iunit,bstart,.true.,status)
 
C       put the string of characters
        call ftpcbf(iunit,nchars,svalue,status)
        end
        subroutine ftptdm(iunit,colnum,naxis,naxes,status)
 
C       write the TDIMnnn keyword describing the dimensionality of a column
 
C       iunit   i  fortran unit number to use for reading
C       colnum  i  column number to read
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       OUTPUT PARAMETERS:
C       status  i  output error status (0=OK)
C
C       written by Wm Pence, HEASARC/GSFC, October 1993
 
        integer iunit,colnum,naxis,naxes(*),status
 
        integer i,j,nextsp
        character tdim*120, cval*20
 
        if (status .gt. 0)return
 
        if (naxis .lt. 1 .or. naxis .gt. 100)then
C               illegal number of axes
                status=320
                return
        else if (colnum .lt. 1 .or. colnum .gt. 999)then
C               illegal column number
                status=302
                return
        end if
 
C       construct the keyword value
        tdim='('
 
        nextsp=2
        do 100 i=1,naxis
                if (naxes(i) .lt. 1)then
                        status=323
                        return
                end if
 
C               convert integer to right justified C*20 string
                call fti2c(naxes(i),cval,status)
                if (status .gt. 0)return
 
                do 20 j=20,1,-1
                        if (cval(j:j) .eq. ' ')then
                                tdim(nextsp:)=cval(j+1:20)
                                nextsp=nextsp+21-j
                                tdim(nextsp-1:)=','
                                go to 100
                        end if
20              continue
100     continue
 
        tdim(nextsp-1:)=')'
 
        call ftpkns(iunit,'TDIM',colnum,1,tdim,
     &          'size of the multidimensional array',status)
        end
        subroutine ftpthp(ounit,heap,status)
 
C       Define the starting address for the heap for a binary table.
C       The default address is NAXIS1 * NAXIS2.  It is in units of
C       bytes relative to the beginning of the regular binary table data.
C       This subroutine also writes the appropriate THEAP keyword to the
C       FITS header.
 
C       ounit   i  Fortran I/O unit number
C       heap   i  starting address of the heap
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1991
 
        integer ounit,heap,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
        ibuff=bufnum(ounit)
        theap(ibuff)=heap
 
C       write the keyword
        call ftukyj(ounit,'THEAP',heap,'Byte offset of heap area',
     &              status)
        end
        subroutine ftpunt(ounit,keywrd,kunit,status)
 
C       write the units string in a header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       kunit   c  keyword units string
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,kunit
        integer ounit,status,lenval,ii,clen,olen
        character card*80,value*80,knam*8,ocmnt*72,ncmnt*72
 
        if (status .gt. 0)return
 
        knam=keywrd
 
C       find the old keyword
        call ftgcrd(ounit,knam,card,status)
        if (status .eq. 202)then
          call ftpmsg('FTPUNT Could not find the '//knam//' keyword.')
          return
        end if
 
C       parse the record to find value and comment strings
        call ftpsvc(card,value,ocmnt,status)
 
C       get the length of the keyword name + value string
        call ftprsv(card,lenval,status)
 
        if (status .gt. 0)return
 
C       write the units string, in square brackets, to the new comment
 
        clen=1
        if (kunit .ne. ' ')then
          ncmnt='['//kunit
 
          do 10 ii = 72,1,-1
              if (ncmnt(ii:ii) .ne. ' ')then
                    clen = ii+1
                    ncmnt(clen:)='] '
                    clen=clen+2
                    go to 20
              end if
10        continue
20        continue
        end if
 
C       check for existing units field in the comment
        olen=1
        if (ocmnt(1:1) .eq. '[')then
            do 30 ii = 2,72
                if (ocmnt(ii:ii) .eq. ']')then
                    olen=ii+1
                    if (ocmnt(olen:olen) .eq. ' ')olen=olen+1
                    go to 40
                end if
30          continue
        end if
40      continue
 
C       concatinate the old comment string to the new string
        ncmnt(clen:)=ocmnt(olen:)
 
C       construct the whole new card
        card(lenval+1:)=' / '//ncmnt
 
C       modify the keyword record
        call ftmodr(ounit,card,status)
        end
        subroutine ftr2e(val,dec,cval,status)
 
C       convert real value to E20.* format character string
C       val     r  input value to be converted
C       dec     i  number of decimal places to display in output string
C       cval    c  output character string
C       status  i  output error status (0 = OK)
 
        real val
        integer dec,status
        character*20 cval,form*10
 
        if (status .gt. 0)return
 
        if (dec .ge. 1 .and. dec .le. 9)then
                write(form,2000)dec
2000            format('(1pe20.',i1,')')
        else if (dec .ge. 10 .and. dec .le. 13)then
                write(form,2001)dec
2001            format('(1pe20.',i2,')')
        else
C               illegal number of decimal places were specified
                status=411
                call ftpmsg('Error in FTR2E: number of decimal places '
     &                      //'is less than 1 or greater than 13.')
                return
        endif
 
        write(cval,form,err=900)val
        if (cval(1:1) .eq. '*')go to 900
        return
 
900     status=402
        call ftpmsg('Error in FTR2E converting real to E20. string.')
        end
        subroutine ftr2f(val,dec,cval,status)
 
C       convert real value to F20.* format character string
C       val     r  input value to be converted
C       dec     i  number of decimal places to display in output string
C       cval    c  output character string
C       status  i  output error status (0 = OK)
 
        real val
        integer dec,status
        character*20 cval,form*8
 
        if (status .gt. 0)return
 
        if (dec .ge. 0 .and. dec .le. 9)then
                write(form,2000)dec
2000            format('(f20.',i1,')')
        else if (dec .ge. 10 .and. dec .lt.18)then
                write(form,2001)dec
2001            format('(f20.',i2,')')
        else
                status=411
                call ftpmsg('Error in FTR2F: number of decimal places '
     &                      //'is less than 0 or greater than 18.')
                return
        endif
 
        write(cval,form,err=900)val
        if (cval(1:1) .eq. '*')go to 900
        return
900     status=402
        call ftpmsg('Error in FTR2F converting real to F20. string.')
        end
        subroutine ftr4i1(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*4 values to output i*1 values, doing optional
C       scaling and checking for null values
 
C       input   r input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  c*1 value to set  array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  c*1 returned array of values
C       status  i  output error status (0 = ok)
 
        real input(*)
        character*1 output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval
        logical tofits,flgray(*),anynul,noscal
        logical fttrnn
        external fttrnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                    do 10 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).lt. 255.49 .and.
     &                      input(i).gt. -.49)then
                                output(i)=char(nint(input(i)))
                        else if (input(i) .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
10                  continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                output(i)=char(nint(dval))
                            else if (dval .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                            else
                                status=-11
                                output(i)=char(0)
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                   don't have to check for nulls
                    if (noscal)then
                      do 30 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).lt. 255.49 .and.
     &                      input(i).gt. -.49)then
                                output(i)=char(int(input(i)))
                        else if (input(i) .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
30                    continue
                    else
                        do 40 i=1,n
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
40                      continue
                    end if
                else
C                   must test for null values
                    if (noscal)then
                         do 50 i=1,n
                             if (fttrnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                              else
C                               trap any values that overflow the I*1 range
                                if (input(i).lt. 255.49 .and.
     &                             input(i).gt. -.49)then
                                   output(i)=char(int(input(i)))
                                else if (input(i) .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                                else
                                    status=-11
                                    output(i)=char(0)
                                end if
                              end if
50                       continue
                    else
                       do 60 i=1,n
                          if (fttrnn(input(i)))then
                                    anynul=.true.
                                    if (chktyp .eq. 1)then
                                        output(i)=setval
                                    else
                                        flgray(i)=.true.
                                    end if
                          else
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
                          end if
60                     continue
                    end if
                end if
        end if
        end
        subroutine ftr4i2(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*4 values to output i*2 values, doing optional
C       scaling and checking for null values
 
C       input   r  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  i*2 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i*2 returned array of values
C       status  i  output error status (0 = ok)
 
        real input(*)
        integer*2 output(*),setval,mmini2,mmaxi2
        integer n,i,chktyp,status
        double precision scale,zero,dval,i2max,i2min
        logical tofits,flgray(*),anynul,noscal
        logical fttrnn
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
        real mini2,maxi2
        parameter (maxi2=32767.49)
        parameter (mini2=-32768.49)
        parameter (mmaxi2=32767)
        parameter (mmini2=-32768)
        external fttrnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. maxi2 .and.
     &                          input(i) .ge. mini2)then
                                    output(i)=nint(input(i))
                            else if (input(i) .gt. maxi2)then
                                    status=-11
                                    output(i)=mmaxi2
                            else
                                    status=-11
                                    output(i)=mmini2
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i2max .and. dval.gt.i2min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i2max)then
                                status=-11
                                output(i)=mmaxi2
                            else
                                status=-11
                                output(i)=mmini2
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                          do 30 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. maxi2 .and.
     &                          input(i) .ge. mini2)then
                                    output(i)=int(input(i))
                            else if (input(i) .gt. maxi2)then
                                    status=-11
                                    output(i)=mmaxi2
                            else
                                    status=-11
                                    output(i)=mmini2
                            end if
30                        continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=mmaxi2
                              else
                                  status=-11
                                  output(i)=mmini2
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                        do 50 i=1,n
                            if (fttrnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
C                               trap any values that overflow the I*2 range
                                if (input(i) .le. maxi2 .and.
     &                              input(i) .ge. mini2)then
                                        output(i)=int(input(i))
                                else if (input(i) .gt. maxi2)then
                                        status=-11
                                        output(i)=mmaxi2
                                else
                                        status=-11
                                        output(i)=mmini2
                                end if
                            end if
50                      continue
                    else
                        do 60 i=1,n
                            if (fttrnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=mmaxi2
                              else
                                  status=-11
                                  output(i)=mmini2
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine ftr4i4(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*4 values to output i*4 values, doing optional
C       scaling and checking for null values
 
C       input   r  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  i   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i   returned array of values
C       status  i  output error status (0 = ok)
 
        real input(*)
        integer output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval,i4min,i4max
        logical tofits,flgray(*),anynul,noscal
        logical fttrnn
        parameter (i4max= 2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        real mini4,maxi4
C       Warning: only have about 7 digits of precision, so don't try
C       to set the maxi4 and mini4 limits any closer to the I*4 range.
        parameter (maxi4= 2.1474835E+09)
        parameter (mini4=-2.1474835E+09)
        integer mmaxi4,mmini4
        parameter (mmaxi4=2147483647)
        external fttrnn
C       work around for bug in the DEC Alpha VMS compiler
        mmini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C                           trap any values that overflow the I*4 range
                            if (input(i) .le. maxi4 .and.
     &                          input(i) .ge. mini4)then
                                    output(i)=nint(input(i))
                            else if (input(i) .gt. maxi4)then
                                    status=-11
                                    output(i)=mmaxi4
                            else
                                    status=-11
                                    output(i)=mmini4
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*4 range
                            if (dval.lt.i4max .and. dval.gt.i4min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i4max)then
                                status=-11
                                output(i)=mmaxi4
                            else
                                status=-11
                                output(i)=mmini4
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                          do 30 i=1,n
C                           trap any values that overflow the I*4 range
                            if (input(i) .le. maxi4 .and.
     &                          input(i) .ge. mini4)then
                                    output(i)=int(input(i))
                            else if (input(i) .gt. maxi4)then
                                    status=-11
                                    output(i)=mmaxi4
                            else
                                    status=-11
                                    output(i)=mmini4
                            end if
30                        continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=mmaxi4
                              else
                                  status=-11
                                  output(i)=mmini4
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                        do 50 i=1,n
                            if (fttrnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                        output(i)=setval
                                else
                                        flgray(i)=.true.
                                end if
                            else
C                               trap any values that overflow the I*4 range
                                if (input(i) .le. maxi4 .and.
     &                              input(i) .ge. mini4)then
                                        output(i)=int(input(i))
                                else if (input(i) .gt. maxi4)then
                                        status=-11
                                        output(i)=mmaxi4
                                else
                                        status=-11
                                        output(i)=mmini4
                                end if
                            end if
50                      continue
                    else
                        do 60 i=1,n
                            if (fttrnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                     output(i)=setval
                                else
                                     flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=mmaxi4
                              else
                                  status=-11
                                  output(i)=mmini4
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine ftr4r4(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*4 values to output r*4 values, doing optional
C       scaling and checking for null values
 
C       input   r  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  r  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  r  returned array of values
 
        real input(*)
        real output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
        logical fttrnn
        external fttrnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (fttrnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (fttrnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine ftr4r8(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*4 values to output r*8 values, doing optional
C       scaling and checking for null values
 
C       input   r  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  d  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  d  returned array of values
 
        real input(*)
        double precision output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
        logical fttrnn
        external fttrnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (fttrnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (fttrnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine ftr4vx(r4vals,i2vals,nvals)
 
C       convert IEEE 32-bit floating point numbers to VAX floating point
C       This routine is only called on Vax and Alpha VMS systems.
 
        real r4vals(*)
        integer*2 i2vals(*)
        integer nvals,i,j
 
        j=1
        do 10 i=1,nvals
C           test for NaNs (treat +/- infinity the same as a NaN)
            if (i2vals(j) .ge. 32640 .or. (i2vals(j) .lt. 0 .and.
     &           i2vals(j) .ge. -128))then
                 i2vals(j)=-1
                 i2vals(j+1)=-1
 
C           set underflows and -0 (8000000 hex) = to zero
            else if (i2vals(j) .le. -32641 .or. (i2vals(j) .ge. 0 .and.
     &           i2vals(j) .le. 127))then
                 r4vals(i)=0.0
            else
C                Must be a real number, so multiply by 4.0 to convert to Vax
                 r4vals(i)=r4vals(i)*4.0
            end if
            j=j+2
10      continue
        end
        subroutine ftr8i1(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*8 values to output i*1 values, doing optional
C       scaling and checking for null values
 
C       input   d input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  c*1 value to set  array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  c*1 returned array of values
C       status  i  output error status (0 = ok)
 
        double precision input(*)
        character*1 output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval
        logical tofits,flgray(*),anynul,noscal
        logical fttdnn
        external fttdnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                    do 10 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).lt. 255.49 .and.
     &                      input(i).gt. -.49)then
                                output(i)=char(nint(input(i)))
                        else if (input(i) .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
10                  continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                output(i)=char(nint(dval))
                            else if (dval .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                            else
                                status=-11
                                output(i)=char(0)
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                   don't have to check for nulls
                    if (noscal)then
                      do 30 i=1,n
C                       trap any values that overflow the I*1 range
                        if (input(i).lt. 255.49 .and.
     &                      input(i).gt. -.49)then
                                output(i)=char(int(input(i)))
                        else if (input(i) .ge. 255.49)then
                                status=-11
                                output(i)=char(255)
                        else
                                status=-11
                                output(i)=char(0)
                        end if
30                    continue
                    else
                        do 40 i=1,n
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
40                      continue
                    end if
                else
C                   must test for null values
                    if (noscal)then
                         do 50 i=1,n
                             if (fttdnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                              else
C                               trap any values that overflow the I*1 range
                                if (input(i).lt. 255.49 .and.
     &                             input(i).gt. -.49)then
                                   output(i)=char(int(input(i)))
                                else if (input(i) .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                                else
                                    status=-11
                                    output(i)=char(0)
                                end if
                              end if
50                       continue
                     else
                        do 60 i=1,n
                          if (fttdnn(input(i)))then
                                    anynul=.true.
                                    if (chktyp .eq. 1)then
                                        output(i)=setval
                                    else
                                        flgray(i)=.true.
                                    end if
                          else
                            dval=input(i)*scale+zero
C                           trap any values that overflow the I*1 range
                            if (dval.lt. 255.49 .and. dval.gt. -.49)then
                                    output(i)=char(int(dval))
                            else if (dval .ge. 255.49)then
                                    status=-11
                                    output(i)=char(255)
                            else
                                    status=-11
                                    output(i)=char(0)
                            end if
                          end if
60                     continue
                    end if
                end if
        end if
        end
        subroutine ftr8i2(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*8 values to output i*2 values, doing optional
C       scaling and checking for null values
 
C       input   d  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  i*2 value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i*2 returned array of values
C       status  i  output error status (0 = ok)
 
        double precision input(*)
        integer*2 output(*),setval,maxi2,mini2
        integer n,i,chktyp,status
        double precision scale,zero,dval,i2max,i2min
        logical tofits,flgray(*),anynul,noscal
        logical fttdnn
        parameter (i2max=3.276749D+04)
        parameter (i2min=-3.276849D+04)
 
        parameter (maxi2=32767)
        parameter (mini2=-32768)
        external fttdnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. i2max .and.
     &                          input(i) .ge. i2min)then
                                    output(i)=nint(input(i))
                            else if (input(i) .gt. i2max)then
                                    status=-11
                                    output(i)=maxi2
                            else
                                    status=-11
                                    output(i)=mini2
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*2 range
                            if (dval.lt.i2max .and. dval.gt.i2min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i2max)then
                                status=-11
                                output(i)=maxi2
                            else
                                status=-11
                                output(i)=mini2
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                          do 30 i=1,n
C                           trap any values that overflow the I*2 range
                            if (input(i) .le. i2max .and.
     &                          input(i) .ge. i2min)then
                                    output(i)=int(input(i))
                            else if (input(i) .gt. i2max)then
                                    status=-11
                                    output(i)=maxi2
                            else
                                    status=-11
                                    output(i)=mini2
                            end if
30                        continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                        do 50 i=1,n
                            if (fttdnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                     output(i)=setval
                                else
                                     flgray(i)=.true.
                                end if
                            else
C                               trap any values that overflow the I*2 range
                                if (input(i) .le. i2max .and.
     &                              input(i) .ge. i2min)then
                                        output(i)=int(input(i))
                                else if (input(i) .gt. i2max)then
                                        status=-11
                                        output(i)=maxi2
                                else
                                        status=-11
                                        output(i)=mini2
                                end if
                            end if
50                      continue
                        else
                          do 60 i=1,n
                            if (fttdnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*2 range
                              if (dval.lt.i2max .and. dval.gt.i2min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i2max)then
                                  status=-11
                                  output(i)=maxi2
                              else
                                  status=-11
                                  output(i)=mini2
                              end if
                            end if
60                        continue
                        end if
                end if
        end if
        end
        subroutine ftr8i4(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*8 values to output i*4 values, doing optional
C       scaling and checking for null values
 
C       input   d  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  i   value to set output array to if value is undefined
C       flgray  l   array of logicals indicating if corresponding value is null
C       anynul  l   set to true if any nulls were set in the output array
C       output  i   returned array of values
C       status  i  output error status (0 = ok)
 
        double precision input(*)
        integer output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero,dval,i4min,i4max
        logical tofits,flgray(*),anynul,noscal
        logical fttdnn
        parameter (i4max=2.14748364749D+09)
        parameter (i4min=-2.14748364849D+09)
        integer maxi4,mini4
        parameter (maxi4=2147483647)
        external fttdnn
C       work around for bug in the DEC Alpha VMS compiler
        mini4=-2147483647 - 1
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
C                           trap any values that overflow the I*4 range
                            if (input(i) .le. i4max .and.
     &                          input(i) .ge. i4min)then
                                    output(i)=nint(input(i))
                            else if (input(i) .gt. i4max)then
                                    status=-11
                                    output(i)=maxi4
                            else
                                    status=-11
                                    output(i)=mini4
                            end if
10                      continue
                else
                        do 20 i=1,n
                            dval=(input(i)-zero)/scale
C                           trap any values that overflow the I*4 range
                            if (dval.lt.i4max .and. dval.gt.i4min)then
                                output(i)=nint(dval)
                            else if (dval .ge. i4max)then
                                status=-11
                                output(i)=maxi4
                            else
                                status=-11
                                output(i)=mini4
                            end if
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                          do 30 i=1,n
C                           trap any values that overflow the I*4 range
                            if (input(i) .le. i4max .and.
     &                          input(i) .ge. i4min)then
                                    output(i)=int(input(i))
                            else if (input(i) .gt. i4max)then
                                    status=-11
                                    output(i)=maxi4
                            else
                                    status=-11
                                    output(i)=mini4
                            end if
30                        continue
                        else
                            do 40 i=1,n
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
40                          continue
                        end if
                else
C                   must test for null values
                    if (noscal)then
                        do 50 i=1,n
                            if (fttdnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                    output(i)=setval
                                else
                                    flgray(i)=.true.
                                end if
                            else
C                               trap any values that overflow the I*4 range
                                if (input(i) .le. i4max .and.
     &                              input(i) .ge. i4min)then
                                        output(i)=int(input(i))
                                else if (input(i) .gt. i4max)then
                                        status=-11
                                        output(i)=maxi4
                                else
                                        status=-11
                                        output(i)=mini4
                                end if
                            end if
50                      continue
                    else
                        do 60 i=1,n
                            if (fttdnn(input(i)))then
                                anynul=.true.
                                if (chktyp .eq. 1)then
                                     output(i)=setval
                                else
                                     flgray(i)=.true.
                                end if
                            else
                              dval=input(i)*scale+zero
C                             trap any values that overflow the I*4 range
                              if (dval.lt.i4max .and. dval.gt.i4min)then
                                  output(i)=int(dval)
                              else if (dval .ge. i4max)then
                                  status=-11
                                  output(i)=maxi4
                              else
                                  status=-11
                                  output(i)=mini4
                              end if
                            end if
60                      continue
                    end if
                end if
        end if
        end
        subroutine ftr8r4(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*8 values to output r*4 values, doing optional
C       scaling and checking for null values
 
C       input   d  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  r  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  r  returned array of values
 
        double precision input(*)
        real output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
        logical fttdnn
        external fttdnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (fttdnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (fttdnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine ftr8r8(input,n,scale,zero,tofits,
     &          chktyp,setval,flgray,anynul,output,status)
 
C       copy input r*8 values to output r*8 values, doing optional
C       scaling and checking for null values
 
C       input   d  input array of values
C       n       i  number of values
C       scale   d  scaling factor to be applied
C       zero    d  scaling zero point to be applied
C       tofits  l  true if converting from internal format to FITS
C       chktyp  i  type of null value checking to be done if TOFITS=.false.
C                       =0  no checking for null values
C                       =1  set null values = SETVAL
C                       =2  set corresponding FLGRAY value = .true.
C       setval  d  value to set output array to if value is undefined
C       flgray  l  array of logicals indicating if corresponding value is null
C       anynul  l  set to true if any nulls were set in the output array
C       output  d  returned array of values
 
        double precision input(*)
        double precision output(*),setval
        integer n,i,chktyp,status
        double precision scale,zero
        logical tofits,flgray(*),anynul,noscal
        logical fttdnn
        external fttdnn
 
        if (status .gt. 0)return
 
        if (scale .eq. 1. .and. zero .eq. 0)then
                noscal=.true.
        else
                noscal=.false.
        end if
 
        if (tofits) then
C               we don't have to worry about null values when writing to FITS
                if (noscal)then
                        do 10 i=1,n
                                output(i)=input(i)
10                      continue
                else
                        do 20 i=1,n
                                output(i)=(input(i)-zero)/scale
20                      continue
                end if
        else
C               converting from FITS to internal format; may have to check nulls
                if (chktyp .eq. 0)then
C                       don't have to check for nulls
                        if (noscal)then
                                do 30 i=1,n
                                        output(i)=input(i)
30                              continue
                        else
                                do 40 i=1,n
                                        output(i)=input(i)*scale+zero
40                              continue
                        end if
                else
C                       must test for null values
                        if (noscal)then
                                do 50 i=1,n
                                        if (fttdnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                                output(i)=input(i)
                                        end if
50                              continue
                        else
                                do 60 i=1,n
                                        if (fttdnn(input(i)))then
                                            anynul=.true.
                                            if (chktyp .eq. 1)then
                                                output(i)=setval
                                            else
                                                flgray(i)=.true.
                                            end if
                                        else
                                         output(i)=input(i)*scale+zero
                                        end if
60                              continue
                        end if
                end if
        end if
        end
        subroutine ftr8vx(r8vals,i4vals,i2vals,nvals)
 
C       convert IEEE 32-bit floating point numbers to VAX floating point
C       This routine is only called on VAX computers.
 
        double precision r8vals(*)
        integer*2 i2vals(*)
        integer i4vals(*)
        integer nvals,i,j,k
 
        j=1
        k=1
        do 10 i=1,nvals
C           test for NaNs (treat +/- infinity the same as a NaN)
            if (i2vals(j) .ge. 32752 .or. (i2vals(j) .lt. 0 .and.
     &           i2vals(j) .ge. -16))then
                 i4vals(k)  =-1
                 i4vals(k+1)=-1
 
C           set underflows and -0 (8000000 hex) = to zero
            else if (i2vals(j) .le. -32753 .or. (i2vals(j) .ge. 0 .and.
     &           i2vals(j) .le. 15))then
                 r8vals(i)=0.0
            else
C                Must be a real number, so multiply by 4.0 to convert to Vax
                 r8vals(i)=r8vals(i)*4.0
            end if
            j=j+4
            k=k+2
10      continue
        end
        subroutine ftrdef(ounit,status)
 
C       ReDEFine the structure of a data unit.  This routine re-reads
C       the CHDU header keywords to determine the structure and length of the
C       current data unit.  This redefines the start of the next HDU.
C
C       ounit   i  Fortran I/O unit number
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1993
 
        integer ounit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,dummy
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       see if we have write access to this file (no need to go on, if not)
        if (wrmode(ibuff))then
C           rewrite the header END card, and following blank fill
            call ftwend(ounit,status)
            if (status .gt. 0)return
 
C           now re-read the required keywords to determine the structure
            call ftrhdu(ounit,dummy,status)
        end if
        end
        subroutine ftread(iunit,nrec,length,pbuff,status)
 
C       lowest-level routine to read a disk file record into a physical buffer
 
C       iunit   i  Fortran unit number to read from
C       nrec    i  number of the file record to read
C       length  i  number of bytes to read
C       pbuff   i  number of the physical buffer to read into
C       status  i  output error status
 
        integer iunit,nrec,length,pbuff,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,ios
 
C       test if desired record exists before trying to read it
        ibuff=bufnum(iunit)
        if (nrec .gt. maxrec(ibuff)) then
C             record doesn't exist, so return EOF error
              status=107
              return
        end if
 
        go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &  19,20)pbuff
 
C       if got here, then pbuff is out of range
        status=101
        return
 
1       read(iunit,rec=nrec,iostat=ios)b1(1:length)
        go to 100
2       read(iunit,rec=nrec,iostat=ios)b2(1:length)
        go to 100
3       read(iunit,rec=nrec,iostat=ios)b3(1:length)
        go to 100
4       read(iunit,rec=nrec,iostat=ios)b4(1:length)
        go to 100
5       read(iunit,rec=nrec,iostat=ios)b5(1:length)
        go to 100
6       read(iunit,rec=nrec,iostat=ios)b6(1:length)
        go to 100
7       read(iunit,rec=nrec,iostat=ios)b7(1:length)
        go to 100
8       read(iunit,rec=nrec,iostat=ios)b8(1:length)
        go to 100
9       read(iunit,rec=nrec,iostat=ios)b9(1:length)
        go to 100
10      read(iunit,rec=nrec,iostat=ios)b10(1:length)
        go to 100
11      read(iunit,rec=nrec,iostat=ios)b11(1:length)
        go to 100
12      read(iunit,rec=nrec,iostat=ios)b12(1:length)
        go to 100
13      read(iunit,rec=nrec,iostat=ios)b13(1:length)
        go to 100
14      read(iunit,rec=nrec,iostat=ios)b14(1:length)
        go to 100
15      read(iunit,rec=nrec,iostat=ios)b15(1:length)
        go to 100
16      read(iunit,rec=nrec,iostat=ios)b16(1:length)
        go to 100
17      read(iunit,rec=nrec,iostat=ios)b17(1:length)
        go to 100
18      read(iunit,rec=nrec,iostat=ios)b18(1:length)
        go to 100
19      read(iunit,rec=nrec,iostat=ios)b19(1:length)
        go to 100
20      read(iunit,rec=nrec,iostat=ios)b20(1:length)
 
100     continue
        if (ios .ne. 0)then
C               assume that this error indicates an end of file condition
                status=107
        end if
        end
        subroutine ftrhdu(iunit,xtend,status)
 
C       read the CHDU structure by reading the header keywords which define
C       the size and structure of the header and data units.
 
C       iunit   i  Fortran I/O unit number
C       OUTPUT PARAMETERS:
C       xtend   i  returned type of extension:   0 = the primary HDU
C                                                1 = an ASCII table
C                                                2 = a binary table
C                                               -1 = unknown
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer iunit,xtend,status,i,ic,tstat
        character keynam*8,exttyp*10,comm*30,keybuf*80
        logical endof
 
        if (status .gt. 0)return
 
C       read first keyword to determine the type of the CHDU
        call ftgrec(iunit,1,keybuf,status)
 
        if (status .gt. 0)then
          call ftpmsg('Cannot read first keyword in header (FTRHDU)')
                return
        end if
 
C       release any current column descriptors for this unit
        call ftfrcl(iunit,status)
 
        keynam=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,exttyp,comm,status)
 
        if (status .gt. 0)then
C               unknown type of FITS record; can't read it
          call ftpmsg('Cannot parse value of first keyword; unknown '
     &      //'type of FITS record (FTRHDU):')
 
        else if (keynam .eq. 'SIMPLE')then
C               initialize the parameters describing the primay HDU
                call ftpini(iunit,status)
                xtend=0
        else if (keynam.eq.'XTENSION')then
                if (exttyp(1:1) .ne. '''')then
C                       value of XTENSION is not a quoted character string!
                        if (keybuf(9:10) .ne. '= ')then
                            call ftpmsg('XTENSION keyword does not '
     &                     //'have "= " in cols 9-10.')
                        else
                        call ftpmsg('Unknown type of extension; value'
     &               //' of XTENSION keyword is not a quoted string:')
                        end if
                        status=251
                        call ftpmsg(keybuf)
                else if (exttyp(2:9) .eq. 'TABLE   ')then
C                       initialize the parameters for the ASCII table extension
                        call ftaini(iunit,status)
                        xtend=1
                else if (exttyp(2:9) .eq. 'BINTABLE' .or. exttyp(2:9)
     &            .eq. 'A3DTABLE' .or. exttyp(2:9) .eq. '3DTABLE ')then
C                       initialize the parameters for the binary table extension
                        call ftbini(iunit,status)
                        xtend=2
                else
C                       try to initialize the parameters describing extension
                        tstat=status
                        call ftpini(iunit,status)
                        xtend=0
                        if (status .eq. 251)then
C                           unknown type of extension
                            xtend=-1
                            status=tstat
                        end if
                end if
        else
C               unknown record
C               If file is created on a VAX with 512-byte records, then
C               the FITS file may have fill bytes (ASCII NULs) at the end.
C               Also, if file has been editted on a SUN, an extra ASCII 10
C               character may appear at the end of the file.  Finally, if
C               file is not a multiple of the record length long, then
C               the last truncated record may be filled with ASCII blanks.
C               So, if the record only contains NULS, LF, and blanks, then
C               assume we found the end of file.  Otherwise report an error.
 
                endof=.true.
                do 10 i=1,80
                    ic=ichar(keybuf(i:i))
                    if (ic .ne. 0 .and .ic .ne. 10 .and. ic .ne. 32)
     &                 endof=.false.
10              continue
                if (endof)then
                     status=107
                     call ftpmsg('ASCII 0s, 10s, or 32s at start of '
     &             //'extension are treated as EOF (FTRHDU):')
                else
                     status=252
                     call ftpmsg('Extension does not start with SIMPLE'
     &               //' or XTENSION keyword (FTRHDU):')
                end if
                xtend=-1
                call ftpmsg(keybuf)
        end if
        end
        subroutine ftrsim(ounit,bitpix,naxis,naxes,status)
 
C       resize an existing primary array or IMAGE extension
 
C       ounit   i  fortran output unit number
C       bitpix  i  number of bits per data value
C       naxis   i  number of axes in the data array
C       naxes   i  array giving the length of each data axis
C       status  i  returned error status (0=ok)
 
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        integer ounit,bitpix,naxis,naxes(*),status
        integer i,bytlen,nblock,minax
        integer nsize,osize,obitpx,onaxis,onaxes(99),pcount,gcount
        logical simple,extend
        character*8 keynm
 
        if (status .gt. 0)return
 
        call ftghpr(ounit,99,simple,obitpx,onaxis,onaxes,
     &                    pcount,gcount,extend,status)
        if (status .gt. 0)return
 
C       check for error conditions
        if (naxis .lt. 0 .or. naxis .gt. 999)then
                status=212
               return
        end if
 
C       test that bitpix has a legal value and set the datatype code value
5       if (bitpix .eq. 8)then
                bytlen=1
        else if (bitpix .eq. 16)then
                bytlen=2
        else if (bitpix .eq. 32)then
                bytlen=4
        else if (bitpix .eq. -32)then
                bytlen=4
        else if (bitpix .eq. -64)then
                bytlen=8
        else
C               illegal value of bitpix
                status=211
                return
        end if
 
C       calculate the number of pixels in the new image
        if (naxis .eq. 0)then
C               no data
                nsize=0
        else
                nsize=1
                do 10 i=1,naxis
                        if (naxes(i) .ge. 0)then
                                nsize=nsize*naxes(i)
                        else
                                status=213
                                return
                        end if
10              continue
        end if
 
C       calculate the number of pixels in the old image
        if (onaxis .eq. 0)then
C               no data
                osize=0
        else
                osize=1
                do 15 i=1,onaxis
                        if (onaxes(i) .ge. 0)then
                                osize=osize*onaxes(i)
                        else
                                status=213
                                return
                        end if
15              continue
        end if
 
C       sizes of old and new images, in bytes
        osize=(osize+pcount) * gcount * abs(obitpx)/8
        nsize=(nsize+pcount) * gcount * bytlen
 
C       sizes of old and new images, in blocks
        osize=(osize+2879)/2880
        nsize=(nsize+2879)/2880
 
C       insert or delete blocks, as necessary
        if (nsize .gt. osize)then
             nblock=nsize-osize
             call ftiblk(ounit,nblock,1,status)
        else if (osize .gt. nsize)then
             nblock=osize-nsize
             call ftdblk(ounit,nblock,1,status)
        end if
        if (status .gt. 0)return
 
C       update the header keywords
 
        if (bitpix .ne. obitpx)then
            call ftmkyj(ounit,'BITPIX',bitpix,'&',status)
        end if
 
        if (naxis .ne. onaxis)then
            call ftmkyj(ounit,'NAXIS',naxis,'&',status)
        end if
 
C       update all the existing keywords
        minax=min(naxis,onaxis)
        do 20 i=1,minax
            call ftkeyn('NAXIS',i,keynm,status)
            call ftmkyj(ounit,keynm,naxes(i),'&',status)
20      continue
 
        if (naxis .gt. onaxis)then
C           insert more NAXISn keywords
            do 25 i=onaxis+1,naxis
                call ftkeyn('NAXIS',i,keynm,status)
                call ftikyj(ounit,keynm,naxes(i),
     &                      'length of data axis',status)
25          continue
        else if (onaxis .gt. naxis)then
C           delete old NAXISn keywords
            do 30 i=naxis+1,onaxis
                call ftkeyn('NAXIS',i,keynm,status)
                call ftdkey(ounit,keynm,status)
30          continue
        end if
 
C       re-read the header, to make sure structures are updated
        call ftrdef(ounit,status)
        end
        subroutine ftrsnm
 
C       simply reset the column names as undefined
C       this will force ftgcnn to read the column names from the
C       file the next time it is called
 
C       written by Wm Pence, HEASARC/GSFC, Feb 1995
 
        integer colpnt,untpnt
        common/ftname/colpnt,untpnt
 
        colpnt= -999
        untpnt=0
        end
        subroutine ftrwdn(iunit,frow,lrow,nshift,status)
 
C       shift rows in a table down by NROWS rows, inserting blank rows
 
C       iunit   i  Fortran I/O unit number
C       frow    i  rows *AFTER* this one are to be moved down
C       lrow    i  last row to be moved down (last row of the table)
C       nshift  i  how far to shift the rows
C       status  i  returned error status (0=ok)
 
        integer iunit,frow,lrow,nshift,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff(2)
        character*1 xdummy(20480)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,kshift,nchar,fchar,in,out,i,j,irow,tin,jrow
        integer lstptr,inptr,outptr,nseg
        character cfill*1
 
        if (status .gt. 0)return
 
C       don't have to do anything if inserting blank rows at end of the table
        if (frow .eq. lrow)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       select appropriate fill value
        if (hdutyp(ibuff) .eq. 1)then
C           fill  header or ASCII table with space
            cfill=char(32)
        else
C           fill image or bintable data area with Null (0)
            cfill=char(0)
        end if
 
C       how many rows will fit in the single buffer?
        kshift=2880/rowlen(ibuff)
 
C **********************************************************************
C       CASE #1: optimal case where the NSHIFT number of rows will all
C       fit in the 2880-byte work buffer simultaneously.  The rows can
C       be shifted down in one efficient pass through the table.
C **********************************************************************
        if (kshift .ge. nshift)then
 
C    Note: the f77 compiler with the -O flag on a linux PC gives
C    incorrect results with the following 2 lines:
C       kshift=nshift
C       nchar=kshift*rowlen(ibuff)
C    Apparently the compiler simply ignores the first statement
C    so kshift is left with it's old value when multipying times rowlen
 
        nchar=nshift*rowlen(ibuff)
        fchar=1
 
C       initialize the first buffer
        in=2
        out=1
 
        do 5 i=1,2880
            buff(1)(i:i)=cfill
5       continue
 
        do 10 irow=frow+1,lrow,nshift
 
C           read the row(s) to be shifted
            call ftgtbs(iunit,irow,fchar,nchar,buff(in),status)
 
C           overwrite these row(s) with the previous row(s)
            call ftptbs(iunit,irow,fchar,nchar,buff(out),status)
 
C           swap the input and output buffer pointers and move to next rows
            tin=in
            in=out
            out=tin
            jrow=irow
10      continue
 
C       write the last row(s) out
        irow=jrow+nshift
        nchar=(lrow-jrow+1)*rowlen(ibuff)
 
        call ftptbs(iunit,irow,fchar,nchar,buff(out),status)
        return
 
C **********************************************************************
C       CASE #2: One or more rows of the table will fit in the work buffer,
C       but cannot fit all NSHIFT rows in the buffer at once.  Note that
C       since we do not need 2 buffers, as in the previous case, we can
C       combine both buffers into one single 2880*2 byte buffer, to handle
C       wider tables.  This algorithm copies then moves blocks of contiguous
C       rows at one time, working upwards from the bottom of the table.
C **********************************************************************
        else if (rowlen(ibuff) .le. 5760)then
 
C       how many rows can we move at one time?
        kshift=5760/rowlen(ibuff)
        fchar=1
 
C       initialize pointers
        lstptr=lrow
        inptr=lrow-kshift+1
 
20      if (inptr .le. frow)inptr=frow+1
        nchar=(lstptr-inptr+1)*rowlen(ibuff)
        outptr=inptr+nshift
 
C       read the row(s) to be shifted
        call ftgtbs(iunit,inptr,fchar,nchar,buff,status)
 
C       write the row(s) to the new location
        call ftptbs(iunit,outptr,fchar,nchar,buff,status)
 
C       If there are more rows, update pointers and repeat
        if (inptr .gt. frow+1)then
            lstptr=lstptr-kshift
            inptr =inptr -kshift
            go to 20
        end if
 
C       initialize the buffer with the fill value
        do 25 i=1,5760
            buff(1)(i:i)=cfill
25      continue
 
C       fill the empty rows with blanks or nulls
        nchar=rowlen(ibuff)
        do 30 i=1,nshift
            outptr=frow+i
            call ftptbs(iunit,outptr,fchar,nchar,buff,status)
30      continue
        return
 
C **********************************************************************
C       CASE #3:  Cannot fit a whole row into the work buffer, so have
C       to move each row in pieces.
C **********************************************************************
        else
 
        nseg=(rowlen(ibuff)+5759)/5760
        nchar=5760
 
        do 60 j=1,nseg
            fchar=(j-1)*5760+1
            if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760
 
            do 40 i=lrow,frow+1,-1
C               read the row to be shifted
                call ftgtbs(iunit,i,fchar,nchar,buff,status)
 
C               write the row(s) to the new location
                call ftptbs(iunit,i+nshift,fchar,nchar,buff,status)
40          continue
 
C           initialize the buffer with the fill value
            do 45 i=1,5760
                buff(1)(i:i)=cfill
45          continue
 
C           fill the empty rows with blanks or nulls
            do 50 i=1,nshift
                outptr=frow+i
                call ftptbs(iunit,outptr,fchar,nchar,buff,status)
50          continue
60      continue
 
        end if
        end
        subroutine ftrwup(iunit,frow,lrow,nshift,status)
 
C       shift rows in a table up by NROWS rows, overwriting the rows above
 
C       iunit   i  Fortran I/O unit number
C       frow    i  first row to be moved up
C       lrow    i  last row to be moved up (last row of the table)
C       nshift  i  how far to shift the rows (number of rows)
C       status  i  returned error status (0=ok)
 
        integer iunit,frow,lrow,nshift,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character*5760 buff
        character*1 xdummy(26240)
        common/ftheap/buff,xdummy
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,kshift,nchar,fchar,i,j
        integer lstptr,inptr,outptr,nseg
        character cfill*1
 
        if (status .gt. 0)return
 
C       define the number of the buffer used for this file
        ibuff=bufnum(iunit)
 
C       select appropriate fill value
        if (hdutyp(ibuff) .eq. 1)then
C           fill  header or ASCII table with space
            cfill=char(32)
        else
C           fill image or bintable data area with Null (0)
            cfill=char(0)
        end if
 
C **********************************************************************
C       CASE #1: One or more rows of the table will fit in the work buffer,
C **********************************************************************
        if (rowlen(ibuff) .le. 5760)then
 
C       how many rows can we move at one time?
        kshift=5760/rowlen(ibuff)
        fchar=1
 
C       check if we just need to clear the last NSHIFT rows of the table
        if (frow .eq. lrow+1)go to 25
 
C       initialize pointers
        inptr=frow
        lstptr=inptr+kshift-1
 
20      if (lstptr .gt. lrow)lstptr=lrow
        nchar=(lstptr-inptr+1)*rowlen(ibuff)
        outptr=inptr-nshift
 
C       read the row(s) to be shifted
        call ftgtbs(iunit,inptr,fchar,nchar,buff,status)
 
C       write the row(s) to the new location
        call ftptbs(iunit,outptr,fchar,nchar,buff,status)
 
C       If there are more rows, update pointers and repeat
        if (lstptr .lt. lrow)then
            inptr =inptr +kshift
            lstptr=lstptr+kshift
            go to 20
        end if
 
C       initialize the buffer with the fill value
25      continue
        do 30 i=1,5760
            buff(i:i)=cfill
30      continue
 
C       fill the empty rows at the bottom of the table with blanks or nulls
        nchar=rowlen(ibuff)
        do 35 i=1,nshift
            outptr=lrow-nshift+i
            call ftptbs(iunit,outptr,fchar,nchar,buff,status)
35      continue
        return
 
C **********************************************************************
C       CASE #2:  Cannot fit a whole row into the work buffer, so have
C       to move each row in pieces.
C **********************************************************************
        else
 
        nseg=(rowlen(ibuff)+5759)/5760
        nchar=5760
 
        do 60 j=1,nseg
            fchar=(j-1)*5760+1
            if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760
 
C           check if we just need to clear the last NSHIFT rows of the table
            if (frow .eq. lrow+1)go to 45
 
            do 40 i=frow,lrow
C               read the row to be shifted
                call ftgtbs(iunit,i,fchar,nchar,buff,status)
 
C               write the row(s) to the new location
                call ftptbs(iunit,i-nshift,fchar,nchar,buff,status)
40          continue
 
C           initialize the buffer with the fill value
45          continue
            do 50 i=1,5760
                buff(i:i)=cfill
50          continue
 
C           fill the empty rows with blanks or nulls
            do 55 i=1,nshift
                outptr=lrow-nshift+i
                call ftptbs(iunit,outptr,fchar,nchar,buff,status)
55          continue
60      continue
        end if
        end
        subroutine fts2c(in,cval,lenval,status)
C       convert an input string to a left justified quoted string
C               The minimum length FITS string is 8 characters, so
C               pad the quoted string with spaces if necessary.
C       cval = returned quoted string
C       lenval = length of the cval string, including the 2 quote characters
        character*(*) in,cval
        integer length,i,j,i1,i2,lenval,status
 
        if (status .gt. 0)return
 
        i1=1
        i2=1
C       test for blank input string
        if (in .eq. ' ')then
                cval='''        '''
                lenval=10
                return
        end if
 
        length=len(in)
C       find first and last non-blank characters
 
C       modified 29 Nov 1994 to treat leading spaces as significant
C        do 5 i=1,length
C                i1=i
C                if (in(i:i) .ne. ' ')go to 10
C5       continue
C10      continue
 
        do 15 i=length,1,-1
                i2=i
                if (in(i:i) .ne. ' ')go to 20
15      continue
20      continue
 
        cval=''''//in(i1:i2)
 
C       test if there are any single quotes in the string;  if so, replace
C       them with two successive single quotes
        lenval=i2-i1+2
        do 30 i=lenval,2,-1
                if (cval(i:i) .eq. '''')then
C                  shift all the characters over 1 space
                   do 40 j=len(cval),i+1,-1
                      cval(j:j)=cval(j-1:j-1)
40                 continue
                   i2=i2+1
                end if
30      continue
 
C       find location of closing quote
        lenval=max(10,i2-i1+3)
        lenval=min(lenval,len(cval))
        if (lenval .eq. 70 .and. cval(69:70) .eq. '''''')then
C           this occurs if the string ends with a literal appostrophy
            cval(70:70) = ' '
        else
            cval(lenval:lenval)=''''
        end if
        end
        subroutine ftsdnn(value)
 
C       set a 64-bit pattern equal to an IEEE Not-a-Number value
C       A NaN has all the exponent bits=1, and the fractional part
C       not=0.
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        integer value(2)
 
C       there are many NaN values;  choose a simple one in which all bits=1
        value(1)=-1
        value(2)=-1
        end
        subroutine ftsnul(ounit,colnum,nulval,status)
 
C       ascii table Column NULl value definition
C       Define the null value for an ASCII table column.
C
C       ounit   i  Fortran I/O unit number
C       colnum  i  number of the column to be defined
C       nulval  c  the string to be use to signify undefined data
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,status
        character*(*) nulval
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
        character cnull*16, cform*8
        common/ft0003/cnull(nf),cform(nf)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
        if (status .gt. 0)return
 
C       test for proper HDU type
        if (hdutyp(ibuff) .ne. 1)then
            status=226
            return
        end if
 
        if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then
             status=302
             return
        end if
 
        cnull(colnum+tstart(ibuff))=nulval
        end
        subroutine ftsrnn(value)
 
C       set a 32-bit pattern equal to an IEEE Not-a-Number value
C       A NaN has all the exponent bits=1, and the fractional part
C       not=0.
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer value
 
C       there are many NaN values;  choose a simple one in which all bits=1
        value=-1
        end
        subroutine ftswby(buffer,npix)
C
C       swap pairs of bytes to convert I*2 values to/from IEEE
C
C       buffer  i  input buffer of 16-bit words to be swapped
C       npix    i  number of 16-bit words to be swapped
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        integer npix,k
        logical*1 buffer(npix*2),temp
 
        do 10 k=2,npix*2,2
           temp = buffer(k-1)
           buffer(k-1) = buffer(k)
           buffer(k) = temp
10      continue
        end
        subroutine ftswi4(buffer,npix)
C
C       swap 4 successive bytes in values to convert to/from IEEE.
C               if the original byte order is: 1 2 3 4
C               the output order is:           4 3 2 1
C
C       buffer  i  input buffer of bytes to be swapped
C       npix    i  number of 4 bytes-words to be swapped
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996
 
C  The equivalence statements in this algorithm cause errors with
C  the Linux NAG F90 compiler.
C        integer npix, i
C        integer buffer(npix)
C        integer*4 temp1,temp2
C        logical*1 l1(4), l2(4)
C        equivalence (temp1,l1)
C        equivalence (temp2,l2)
C
C        do 10 i=1,npix
C            temp1=buffer(i)
C            l2(4)=l1(1)
C            l2(3)=l1(2)
C            l2(2)=l1(3)
C            l2(1)=l1(4)
C            buffer(i)=temp2
C10      continue
 
C       alternate swapping algorithm, Wm Pence, April 97
        integer npix,i4
        logical*1 buffer(npix*4),temp
 
        do 10 i4=4,npix*4,4
 
C          swap 1st and 4th bytes
           temp=buffer(i4-3)
           buffer(i4-3)=buffer(i4)
           buffer(i4)=temp
 
C          swap 2nd and 3rd bytes
           temp=buffer(i4-2)
           buffer(i4-2)=buffer(i4-1)
           buffer(i4-1)=temp
 
10      continue
 
        end
        subroutine ftswi8(buffer,npix)
C
C       swap 8 successive bytes in values to convert to/from IEEE.
C               if the original byte order is: 1 2 3 4 5 6 7 8
C               the output order is:           8 7 6 5 4 3 2 1
C
C       buffer  i  input buffer of bytes to be swapped
C       npix    i  number of 8 bytes-words to be swapped
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996
 
C  The equivalence statements in this algorithm cause errors with
C  the Linux NAG F90 compiler.
C        integer npix, i
C        double precision buffer(npix),temp1,temp2
C        logical*1 l1(8), l2(8)
C        equivalence (temp1,l1)
C        equivalence (temp2,l2)
C
C        do 10 i=1,npix
C            temp1=buffer(i)
C            l2(8)=l1(1)
C            l2(7)=l1(2)
C            l2(6)=l1(3)
C            l2(5)=l1(4)
C            l2(4)=l1(5)
C            l2(3)=l1(6)
C            l2(2)=l1(7)
C            l2(1)=l1(8)
C            buffer(i)=temp2
C10      continue
 
C       alternate swapping algorithm, Wm Pence, April 97
        integer npix,i8
        logical*1 buffer(npix*8),temp
 
        do 10 i8=8,npix*8,8
 
C          swap 1st and 8th bytes
           temp=buffer(i8-7)
           buffer(i8-7)=buffer(i8)
           buffer(i8)=temp
 
C          swap 2nd and 7th bytes
           temp=buffer(i8-6)
           buffer(i8-6)=buffer(i8-1)
           buffer(i8-1)=temp
 
C          swap 3rd and 6th bytes
           temp=buffer(i8-5)
           buffer(i8-5)=buffer(i8-2)
           buffer(i8-2)=temp
 
C          swap 4th and 5th bytes
           temp=buffer(i8-4)
           buffer(i8-4)=buffer(i8-3)
           buffer(i8-3)=temp
10      continue
        end
        subroutine fttbit(bitpix,status)
 
C       test that bitpix has a legal value
 
        integer bitpix,status
        character value*20
 
        if (status .gt. 0)return
 
        if (bitpix .ne. 8 .and. bitpix .ne. 16 .and. bitpix .ne. 32
     &      .and. bitpix .ne. -32 .and. bitpix .ne. -64)then
                status=211
                write(value,1000)bitpix
1000            format(i20)
                call ftpmsg('Illegal BITPIX value: '//value)
        end if
        end
        logical function fttdnn(value)
 
C       test if a R*8 value has a IEEE Not-a-Number value
C       A NaN has all the exponent bits=1, and the fractional part
C       not=0.
C       Exponent field is in bits 20-30 in the most significant 4-byte word
C       Mantissa field is in bits 0-19 of most sig. word and entire 2nd word
C
C       written by Wm Pence, HEASARC/GSFC, May 1992
C       modified Aug 1994 to handle all IEEE special values.
 
        integer value(2)
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer compid
        common/ftcpid/compid
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer word1,word2
C       COMPID specifies what type of floating point word structure
C       is used on this machine, and determines how to test for NaNs.
 
C       COMPID value:
C          2 or 3    generic machine: simply test for NaNs with all bits set
C           1        like a decstation or alpha OSF/1, or IBM PC
C           0        SUN workstation, or IBM mainframe
C          -2305843009213693952   Cray (64-bit) machine
 
        fttdnn=.false.
        if (compid .ge. 2)then
C           on the VAX we can assume that all NaNs will be set to all bits on
C           (which is equivalent to an integer with a value of -1) because
C           this is what the IEEE to VAX conversion MACRO program returns
            if (value(1) .eq. -1 .and. value(2) .eq. -1)fttdnn=.true.
        else if (compid .ge. -1)then
            if (compid .le. 0)then
C               this is for SUN-like machines, or IBM main frames
                word1=value(1)
                word2=value(2)
            else
C               this is for DECstation and IBM PCs.  The 2 32 bit integer words
C               are reversed from what you get on the SUN.
                word1=value(2)
                word2=value(1)
            end if
 
C           efficiently search the number space for NaNs and underflows
            if (word2 .eq. -1)then
                if ((word1 .ge. -1048577 .and. word1 .le. -1)
     &           .or. (word1 .ge. 2146435071))then
                      fttdnn=.true.
                else if ((word1 .lt. -2146435072) .or.
     &          (word1 .ge. 0 .and. word1 .lt. 1048576))then
                      value(1)=0
                      value(2)=0
                end if
             else if (word2 .eq. 0)then
                if ((word1 .gt. -1048577 .and. word1 .le. -1)
     &           .or. (word1 .gt. 2146435071))then
                      fttdnn=.true.
                else if ((word1 .le. -2146435072) .or.
     &          (word1 .ge. 0 .and. word1 .le. 1048576))then
                      value(1)=0
                      value(2)=0
                end if
             else
                if ((word1 .gt. -1048577 .and. word1 .le. -1)
     &           .or. (word1 .gt. 2146435071))then
                      fttdnn=.true.
                else if ((word1 .lt. -2146435072) .or.
     &          (word1 .ge. 0 .and. word1 .lt. 1048576))then
                      value(1)=0
                      value(2)=0
                end if
             end if
        else
C           branch for the Cray:  COMPID stores the negative integer
C           which corresponds to the 3 most sig digits set to 1.   If these
C           3 bits are set in a floating point number, then it represents
C           a reserved value (i.e., a NaN)
            if (value(1).lt. 0 .and. value(1) .ge. compid)fttdnn=.true.
        end if
        end
        subroutine fttkey(keynam,status)
 
C       test that keyword name contains only legal characters:
C         uppercase letters, numbers, hyphen, underscore, or space
C         (but no embedded spaces)
 
C       keynam  c*8  keyword name
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
 
        character keynam*(*)
        integer status,i
        character*1 c1,pos
        logical spaces
 
        if (status .gt. 0)return
 
        spaces=.false.
        do 20 i=1,8
            c1=keynam(i:i)
            if ((c1 .ge. 'A' .and. c1 .le. 'Z') .or.
     &          (c1 .ge. '0' .and. c1 .le. '9') .or.
     &           c1 .eq. '-' .or. c1 .eq. '_')then
                 if (spaces)then
C                   error: name contains embedded space
                    status=207
                    call ftpmsg('Keyword name contains embedded '//
     &              'space(s): '//keynam(1:8))
                    return
                 end if
            else if (c1 .eq. ' ')then
                 spaces=.true.
            else
C                illegal character found
                 status=207
                 write(pos,1000)i
1000             format(i1)
                 call ftpmsg('Character '//pos//' in this keyword name'
     &           //' is illegal: "'//keynam(1:8)//'"')
C                explicitly test for the 2 most common cases:
                 if (ichar(c1) .eq. 0)then
                   call ftpmsg('(This is an ASCII NUL (0) character).')
                 else if (ichar(c1) .eq. 9)then
                   call ftpmsg('(This is an ASCII TAB (9) character).')
                 end if
                 return
            end if
20      continue
        end
        subroutine fttkyn(iunit,nkey,keynam,keyval,status)
 
C       test that the keyword number NKEY has name = KEYNAM
C       and has value = KEYVAL
C
C       iunit   i  Fortran I/O unit number
C       nkey    i  sequence number of the keyword to test
C       keynam  c  name that the keyword is supposed to have
C       keyval  c  value that the keyword is supposed to have
C       OUTPUT PARAMETERS:
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
C
        integer iunit,nkey,status
        character*(*) keynam,keyval
        character kname*8,value*30,comm*48,npos*8,keybuf*80
        character errmsg*80
 
        if (status .gt. 0)return
 
C       read the name and value of the keyword
 
C       get the whole record
        call ftgrec(iunit,nkey,keybuf,status)
 
        kname=keybuf(1:8)
C       parse the value and comment fields from the record
        call ftpsvc(keybuf,value,comm,status)
        if (status .gt. 0)go to 900
 
C       test if the keyword has the correct name
        if (kname .ne. keynam)then
                status=208
                go to 900
        end if
 
C       check that the keyword has the correct value
        if (value .ne. keyval)then
                status=209
        end if
 
900     continue
        if (status .gt. 0)then
 
            write(npos,1000)nkey
1000        format(i8)
            errmsg='FTTKYN found unexpected keyword or value '//
     &      'for header keyword number '//npos//'.'
            call ftpmsg(errmsg)
            errmsg='  Was expecting keyword '//keynam//
     &      ' with value = '//keyval
            call ftpmsg(errmsg)
            if (keybuf(9:10) .ne. '= ')then
              errmsg='      but found keyword '//kname//
     &      ' with no "= " in cols. 9-10.'
            else
              errmsg='      but found keyword '//kname//
     &      ' with value = '//value
            end if
            call ftpmsg(errmsg)
            call ftpmsg(keybuf)
        end if
        end
        subroutine fttnul(ounit,colnum,inull,status)
 
C       Table column NULl value definition
C       Define the null value for a table column
C
C       ounit   i  Fortran I/O unit number
C       colnum  i  number of the column to be defined
C       inull   i  the value to be use to signify undefined data
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,inull,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
        if (status .gt. 0)return
 
C       test for proper HDU type
        if (hdutyp(ibuff) .eq. 0)then
            status=235
            return
        end if
 
        if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then
             status=302
             return
        end if
 
        tnull(colnum+tstart(ibuff))=inull
        end
        subroutine fttrec(string,status)
 
C       test the remaining characters in a header record to insure that
C       it contains only pri-ntable ASCII characters,
C       i.e., with ASCII codes greater than or equal to 32 (a blank)
C       and less than or equal to 126 (tilda).
 
C       Note: this will not detect the delete character (ASCII 127)
C       because of the difficulties in also supporting this check
C       on IBM mainframes, where the collating sequence is entirely
C       different.
 
C       Dec 1996:  since support for non-ASCII character sets has
C       been dropped, the test for characters greater than 126
C       has been restated.
 
C       string  c*72 keyword record
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
 
C       optimized in 7/93 to compare "ichar(string(i:i)) .lt. space"
C       rather than                       "(string(i:i)) .lt. ' ' "
C       This is much faster on SUNs and DECstations,
C       and decreases the time needed to write a keyword (ftprec) by 10%.
C       This change made no difference on a VAX
 
        integer space,tilda
C       the following 2 lines are only correct for machines that use ASCII
        parameter (space = 32)
        parameter (tilda = 126)
        character string*(*)
        integer status,i
        character pos*2
 
        if (status .gt. 0)return
 
        do 20 i=1,72
            if (ichar(string(i:i)) .lt. space .or.
     &          ichar(string(i:i)) .gt. tilda) then
C                 illegal character found
                  status=207
                  write(pos,1000)i
1000              format(i2)
        call ftpmsg('Character #'//pos//' in this keyword value or '//
     &  'comment string is illegal:')
        call ftpmsg(string)
                  return
            end if
20      continue
        end
        logical function fttrnn(value)
 
C       test if a R*4 value has a IEEE Not-a-Number (NaN) value
C       A NaN has all the exponent bits=1, and the fractional part not=0.
C       The exponent field occupies bits 23-30,  (least significant bit = 0)
C       The mantissa field occupies bits 0-22
 
C       This routine also sets any underflow values to zero.
 
C       written by Wm Pence, HEASARC/GSFC, May 1992
C       modified Aug 1994 to handle all IEEE special values.
 
        integer value
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer compid
        common/ftcpid/compid
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
C       COMPID specifies what type of floating point word structure
C       is used on this machine, and determines how to test for NaNs.
 
C       COMPID value:
C         2 or 3 VAX or generic machine: simply test for NaNs with all bits set
C           1   like a decstation or alpha OSF/1, or IBM PC
C           0   SUN workstation, or IBM mainframe
C          -2305843009213693952   Cray (64-bit) machine
 
        fttrnn=.false.
        if (compid .ge. 2)then
C           on the VAX we can assume that all NaNs will be set to all bits on
C           (which is equivalent to an integer with a value of -1) because
C           this is what the IEEE to VAX conversion MACRO program returns
            if (value .eq. -1)fttrnn=.true.
        else if (compid .ge. -1)then
C           the following test works on all other machines (except Cray)
C           the sign bit may be either 1 or 0 so have to test both possibilites.
C           Note: overflows and infinities are also flagged as NaNs.
            if (value .ge. 2139095039 .or. (value .lt. 0 .and.
     1             value .ge. -8388609))then
                   fttrnn=.true.
            else if ((value .gt. 0 .and. value .le. 8388608) .or.
     1             value .le. -2139095040)then
C                  set underflows and denormalized values to zero
                   value=0
            end if
        else
C           branch for the Cray:  COMPID stores the negative integer
C           which corresponds to the 3 most sig digits set to 1.   If these
C           3 bits are set in a floating point number, then it represents
C           a reserved value (i.e., a NaN)
            if (value .lt. 0 .and. value .ge. compid)fttrnn=.true.
        end if
        end
        subroutine fttscl(ounit,colnum,bscale,bzero,status)
 
C       Table column SCaLing factor definition
C       Define the scaling factor for a table column.
C
C       ounit   i  Fortran I/O unit number
C       colnum  i  number of the column to be defined
C       bscale  d  scaling factor
C       bzero   d  scaling zero point
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        integer ounit,colnum,status
        double precision bscale,bzero
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne,nf
        parameter (nb = 20)
        parameter (ne = 512)
        parameter (nf = 3000)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
        if (status .gt. 0)return
 
        if (bscale .eq. 0.)then
C               illegal bscale value
                status=322
                return
        end if
 
        ibuff=bufnum(ounit)
 
C       if HDU structure is not defined then scan the header keywords
        if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status)
        if (status .gt. 0)return
 
C       test for proper HDU type
        if (hdutyp(ibuff) .eq. 0)then
            status=235
            return
        end if
 
        if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then
             status=302
             return
        end if
 
        tscale(colnum+tstart(ibuff))=bscale
        tzero(colnum+tstart(ibuff))=bzero
        end
        subroutine ftucks(iunit,status)
 
C       Update the CHECKSUM keyword value.  This assumes that the DATASUM
C       keyword exists and has the correct value.
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, May, 1995
 
        integer iunit,status
 
C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nf = 3000)
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz
        integer theap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb)
     &  ,theap(nb)
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        double precision sum,dsum
        integer ibuff,nrec,dd,mm,yy,i,tstat
        character datstr*8,string*16,comm*40,datsum*20,oldcks*16
        logical complm
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       get the DATASUM keyword value
        call ftgkys(iunit,'DATASUM',datsum,comm,status)
        if (status .eq. 202)then
             call ftpmsg('DATASUM keyword not found (FTUCKS)')
             return
        end if
 
C       decode the datasum string into a double precision variable
        do 10 i=1,20
            if (datsum(i:i) .ne. ' ')then
                call ftc2dd(datsum(i:20),dsum,status)
                go to 15
            end if
10      continue
        dsum=0.
 
C       generate current date string to put into the keyword comment
15      call ftgsdt(dd,mm,yy,status)
        if (status .gt. 0)return
 
        datstr='  /  /  '
        write(datstr(1:2),1001)dd
        write(datstr(4:5),1001)mm
        write(datstr(7:8),1001)yy
1001    format(i2)
 
C       replace blank with leading 0 in each field if required
        if (datstr(1:1) .eq. ' ')datstr(1:1)='0'
        if (datstr(4:4) .eq. ' ')datstr(4:4)='0'
        if (datstr(7:7) .eq. ' ')datstr(7:7)='0'
 
C       get the CHECKSUM keyword value if it exists
        tstat=status
        call ftgkys(iunit,'CHECKSUM',oldcks,comm,status)
        if (status .eq. 202)then
          status=tstat
          oldcks='0000000000000000'
          comm='encoded HDU checksum updated on '//datstr
          call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status)
        end if
 
C       rewrite the header END card, and following blank fill
        call ftwend(iunit,status)
        if (status .gt. 0)return
 
C       move to the start of the header
        call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status)
 
C       accumulate the header checksum into the previous data checksum
        nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880
        sum=dsum
        call ftcsum(iunit,nrec,sum,status)
 
C       encode the COMPLEMENT of the checksum into a 16-character string
        complm=.true.
        call ftesum(sum,complm,string)
 
C       return if the checksum is correct
        if (string .eq. '0000000000000000')return
 
        if (oldcks .eq. '0000000000000000')then
C               update the CHECKSUM keyword value with the checksum string
                call ftmkys(iunit,'CHECKSUM',string,'&',status)
        else
 
C           Zero the checksum and compute the new value
            comm='encoded HDU checksum updated on '//datstr
            call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status)
 
C           move to the start of the header
            call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status)
 
C           accumulate the header checksum into the previous data checksum
            sum=dsum
            call ftcsum(iunit,nrec,sum,status)
 
C           encode the COMPLEMENT of the checksum into a 16-character string
            complm=.true.
            call ftesum(sum,complm,string)
 
C           update the CHECKSUM keyword value with the checksum string
            call ftmkys(iunit,'CHECKSUM',string,'&',status)
        end if
        end
        subroutine ftucrd(ounit,keywrd,card,status)
 
C       update a 80-character FITS header card/record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       card    c  80-character FITS card image
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, May 1995
 
        character*(*) keywrd,card
        integer ounit,status,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the card, if it exists
        call ftmcrd(ounit,keywrd,card,status)
 
        if (status .eq. 202)then
C               card doesn't exist, so create it
                status=tstat
                call ftprec(ounit,card,status)
        end if
        end
        subroutine ftukyd(ounit,keywrd,dval,decim,comm,status)
 
C       update a double precision value header record in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (max. 47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyd(ounit,keywrd,dval,decim,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyd(ounit,keywrd,dval,decim,comm,status)
        end if
        end
        subroutine ftukye(ounit,keywrd,rval,decim,comm,status)
 
C       update a real*4 value header record in E format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkye(ounit,keywrd,rval,decim,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkye(ounit,keywrd,rval,decim,comm,status)
        end if
        end
        subroutine ftukyf(ounit,keywrd,rval,decim,comm,status)
 
C       update a real*4 value header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       rval    r  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        real rval
        integer ounit,status,decim,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyf(ounit,keywrd,rval,decim,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyf(ounit,keywrd,rval,decim,comm,status)
        end if
        end
        subroutine ftukyg(ounit,keywrd,dval,decim,comm,status)
 
C       update a double precision value header record in F format
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       dval    d  keyword value
C       decim   i  number of decimal places to display in value field
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        double precision dval
        integer ounit,status,decim,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyg(ounit,keywrd,dval,decim,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyg(ounit,keywrd,dval,decim,comm,status)
        end if
        end
        subroutine ftukyj(ounit,keywrd,intval,comm,status)
 
C       update an integer value header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       intval  i  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        integer ounit,status,intval,tstat
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyj(ounit,keywrd,intval,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyj(ounit,keywrd,intval,comm,status)
        end if
        end
        subroutine ftukyl(ounit,keywrd,logval,comm,status)
 
C       update a logical value header record
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       logval  l  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,comm
        integer ounit,status,tstat
        logical logval
 
        if (status .gt. 0)return
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyl(ounit,keywrd,logval,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyl(ounit,keywrd,logval,comm,status)
        end if
        end
        subroutine ftukys(ounit,keywrd,strval,comm,status)
 
C       update a character string value header record
 
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       strval  c  keyword value
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS:
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Oct 1994
 
        character*(*) keywrd,strval,comm
        integer ounit,status,tstat
 
        if (status .gt. 0)return
 
        tstat=status
C       try modifying the keyword, if it exists
        call ftmkys(ounit,keywrd,strval,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
C               note that this supports the HEASARC long-string conventions
                call ftpkls(ounit,keywrd,strval,comm,status)
        end if
        end
        subroutine ftukyu(ounit,keywrd,comm,status)
 
C       update a null-valued keyword
C
C       ounit   i  fortran output unit number
C       keywrd  c  keyword name    ( 8 characters, cols.  1- 8)
C       comm    c  keyword comment (47 characters, cols. 34-80)
C       OUTPUT PARAMETERS
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, July 1997
 
        character*(*) keywrd,comm
        integer ounit,status,tstat
 
        if (status .gt. 0)return
 
        tstat=status
 
C       try modifying the keyword, if it exists
        call ftmkyu(ounit,keywrd,comm,status)
 
        if (status .eq. 202)then
C               keyword doesn't exist, so create it
                status=tstat
                call ftpkyu(ounit,keywrd,comm,status)
        end if
        end
        subroutine ftupch(string)
 
C       convert input string to upper case
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
C       modified 7/93 to use ichar comparisons, to improve performance
 
        character*(*) string
        integer i,length
        integer a,z
 
        a=ichar('a')
        z=ichar('z')
 
        length=len(string)
        do 10 i=1,length
                if   (ichar(string(i:i)) .ge. a
     1          .and. ichar(string(i:i)) .le. z)then
                        string(i:i)=char(ichar(string(i:i))-32)
                end if
10      continue
        end
        subroutine ftupi2(i2vals,nvals,temp)
 
C       unpack array of 2-byte integers into 4-integers
C       This routine is only currently used on the SUN Solaris F90
C       which does not directly support integer*2 variables and instead
C       maps them into integer*4 variables.
 
        integer nvals,ii,jj
        integer*2 temp
        character*1 i2vals(nvals*4),zero,neg,pos
 
        zero = char(0)
C       neg is use to extend the sign bit if the value is negative
        neg  = char(255)
        pos  = char(127)
 
        jj=nvals*4
        do 10 ii = nvals*2,2,-2
             i2vals(jj)=i2vals(ii)
             i2vals(jj-1)=i2vals(ii - 1)
 
C            fill in the 2 most-significant bytes
             if (i2vals(jj-1) .le. pos)then
                 i2vals(jj-2)=zero
                 i2vals(jj-3)=zero
             else
                 i2vals(jj-2)=neg
                 i2vals(jj-3)=neg
             end if
             jj=jj-4
10      continue
        end
        subroutine ftuptf(iunit,status)
 
C       Update the value of the TFORM keywords for the variable length array
C       columns to make sure they all have the form 1Pt(len) or Pt(len)
C       where 'len' is the maximum length of the vector in the table (e.g.,
C       '1PE(400)')
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Jan, 1997
 
        integer iunit,status
 
        integer ii,tflds,naxis2,maxlen,jj,length,addr,endpos,cpos
        character comment*80, keynam*8,tform*40,newfrm*40
        character message*80,lenstr*20
 
        call ftgkyj(iunit,'TFIELDS', tflds, comment, status)
        call ftgkyj(iunit,'NAXIS2', naxis2, comment, status)
 
        do 100 ii = 1,tflds
           call ftkeyn('TFORM',ii,keynam,status)
           call ftgkys(iunit,keynam,tform,comment,status)
 
           if (status .gt. 0)then
               message='Error while updating variable length TFORMn '//
     &         'values (ftuptf)'
               call ftpmsg(message)
           end if
 
C          test if this is a variable length array column
           if (tform(1:1) .eq. 'P' .or. tform(2:2) .eq. 'P')then
 
C             test if the length field is missing
              if (tform(5:5) .eq. ' ')then
 
                 maxlen = 0
                 do 50 jj=1,naxis2
                    call ftgdes(iunit,ii,jj,length,addr,status)
                    maxlen = max(maxlen,length)
50               continue
 
                 if (tform(1:1) .eq. 'P')then
                    endpos=3
                 else
                    endpos=4
                 end if
 
C                convert integer to C*20 string, and find first digit
                 call fti2c(maxlen,lenstr,status)
                 do 60 jj = 1, 20
                    cpos = jj
                    if (lenstr(cpos:cpos) .ne. ' ')go to 70
60               continue
 
C                construct new keyword value
70               newfrm=tform
                 newfrm(endpos:)='('//lenstr(cpos:20)//')'
 
C                now modify the old TFORMn keyword
                 call ftmkys(iunit,keynam,newfrm,comment,status)
              end if
           end if
100     continue
        end
        subroutine ftuscc(input,np,scaled,scale,zero,output)
 
C       unscale the array of complex numbers, prior to writing to the FITS file
 
C       input  r  array of complex numbers (pairs of real/imaginay numbers)
C       np     i  total number of values to scale (no. of pairs times 2)
C       scaled l  is the data scaled?
C       scale  d  scale factor
C       zero   d  offset
C       output r  output array
 
        integer np,i,j
        logical scaled
        real input(np),output(np)
        double precision scale,zero
 
        j=1
        if (scaled)then
            do 10 i=1,np/2
                output(j)=(input(j)-zero)/scale
                j=j+1
C               the imaginary part of the number is not offset!!
                output(j)=input(j)/scale
                j=j+1
10          continue
        else
            do 20 i=1,np
                output(i)=input(i)
20          continue
        end if
        end
        subroutine ftuscm(input,np,scaled,scale,zero,output)
 
C       unscale the array of complex numbers, prior to writing to the FITS file
 
C       input  d  array of complex numbers (pairs of real/imaginay numbers)
C       np     i  total number of values to scale (no. of pairs times 2)
C       scaled l  is the data scaled?
C       scale  d  scale factor
C       zero   d  offset
C       output d  output array
 
        integer np,i,j
        logical scaled
        double precision input(np),output(np)
        double precision scale,zero
 
        j=1
        if (scaled)then
            do 10 i=1,np/2
                output(j)=(input(j)-zero)/scale
                j=j+1
C               the imaginary part of the number is not offset!!
                output(j)=input(j)/scale
                j=j+1
10          continue
        else
            do 20 i=1,np
                output(i)=input(i)
20          continue
        end if
        end
        subroutine ftvcks(iunit,dataok,hduok,status)
 
C       Verify the HDU by comparing the value of the computed checksums against
C       the values of the DATASUM and CHECKSUM keywords if they are present.
 
C       iunit   i  fortran unit number
C       dataok  i  output verification code for the data unit alone
C       hduok   i  output verification code for the entire HDU
C                  the code values = 1  verification is correct
C                                  = 0  checksum keyword is not present
C                                  = -1 verification not correct
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Dec, 1994
 
        integer iunit,dataok,hduok,status,tstat,i
        double precision datsum,chksum,dsum
        character keyval*20,comm*8
        logical cexist,dexist
 
        if (status .gt. 0)return
 
C       check if the CHECKSUM keyword exists
        tstat=status
        call ftgkys(iunit,'CHECKSUM',keyval,comm,status)
        if (status .le. 0)then
            cexist=.true.
        else
            hduok=0
            cexist=.false.
            status=tstat
        end if
 
C       check if the DATASUM keyword exists and get its value
        call ftgkys(iunit,'DATASUM',keyval,comm,status)
        if (status .le. 0)then
            dexist=.true.
        else
            dataok=0
            dexist=.false.
            status=tstat
        end if
 
C       return if neither keyword exists
        if (.not. cexist .and. .not. dexist)return
 
C       calculate the data checksum and the HDU checksum
        call ftgcks(iunit,datsum,chksum,status)
        if (status .gt. 0)return
 
        if (dexist)then
 
C           decode the datasum string into a double precision variable
            do 10 i=1,20
                if (keyval(i:i) .ne. ' ')then
                    call ftc2dd(keyval(i:20),dsum,status)
                    if (status .eq. 409)then
C                       couldn't read the keyword; assume it is out of date
                        status=tstat
                        dsum=-1.
                    end if
                    go to 15
                end if
10          continue
            dsum=0.
15          continue
 
            if (dsum .eq. datsum)then
                dataok=1
            else
                dataok=-1
            end if
        end if
 
        if (cexist)then
            if (chksum .eq. 0 .or. chksum .eq. 4.294967295D+09)then
                hduok=1
            else
                hduok=-1
            end if
        end if
        end
        subroutine ftvers(vernum)
 
C       Returns the current revision number of the FITSIO package.
C       The revision number will be incremented whenever any modifications,
C       bug fixes, or enhancements are made to the package
 
        real vernum
 
        vernum=5.03
 
C       version 5.03    1 Aug   1997   null keywords; keyword units
C       version 5.02   11 Apr   1997   F90 portability modifications
C       version 5.01    8 Apr   1997   OK if nelems = 0 when accessing tables
C       version 5.00   21 Mar   1997   Major overhaul:
C                                      more efficient; F90-compatible
C       version 4.14   13 Aug   1996   initialize lenval in ftdkey; check for
C                                      valid unit number in ftclos
C       version 4.13   22 Mar   1996   add ftflus; prevent duplicate header
C                                      keyword in ftphpr, ftphtb, and ftphbn
C       version 4.12   28 Feb   1996   added fticls subroutine
C       version 4.11    8 Feb   1996   add calls to ftrdef in ftptbb and ftptbs
C                                      bug in ftdrow
C       version 4.10    1 Dec   1995   fixed pattern matching bugs in ftcmps;
C       version 4.09    8 Nov   1995   don't update header pointer in ftprec;
C                                      open blocksize optimized in fitsvax.f
C       version 4.08    3 Oct   1995   bug in ftiimg: data offset by 8 bytes
C       version 4.07    7 Sept  1995   fticol failed on ASCII columns
C       version 4.06   18 Aug   1995   ftdelt bug; ftpmsg saves latest errors
C       version 4.05    2 Aug   1995   another bug in ftfrcl in reseting tstart
C       version 4.04   12 Jul   1995   bug in ftfrcl in resetting tstart
C       version 4.03    3 Jul   1995   bug in restoring CHDU when moving to EOF
C       version 4.02   20 Jun   1995   modified checksum algorithm
C       version 4.01   30 May   1995   many changes
C       version 3.711  30 Jan   1995   ftgphx was cutting BSCALE to 20 chars
C       version 3.710  27 Jan   1995   fix ftgcnn, fitsmac; add ftirec, ftdrec
C       version 3.700  29 Dec   1994   public release
C       version 3.623   8 Nov   1994   ftgkys, ftgnst, checksum
C       version 3.622   7 Nov   1994   ftgclj R*8 alignment; I*2 overflow fti4i2
C       version 3.621   4 Nov   1994   fixed endhd position in ftgrec
C       version 3.62    2 Nov   1994   ftgcx[ijd] routines added
C       version 3.612  31 Oct   1994   restored previous FTIBLK algorithm
C       version 3.61   26 Oct   1994   ftirow and ftdrow to modify tables
C       version 3.6    18 Oct   1994   ftukyX, range checking, new EOF checks
C       version 3.512  20 Sep   1994   fixed writing header fill in FTWEND
C       version 3.511  20 Sep   1994   removed '=' from CONTINUE on long strings
C       version 3.51   14 Sep   1994   long string convention and IEEE support
C       version 3.504  22 Aug   1994   fixed bug in ftcopy making files too big
C       version 3.503   8 Aug   1994   fixed bug in ftcopy making files too big
C       version 3.502  26 Jul   1994   explicitly write data fill bytes
C       version 3.501  19 Jul   1994   minor changes for FTOOLS release
C       version 3.500  29 Jun   1994   added error message stack
C       version 3.415  07 Jun   1994   fixed ftmahd and ftgrec
C       version 3.414  18 May   1994   modify ftmoff and ftpbyt for status 112
C       version 3.413  18 Mar   1994   Cray port added
C       version 3.412  01 Mar   1994   SUN internal read problem in ftgthd
C       version 3.411  25 Feb   1994   fixed 107 error when reading byte column
C       version 3.410  21 Jan   1994   bug fixes in Alpha VMS version
C       version 3.409  21 Dec   1993   long string bug; HP support
C       version 3.408  09 Nov   1993   Alpha VMS open; ftgthd -; 210 status
C       version 3.407  02 Nov   1993   initialize TABLEs with blanks; ftrdef
C       version 3.406  26 Oct   1993   ftgtdm bug - last not initialized
C                                      modified to read unknown extenstions
C       version 3.405  21 Oct   1993   ftpini bug with GROUP format files
C       version 3.404   7 Oct   1993   new TDIM subroutines, new error status
C       version 3.403   1 Sept  1993   initialize strlen in ftpkys
C       version 3.402  23 Aug   1993   bug in ftgcno
C       version 3.401  20 Aug   1993   minor change to ftpi1b
C       version 3.4  - 11 Aug   1993
C       version 3.31 -  2 Feb   1993
C       version 3.3  - 28 Oct   1992
C       version 3.21 -  8 July  1992
C       version 3.20 - 30 Mar   1992
C       version 3.10 -  4 Nov   1991
C       version 3.01 - 27 Sept  1991
C       version 3.00 - 12 Sept  1991
C       version 2.99 - 24 July  1991
C       version 2.0  -  1 May   1991
C       version 1.3  -  2 April 1991
C       version 1.22 - 22 March 1991
C       version 1.21 - 20 March 1991
 
        end
        subroutine ftwend(iunit,status)
 
C       write the END card, and following fill values in the CHDU
 
C       iunit   i  fortran unit number
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Aug 1994
 
        integer iunit,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff,nblank,i,endpos
        character*80 rec
 
        if (status .gt. 0)return
 
        ibuff=bufnum(iunit)
 
C       calc the data starting position if not currently defined
        if (dtstrt(ibuff) .lt. 0)then
                dtstrt(ibuff)=(hdend(ibuff)/2880 + 1)*2880
        end if
 
C       calculate the number of blank keyword slots in the header
        endpos=hdend(ibuff)
        nblank=(dtstrt(ibuff)-endpos)/80
C       move the i/o pointer to the end of the header keywords
        call ftmbyt(iunit,endpos,.true.,status)
 
C       fill all the slots with blanks
        rec=' '
        do 10 i=1,nblank
                call ftpcbf(iunit,80,rec,status)
10      continue
 
C               The END keyword must either be placed
C               immediately after the last keyword that was written
C               (as indicated by the HDEND parameter), or must be in the
C               first 80 bytes of the FITS record immediately preceeding
C               the data unit, whichever is further in the file.
C               The latter will occur if the user reserved room for more
C               header keywords which have not (yet) been filled.
 
C       move pointer to where the END card should be
        endpos=max(endpos,dtstrt(ibuff)-2880)
        call ftmbyt(iunit,endpos,.true.,status)
 
C       write the END record to the output buffer:
        rec='END'
        call ftpcbf(iunit,80,rec,status)
 
        if (status .gt. 0)then
            call ftpmsg('Error while writing END card (FTWEND).')
        end if
        end
        subroutine ftwhbf(ilbuff,pbuff)
 
C       decide which physical buffer to use to load in a new record
 
C       ilbuff  i  the logical buffer number of the record to be loaded (input)
C       pbuff   i  the physical buffer that should be used (output)
 
        integer ilbuff,pbuff
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,pb
        parameter (nb = 20)
        parameter (pb = 20)
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
        integer maxbuf,logbuf,recnum,pindex
        logical modify
        common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb),
     &  pindex(pb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer i,num,lbuff
 
C       search from the oldest to the youngest for an unlocked record
        do 10 i=1,maxbuf
C           num is the number of the next oldest buffer
            num=pindex(i)
 
C           lbuff is the logical buffer associated with this physical buffer
            lbuff=logbuf(num)
 
C           is the physical buffer a current buffer (i.e., locked)?
            if (lbuff .eq. 0 .or. currnt(lbuff) .ne. num)then
                pbuff=num
                return
            end if
10      continue
 
C       all the buffers are locked, so we have to reuse the current one
        pbuff=currnt(ilbuff)
        end
        subroutine ftwldp(xpix,ypix,xref,yref,xrefpix,yrefpix,
     &                    xinc,yinc,rot,type,xpos,ypos,status)
 
C       Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS
C       Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994
C       routine to determine accurate position from pixel coordinates
C       does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections
C       returns   0 = good,
C               501 = angle too large for projection;
C Input:
C dbl   xpix    x pixel number  (RA or long without rotation)
C dbl   ypiy    y pixel number  (dec or lat without rotation)
C dbl   xref    x reference coordinate value (deg)
C dbl   yref    y reference coordinate value (deg)
C dbl   xrefpix x reference pixel
C dbl   yrefpix y reference pixel
C dbl   xinc    x coordinate increment (deg)
C dbl   yinc    y coordinate increment (deg)
C dbl   rot     rotation (deg)  (from N through E)
C chr   type    projection type code e.g. "-SIN"
C Output:
C dbl    xpos   x (RA) coordinate (deg)
C dbl    ypos   y (dec) coordinate (deg)
C int   status  error status flag, zero
 
        integer           status
        double precision  xpix,ypix,xref,yref,xrefpix,yrefpix
        double precision  xinc,yinc,rot,xpos,ypos
        character*(*)     type
        integer           error1,error4
        parameter         (error1=501)
        parameter         (error4=504)
 
        double precision  cosr,sinr,dx,dy,dz,temp
        double precision  sins,coss,dect,rat,dt,l,m,mg,da,dd,cos0,sin0
        double precision  dec0,ra0,decout,raout
        double precision  geo1,geo2,geo3
        double precision  cond2r
        parameter         (cond2r=1.745329252d-2)
        double precision  twopi,deps
        parameter         (twopi = 6.28318530717959)
        parameter         (deps = 1.0d-5)
        integer           i,itype
        character*4       ctypes(8)
        data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP',
     &               '-GLS', '-MER', '-AIT', '-STG' /
 
        if (status .gt. 0) return
C   *** Offset from ref pixel
        dx = (xpix-xrefpix) * xinc
        dy = (ypix-yrefpix) * yinc
C   *** Take out rotation
        cosr = dcos(rot*cond2r)
        sinr = dsin(rot*cond2r)
        if (rot .ne. 0.0) then
          temp = dx * cosr - dy * sinr
          dy = dy * cosr + dx * sinr
          dx = temp
        end if
C   *** Find type of coordinate transformation (0 is linear)
C   WDP, 1/97: removed support for default type, to give better error ck
C       itype = 0
        itype = -1
        do 10 i = 1, 8
          if (ctypes(i) .eq. type) itype = i
  10    continue
C   *** default, linear result for error return
        xpos = xref + dx
        ypos = yref + dy
C   *** Convert to radians
        ra0 = xref * cond2r
        dec0 = yref * cond2r
        l = dx * cond2r
        m = dy * cond2r
        sins = l*l + m*m
        decout = 0.0
        raout = 0.0
        cos0 = dcos(dec0)
        sin0 = dsin(dec0)
C   *** Process by case
        if (itype .eq. 0) then
C   *** LINEAR
          rat =  ra0 + l
          dect = dec0 + m
        else if (itype .eq. 1) then
C   *** SINE from '-SIN' type
          if (sins .gt. 1.0) then
            status = error1
            goto 30
          end if
          coss = dsqrt(1.0 - sins)
          dt = sin0 * coss + cos0 * m
          if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then
            status = error1
            goto 30
          end if
          dect = dasin(dt)
          rat = cos0 * coss - sin0 * m
          if ((rat .eq. 0.0) .and. (l .eq. 0.0)) then
            status = error1
            goto 30
          end if
          rat = datan2 (l, rat) + ra0
        else if (itype .eq. 2) then
C   *** TANGENT from '-TAN' type
          if (sins .gt. 1.0) then
            status = error1
            goto 30
          end if
          dect = cos0 - m * sin0
          if (dect .eq. 0.0) then
            status = error1
            goto 30
          end if
          rat = ra0 + datan2(l, dect)
          dect = datan(dcos(rat-ra0) * (m * cos0 + sin0) / dect)
        else if (itype .eq. 3) then
C   *** Arc from '-ARC' type
          if (sins .ge. twopi * twopi / 4.0) then
            status = error1
            goto 30
          end if
          sins = dsqrt(sins)
          coss = dcos(sins)
          if (sins .ne. 0.0) then
            sins = dsin(sins) / sins
          else
            sins = 1.0
          end if
          dt = m * cos0 * sins + sin0 * coss
          if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then
            status = error1
            goto 30
          end if
          dect = dasin(dt)
          da = coss - dt * sin0
          dt = l * sins * cos0
          if ((da .eq. 0.0) .and. (dt .eq. 0.0)) then
            status = error1
            goto 30
          end if
          rat = ra0 + datan2(dt, da)
        else if (itype .eq. 4) then
C   *** North Celestial Pole from '-NCP' type
          dect = cos0 - m * sin0
          if (dect .eq. 0.0) then
            status = error1
            goto 30
          end if
          rat = ra0 + datan2(l, dect)
          dt = dcos(rat-ra0)
          if (dt .eq. 0.0) then
            status = error1
            goto 30
          end if
          dect = dect / dt
          if ((dect .gt. 1.0) .or. (dect .lt. -1.0)) then
            status = error1
            goto 30
          end if
          dect = dacos(dect)
          if (dec0 .lt. 0.0) dect = -dect
        else if (itype .eq. 5) then
C   *** Global Sinusoid from '-GLS' type
          dect = dec0 + m
          if (dabs(dect) .gt. twopi/4.0) then
            status = error1
            goto 30
          end if
          coss = dcos(dect)
          if (dabs(l) .gt. twopi*coss/2.0) then
            status = error1
            goto 30
          end if
          rat = ra0
          if (coss .gt. deps) rat = rat + l / coss
        else if (itype .eq. 6) then
C   *** Mercator from '-MER' type
          dt = yinc * cosr + xinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dy = (yref/2.0 + 45.0) * cond2r
          dx = dy + dt / 2.0 * cond2r
          dy = dlog(dtan(dy))
          dx = dlog(dtan(dx))
          geo2 = dt * cond2r / (dx - dy)
          geo3 = geo2 * dy
          geo1 = dcos(yref * cond2r)
          if (geo1 .le. 0.0) geo1 = 1.0
          rat = l / geo1 + ra0
          if (dabs(rat - ra0) .gt. twopi) then
            status = error1
            goto 30
          end if
          dt = 0.0
          if (geo2 .ne. 0.0) dt = (m + geo3) / geo2
          dt = dexp(dt)
          dect = 2.0 * datan(dt) - twopi / 4.0
        else if (itype .eq. 7) then
C   *** Aitoff from '-AIT' type
          dt = yinc * cosr + xinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dt = dt * cond2r
          dy = yref * cond2r
          dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) -
     &         dsin(dy)/dsqrt((1.0+dcos(dy))/2.0)
          if (dx .eq. 0.0) dx = 1.0
          geo2 = dt / dx
          dt = xinc * cosr - yinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dt = dt * cond2r
          dx = 2.0 * dcos(dy) * dsin(dt/2.0)
          if (dx .eq. 0.0) dx = 1.0
          geo1 = dt * dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0) / dx
          geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0)
          rat = ra0
          dect = dec0
          if ((l .eq. 0.0) .and. (m .eq. 0.0)) goto 20
          dz = 4.0-l*l/(4.0*geo1*geo1)-((m+geo3)/geo2)*((m+geo3)/geo2)
          if ((dz .gt. 4.0) .or. (dz .lt. 2.0)) then
            status = error1
            goto 30
          end if
          dz = 0.5 * dsqrt(dz)
          dd = (m+geo3) * dz / geo2
          if (dabs(dd) .gt. 1.0) then
            status = error1
            goto 30
          end if
          dd = dasin(dd)
          if (dabs(dcos(dd)) .lt. deps) then
            status = error1
            goto 30
          end if
          da = l * dz / (2.0 * geo1 * dcos(dd))
          if (dabs(da) .gt. 1.0) then
            status = error1
            goto 30
          end if
          da = dasin(da)
          rat = ra0 + 2.0 * da
          dect = dd
        else if (itype .eq. 8) then
C   *** Stereographic from '-STG' type
          dz = (4.0 - sins) / (4.0 + sins)
          if (dabs(dz) .gt. 1.0) then
            status = error1
            goto 30
          end if
          dect = dz * sin0 + m * cos0 * (1.0+dz) / 2.0
          if (dabs(dect) .gt. 1.0) then
            status = error1
            goto 30
          end if
          dect = dasin(dect)
          rat = dcos(dect)
          if (dabs(rat) .lt. deps) then
            status = error1
            goto 30
          end if
          rat = l * (1.0+dz) / (2.0 * rat)
          if (dabs(rat) .gt. 1.0) then
            status = error1
            goto 30
          end if
          rat = dasin(rat)
          mg = 1.0 + dsin(dect)*sin0 + dcos(dect)*cos0*dcos(rat)
          if (dabs(mg) .lt. deps) then
            status = error1
            goto 30
          end if
          mg = 2.0 * (dsin(dect)*cos0 - dcos(dect)*sin0*dcos(rat)) / mg
          if (dabs(mg-m) .gt. deps) rat = twopi/2.0 - rat
          rat = ra0 + rat
        else
C   *** Unsupported Projection
          status = error4
          goto 30
        end if
  20    continue
C   *** Return RA in range
        raout = rat
        decout = dect
        if (raout-ra0 .gt. twopi/2.0) raout = raout - twopi
        if (raout-ra0 .lt. (-twopi)/2.0) raout = raout + twopi
        if (raout .lt. 0.0) raout = raout + twopi
C   *** Correct units back to degrees
        xpos = raout / cond2r
        ypos = decout / cond2r
  30    continue
        end
        subroutine ftwrit(ounit,nrec,length,pbuff,status)
 
C       lowest-level routine to write a physical buffer to the disk file
 
C       ounit   i  Fortran unit number to write to
C       nrec    i  number of the file record to write
C       length  i  number of bytes to write
C       pbuff   i  number of the physical buffer to write from
C       status  i  output error status
 
        integer ounit,nrec,length,pbuff,status
 
C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 20)
        parameter (ne = 512)
 
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
 
        integer buflun,currnt,reclen,bytnum,maxrec
        common/ftlbuf/buflun(nb),currnt(nb),reclen(nb),
     &  bytnum(nb),maxrec(nb)
 
C       have to use separate character arrays because of compiler limitations
        character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
        common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,
     &  b15,b16,b17,b18,b19,b20
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------
 
        integer ibuff
 
C       Note: performance testing on a SUN showed that writing a
C       c*2888 string was MUCH (11x) faster than writing a C*1(2880) array
C       with write(...)(b1(i),i=1,2880).  It was also 2-3 times faster
C       than if the array was declared as a double and written with
C       write(...)(darray(i),i=1,360).  The VAX took about the same
C       time for all 3 different ways to write the bytes.
 
        ibuff=bufnum(ounit)
C       Save maximum record written, for comparison in ftread
        maxrec(ibuff) = max(maxrec(ibuff), nrec)
 
        go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,
     &  19,20)pbuff
 
C       if got here, then pbuff is out of range
        status=101
        return
 
1       write(ounit,rec=nrec,err=900)b1(1:length)
        return
2       write(ounit,rec=nrec,err=900)b2(1:length)
        return
3       write(ounit,rec=nrec,err=900)b3(1:length)
        return
4       write(ounit,rec=nrec,err=900)b4(1:length)
        return
5       write(ounit,rec=nrec,err=900)b5(1:length)
        return
6       write(ounit,rec=nrec,err=900)b6(1:length)
        return
7       write(ounit,rec=nrec,err=900)b7(1:length)
        return
8       write(ounit,rec=nrec,err=900)b8(1:length)
        return
9       write(ounit,rec=nrec,err=900)b9(1:length)
        return
10      write(ounit,rec=nrec,err=900)b10(1:length)
        return
11      write(ounit,rec=nrec,err=900)b11(1:length)
        return
12      write(ounit,rec=nrec,err=900)b12(1:length)
        return
13      write(ounit,rec=nrec,err=900)b13(1:length)
        return
14      write(ounit,rec=nrec,err=900)b14(1:length)
        return
15      write(ounit,rec=nrec,err=900)b15(1:length)
        return
16      write(ounit,rec=nrec,err=900)b16(1:length)
        return
17      write(ounit,rec=nrec,err=900)b17(1:length)
        return
18      write(ounit,rec=nrec,err=900)b18(1:length)
        return
19      write(ounit,rec=nrec,err=900)b19(1:length)
        return
20      write(ounit,rec=nrec,err=900)b20(1:length)
        return
 
C       come here if there was a disk write error of some sort
900     status=106
        end
        subroutine ftxiou(iounit,status)
 
C       generic routine to manage logical unit numbers in the range 50-99
 
        integer iounit,status,i
        integer*2 array(50)
        save array
        data array/50*0/
 
        if (iounit .eq. 0)then
C           get an unused logical unit number
            do 10 i=50,1,-1
 
C        The following would be a more robust way of testing for
C        an available unit number, however, this cannot work
C        when building FITSIO using the IRAF/SPP version, because
C        IRAF does not use Fortran I/O.
C
C                inquire(unit=iounit, exist=exists, opened=open)
C                if(exists .and. .not. open)then
C                    array(iounit-49)=1
C                    return
C                end if
 
                 if (array(i) .eq. 0)then
                     array(i)=1
                     iounit=i+49
                     return
                 end if
10          continue
C           error: all units are allocated
            iounit=-1
            status=114
            call ftpmsg('FTGIOU has no more available unit numbers.')
 
        else if (iounit .eq. -1)then
C           deallocate all the unit numbers
            do 20 i=1,50
                 array(i)=0
20          continue
 
        else
C            deallocat a specific unit number
             if (iounit .ge. 50 .and. iounit .le. 99)then
                 array(iounit-49)=0
             end if
        endif
        end
        subroutine ftxmsg(action,text)
 
C       get, put, or clear the error message stack
 
        integer action
        character*(*) text
 
        integer nbuff,i
        parameter (nbuff=50)
        character*80 txbuff(nbuff)
        save txbuff
        data txbuff/nbuff * ' '/
 
        if (action .eq. -1)then
 
C           get error message from top of stack and shift the stack up one
            text=txbuff(1)
            do 10 i=1,nbuff-1
                txbuff(i) = txbuff(i+1)
 10         continue
            txbuff(nbuff)=' '
 
        else if (action .eq. 1)then
 
C           put error message onto stack.
            do 20 i=1,nbuff
                if (txbuff(i) .eq. ' ')then
                   txbuff(i)=text
                   return
                end if
20          continue
C           stack is full so discard oldest message
            do 25 i=1,nbuff-1
                txbuff(i) = txbuff(i+1)
25          continue
            txbuff(nbuff)=text
 
        else if (action .eq. 0)then
 
C           clear the error message stack
            do 30 i=1,nbuff
                txbuff(i) = ' '
30          continue
 
        end if
        end
        subroutine ftxypx(xpos,ypos,xref,yref,xrefpix,yrefpix,
     &                    xinc,yinc,rot,type,xpix,ypix,status)
 
C       Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS
C       Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994
C       routine to determine accurate pixel coordinates from an RA and Dec
C       does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections
C       returns   0 = good,
C               501 = angle too large for projection;
C               502 = bad values
C               503 = ???undocumented error - looks like an underflow???
C Input:
C dbl   xpos   x (RA) coordinate (deg)
C dbl   ypos   y (dec) coordinate (deg)
C dbl   xref    x reference coordinate value (deg)
C dbl   yref    y reference coordinate value (deg)
C dbl   xrefpix x reference pixel
C dbl   yrefpix y reference pixel
C dbl   xinc    x coordinate increment (deg)
C dbl   yinc    y coordinate increment (deg)
C dbl   rot     rotation (deg)  (from N through E)
C chr   type    projection type code e.g. "-SIN"
C Output:
C dbl   xpix    x pixel number  (RA or long without rotation)
C dbl   ypiy    y pixel number  (dec or lat without rotation)
C int   status  error status flag, zero
 
        integer           status
        double precision  xpos,ypos,xref,yref,xrefpix,yrefpix
        double precision  xinc,yinc,rot,xpix,ypix
        character*(*)     type
        integer           error1,error2,error3,error4
        parameter         (error1=501)
        parameter         (error2=502)
        parameter         (error3=503)
        parameter         (error4=504)
        double precision  dx,dy,dz,r,ra0,dec0,ra,dec
        double precision  coss,sins,dt,da,dd,sint,oldxpos
        double precision  l,m,geo1,geo2,geo3,sinr,cosr
        double precision  cond2r
        parameter         (cond2r=1.745329252d-2)
        double precision  twopi,deps
        parameter         (twopi = 6.28318530717959)
        parameter         (deps = 1.0d-5)
        integer           i,itype
        character*4       ctypes(8)
        data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP',
     &               '-GLS', '-MER', '-AIT', '-STG' /
 
        if (status .gt. 0) return
C   *** 0 hour wrap around test
        oldxpos = xpos
        dt = (xpos - xref)
        if (dt .gt. +180) xpos = xpos - 360
        if (dt .lt. -180) xpos = xpos + 360
C   *** Default values - Linear
        dx = xpos - xref
        dy = ypos - yref
        dz = 0.0
C   *** Correct for rotation
        r = rot * cond2r
        cosr = dcos(r)
        sinr = dsin(r)
        dz = dx * cosr + dy * sinr
        dy = dy * cosr - dx * sinr
        dx = dz
C   *** Check axis increments - bail out if either 0
        if ((xinc .eq. 0.0) .or. (yinc .eq. 0.0)) then
          xpix = 0.0
          ypix = 0.0
          status = error2
          goto 30
        end if
        xpix = dx / xinc + xrefpix
        ypix = dy / yinc + yrefpix
C   *** Find type of coordinate transformation (0 is linear)
C   WDP, 1/97: removed support for default type, to give better error ck
C       itype = 0
        itype = -1
        do 10 i = 1, 8
          if (ctypes(i) .eq. type) itype = i
  10    continue
C   *** Done if linear
        if (itype .eq. 0) goto 30
C   *** Non-Linear position
        ra0 = xref * cond2r
        dec0 = yref * cond2r
        ra = xpos * cond2r
        dec = ypos * cond2r
C   *** Compute directional cosine
        coss = dcos(dec)
        sins = dsin(dec)
        l = dsin(ra-ra0) * coss
        sint = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0)
C   *** Process by case
        if (itype .eq. 1) then
C   *** SINE from '-SIN' type
          if (sint .lt. 0.0) then
            status = error1
            goto 30
          end if
          m = sins * dcos(dec0) - coss * dsin(dec0) * dcos(ra-ra0)
        else if (itype .eq. 2) then
C   *** TANGENT from '-TAN' type
          if (sint .le. 0.0) then
            status = error1
            goto 30
          end if
          m = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0)
          l = l / m
          m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) / m
        else if (itype .eq. 3) then
C   *** Arc from '-ARC' type
          m = sins*dsin(dec0) + coss*dcos(dec0)*dcos(ra-ra0)
          if (m .lt. -1.0) m = -1.0
          if (m .gt. 1.0) m = 1.0
          m = dacos(m)
          if (m .ne. 0) then
            m = m / dsin(m)
          else
            m = 1.0
          end if
          l = l * m
          m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) * m
        else if (itype .eq. 4) then
C   *** North Celestial Pole from '-NCP' type
          if (dec0 .eq. 0.0) then
            status = error1
            goto 30
          else
            m = (dcos(dec0) - coss * dcos(ra-ra0)) / dsin(dec0)
          end if
        else if (itype .eq. 5) then
C   *** Global Sinusoid from '-GLS' type
          dt = ra - ra0
          if (dabs(dec) .gt. twopi/4.0) then
            status = error1
            goto 30
          end if
          if (dabs(dec0) .gt. twopi/4.0) then
            status = error1
            goto 30
          end if
          m = dec - dec0
          l = dt * coss
        else if (itype .eq. 6) then
C   *** Mercator from '-MER' type
          dt = yinc * cosr + xinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dy = (yref/2.0 + 45.0) * cond2r
          dx = dy + dt / 2.0 * cond2r
          dy = dlog(dtan(dy))
          dx = dlog(dtan (dx))
          geo2 = dt * cond2r / (dx - dy)
          geo3 = geo2 * dy
          geo1 = cos (yref * cond2r)
          if (geo1 .le. 0.0) geo1 = 1.0
          dt = ra - ra0
          l = geo1 * dt
          dt = dec / 2.0 + twopi / 8.0
          dt = dtan(dt)
          if (dt .lt. deps) then
            status = error2
            goto 30
          end if
          m = geo2 * dlog(dt) - geo3
        else if (itype .eq. 7) then
C   *** Aitoff from '-AIT' type
          l = 0.0
          m = 0.0
          da = (ra - ra0) / 2.0
          if (dabs(da) .gt. twopi/4.0) then
            status = error1
            goto 30
          end if
          dt = yinc * cosr + xinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dt = dt * cond2r
          dy = yref * cond2r
          dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) -
     &         dsin(dy)/dsqrt((1.0+dcos(dy))/2.0)
          if (dx .eq. 0.0) dx = 1.0
          geo2 = dt / dx
          dt = xinc * cosr - yinc * sinr
          if (dt .eq. 0.0) dt = 1.0
          dt = dt * cond2r
          dx = 2.0 * dcos(dy) * dsin(dt/2.0)
          if (dx .eq. 0.0) dx = 1.0
          geo1 = dt*dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0)/dx
          geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0)
          dt = dsqrt ((1.0 + dcos(dec) * dcos(da))/2.0)
          if (dabs(dt) .lt. deps) then
            status = error3
            goto 30
          end if
          l = 2.0 * geo1 * dcos(dec) * dsin(da) / dt
          m = geo2 * dsin(dec) / dt - geo3
        else if (itype .eq. 8) then
C   *** Stereographic from '-STG' type
          da = ra - ra0
          if (dabs(dec) .gt. twopi/4.0) then
            status = error1
            goto 30
          end if
          dd = 1.0 + sins*dsin(dec0) + coss*dcos(dec0)*dcos(da)
          if (dabs(dd) .lt. deps) then
            status = error1
            goto 30
          end if
          dd = 2.0 / dd
          l = l * dd
          m = dd * (sins*dcos(dec0) - coss*dsin(dec0)*dcos(da))
        else
C   *** Unsupported Projection
          status = error4
          goto 30
        end if
C   *** Convert back to degrees
        dx = l / cond2r
        dy = m / cond2r
C   *** Correct for rotation
        dz = dx * cosr + dy * sinr
        dy = dy * cosr - dx * sinr
        dx = dz
C   *** Convert to PIXELS ... yeah!
        xpix = dx / xinc + xrefpix
        ypix = dy / yinc + yrefpix
  30    continue
C   *** reset xpos to correct for in place modification
        xpos = oldxpos
        end
        subroutine ftzrcr(pbuff)
 
C       initalize the common block buffer with zeros.
C       This routine is reserved for Cray computers.
 
C       pbuff  i  number of the physical buffer to initialize
 
        integer pbuff,i
        integer pb
        parameter (pb = 20)
        integer buff,dummy
        common /ftbuff/buff(360,pb),dummy(360,pb)
 
C       The dummy array was added to the common block to eliminate
C       compiler warnings on other platforms besides Cray.  On all
C       other machines, an integer is 4 bytes long, hence the dummy
C       array is needed to increase the size of the common block to
C       the same length as other routines where the array is declared
C       as character*2880 buff(pb).
 
C       This will cause compiler warnings on the CRAY, but these
C       can be ignored since the dummy array is never used.
 
        do 10 i=1,360
                buff(i,pbuff)=0
10      continue
        end

C------------------------------------------------------------------------------
C       The following routines are part of the FITSIO library
C       and are specific to Fortran-90 compilers.
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 ftopnf(funit,fname,oldnew,rwmode,block,size,status)

C       low-level, machine-dependent routine to create or 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       size    i  min size of file, in bytes
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, December 1996

        integer funit,oldnew,rwmode,block,size,status,lenrec
        character*(*) fname
        character fstat*3, fmode*9
        character dummy*2880

C       some compilers require that dummy be initialized!
        dummy = ' '
        if (oldnew .eq. 0)then
                fstat='OLD'
C               simply return the default block size
                block=1
C               no easy way to determine the size of the file, 
C               so just set value to a huge number
                size=1000000000
        else
C               create a new file
                fstat='NEW'
                size = 0
        end if

        if(rwmode .eq. 0) then
           fmode = 'READ'
        else
           fmode = 'READWRITE'
        end if

C       determine the record length needed to read or write 2880-byte records
C       (could be 720 words or 2880 bytes, depending on the compiler)

        inquire(iolength=lenrec) dummy
        open(unit=funit,file=fname,status=fstat,err=900, action=fmode,
     &       recl=lenrec,form='UNFORMATTED',access='DIRECT')
        return

C       error opening file:
900     status=104 + oldnew
        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)

C     This routine is not valid after the year 1999; must be modified
C     before the year 2000.

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

        if (status .gt. 0)return

        call date_and_time(values=iarray)

        dd=iarray(3)
        mm=iarray(2)
        yy=mod(iarray(1),100)
        end
C----------------------------------------------------------------------
        subroutine ftpbyt(ounit,nbytes,array,status)

C       write string of data bytes to output buffer.

C       ounit   i  fortran unit number
C       nbytes  i  number of bytes
C       array   i  integer array
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991

        integer nbytes,ounit,status
        integer array((nbytes-1) / 4 + 1)
        character temp

C       Trick the compiler into passing the integer array to a routine
C       that is expecting a character string argument.
C       This is very ugly, but I/O efficiency is of primary importance.

        call ftpxbf(ounit,nbytes,array,temp,status)
        end
C--------------------------------------------------------------------------
        subroutine ftpxbf(ounit,nbytes,array,temp,status)
        integer temp
        integer nbytes,ounit,status
        character*(nbytes) array

C       array is now declared as a string!
        call ftpcbf(ounit,nbytes,array,status) 
        end
C--------------------------------------------------------------------------
        subroutine ftpbyo(ounit,gsize,ngroup,offset,array,status)
 
C       "Put Bytes with Offsets"
C       copy input buffer of bytes to the output character buffer.
 
C       ounit   i  Fortran output unit number
C       gsize   i  size of each group of bytes
C       ngroup  i  number of groups to write
C       offset  i  size of gap between groups
C       array   i  input array of bytes
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996
 
        integer ounit,gsize,ngroup,offset,status
        integer array(*)
        character temp

C       Trick the compiler into passing the integer array to a routine
C       that is expecting a character string argument.
C       This is very ugly, but I/O efficiency is of primary importance.

        call ftpxbo(ounit,gsize,ngroup,offset,array,temp,status)
        end
C--------------------------------------------------------------------------
        subroutine ftpxbo(ounit,gsize,ngroup,offset,array,temp,status)
        integer temp
        integer ounit,gsize,ngroup,offset,status
        character*(gsize*ngroup) array

C       array is now declared as a string!
        call ftpcbo(ounit,gsize,ngroup,offset,array,status)
        end
C----------------------------------------------------------------------
        subroutine ftgbyt(iunit,nbytes,array,status)

C       read string of data bytes from input buffer.

C       iunit   i  fortran unit number
C       nbytes  i  number of bytes
C       array   i  integer array
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991

        integer nbytes,iunit,status
        integer array(*)
        character temp

C       Trick the compiler into passing the integer array to a routine
C       that is expecting a character string argument.
C       This is very ugly, but I/O efficiency is of primary importance.

        call ftgxbf(iunit,nbytes,array,temp,status)

        end
C--------------------------------------------------------------------------
        subroutine ftgxbf(iunit,nbytes,array,temp,status)
        integer temp
        integer nbytes,iunit,status
        character*(nbytes) array

C       array is now declared as a string!
        call ftgcbf(iunit,nbytes,array,status) 
        end
C--------------------------------------------------------------------------
        subroutine ftgbyo(iunit,gsize,ngroup,offset,array,status)

C       "Get BYtes with Offsets"
C       read bytes from the character buffer.

C       iunit   i  Fortran output unit number
C       gsize   i  size of each group of bytes
C       ngroup  i  number of groups to read
C       offset  i  size of gap between groups
C       array   i  output array of bytes
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, Dec 1996

        integer iunit,gsize,ngroup,offset,status
        integer array(*)
        character temp

C       Trick the compiler into passing the integer array to a routine
C       that is expecting a character string argument.
C       This is very ugly, but I/O efficiency is of primary importance.

        call ftgxbo(iunit,gsize,ngroup,offset,array,temp,status)
        end
C--------------------------------------------------------------------------
        subroutine ftgxbo(iunit,gsize,ngroup,offset,array,temp,status)
        integer temp
        integer iunit,gsize,ngroup,offset,status
        character*(gsize*ngroup) array

C       array is now declared as a string!
        call ftgcbo(iunit,gsize,ngroup,offset,array,status)
        end
C------------------------------------------------------------------------
        subroutine ieevud(dbl1, dbl2, int)
        double precision dbl1,dbl2
        integer int
C       dummy routine; only used on Vax VMS computers
        end
C------------------------------------------------------------------------
        subroutine ieevpd(dbl1, dbl2, int)
        double precision dbl1,dbl2
        integer int
C       dummy routine; only used on Vax VMS computers
        end
C------------------------------------------------------------------------
        integer function cray2ieg(i1,i2,i3,i4,i5,i6,s1)
        integer i1,i2,i3,i4,i5,i6
        character s1
C       dummy routine; only used on Cray supercomputers
        cray2ieg=0
        end
C------------------------------------------------------------------------
        integer function ieg2cray(i1,i2,i3,i4,i5,i6,s1)
        integer i1,i2,i3,i4,i5,i6
        character s1
C       dummy routine; only used on Cray supercomputers
        ieg2cray=0
        end

