Initial commit

1 files changed, 154 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/fticol.f b/pkg/tbtables/fitsio/fticol.f
new file mode 100644
index 00000000..33582ea9
--- /dev/null
+++ b/pkg/tbtables/fitsio/fticol.f
@@ -0,0 +1,154 @@
+C--------------------------------------------------------------------------
+        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 = 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)
+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)+scount(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