diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftbini.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftbini.f | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftbini.f b/pkg/tbtables/fitsio/ftbini.f new file mode 100644 index 00000000..5f39e763 --- /dev/null +++ b/pkg/tbtables/fitsio/ftbini.f @@ -0,0 +1,181 @@ +C-------------------------------------------------------------------------- + subroutine ftbini(iunit,status) + +C initialize the parameters defining the structure of a binary 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 lenrow,nrows,pcnt,tfld,nkey,ibuff,i,j,nblank + character keynam*8,value*70,comm*72,cnaxis*8,clen*8,rec*80 + + 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 (2 = Binary table extension) + hdutyp(ibuff)=2 + +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 binary table, and get parameters + call ftgtbn(iunit,rowlen(ibuff),nrows,pcnt,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 Binary table has too many fields '// + & 'to be read with FITSIO (FTBINI).') + 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. + tnull(i+tstart(ibuff))=123454321 + tdtype(i+tstart(ibuff))=-9999 + trept(i+tstart(ibuff))=0 +C reset character NUL string, in case it has been previously +C defined from an ASCII table extension + cnull(i+tstart(ibuff))=char(0) +5 continue + +C initialize the default heap starting address (immediately following +C the table data) and set the next empty heap address +C PCOUNT specifies the amount of special data following the table + scount(ibuff)=pcnt + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=pcnt + +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 Binary table'// + & ' header (FTBINI).') + 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 binary table parameter (if it is one) + call ftpsvc(rec,value,comm,status) + call ftgbtp(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 (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, ignoring +C 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+pcnt+2879)/2880*2880 + +C determine the byte offset of the beginning of each field and row length + if (tfld .gt. 0)then + call ftgtbc(tfld,tdtype(1+tstart(ibuff)), + & trept(1+tstart(ibuff)),tbcol(1+tstart(ibuff)),lenrow,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 30 i=1,tfld + 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 +30 continue + if (status .gt. 0)go to 900 + +C check that the sum of the column widths = NAXIS2 value + if (rowlen(ibuff) .ne. lenrow)then + status=241 + write(cnaxis,1001)rowlen(ibuff) + write(clen,1001)lenrow +1001 format(i8) + call ftpmsg('NAXIS1 ='//cnaxis//' not equal'// + & ' to the sum of the column widths ='//clen//' (FTBINI).') + end if + end if + +900 continue + end |