diff options
Diffstat (limited to 'pkg/tbtables/fitsio/fticol.f')
| -rw-r--r-- | pkg/tbtables/fitsio/fticol.f | 154 |
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 |