Initial commit

1 files changed, 183 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftaini.f b/pkg/tbtables/fitsio/ftaini.f
new file mode 100644
index 00000000..1f7d2d70
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftaini.f
@@ -0,0 +1,183 @@
+C--------------------------------------------------------------------------
+        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 = 200)
+        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,scount
+        integer theap,nxheap
+        double precision tscale,tzero
+        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
+     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb)
+     &  ,theap(nb),nxheap(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
+        scount(ibuff)=0
+        theap(ibuff)=rowlen(ibuff)*nrows
+        nxheap(ibuff)=0
+
+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