diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftbdef.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftbdef.f | 121 |
1 files changed, 121 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftbdef.f b/pkg/tbtables/fitsio/ftbdef.f new file mode 100644 index 00000000..97c74cf7 --- /dev/null +++ b/pkg/tbtables/fitsio/ftbdef.f @@ -0,0 +1,121 @@ +C-------------------------------------------------------------------------- + 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 = 200) + 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,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 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) + scount(ibuff)=0 + theap(ibuff)=0 + nxheap(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 store the size of the special data area, if any + scount(ibuff)=pcount + theap(ibuff)=nrows*rowlen(ibuff) + nxheap(ibuff)=0 + +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 |