diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftcins.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftcins.f | 173 |
1 files changed, 173 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftcins.f b/pkg/tbtables/fitsio/ftcins.f new file mode 100644 index 00000000..08485ce3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcins.f @@ -0,0 +1,173 @@ +C-------------------------------------------------------------------------- + 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 = 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*1 buff(5760) + common/ftheap/buff +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)=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)=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 |