diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftadef.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftadef.f | 143 |
1 files changed, 143 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftadef.f b/pkg/tbtables/fitsio/ftadef.f new file mode 100644 index 00000000..5c516448 --- /dev/null +++ b/pkg/tbtables/fitsio/ftadef.f @@ -0,0 +1,143 @@ +C-------------------------------------------------------------------------- + subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status) + +C Ascii table data DEFinition +C define the structure of the ASCII table data unit +C +C ounit i Fortran I/O unit number +C lenrow i length of a row, in characters +C nfield i number of fields in the table +C bcol i starting position of each column, (starting with 1) +C tform C the data format of the column +C nrows i number of rows in the table +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,lenrow,nfield,bcol(*),nrows,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,clen,c2 + character ctemp*24, cnum*3,cbcol*10,caxis1*10 + + 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)=1 + 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 + clen=len(tform(1)) + do 20 i=1,nfield + tscale(i+tstart(ibuff))=1. + tzero(i+tstart(ibuff))=0. +C choose special value to indicate null values are not defined + cnull(i+tstart(ibuff))=char(1) + cform(i+tstart(ibuff))=tform(i) + tbcol(i+tstart(ibuff))=bcol(i)-1 + tdtype(i+tstart(ibuff))=16 +C the repeat count is always one for ASCII tables + trept(i+tstart(ibuff))=1 +C store the width of the field in TNULL + c2=0 + do 10 j=2,clen + if (tform(i)(j:j) .ge. '0' .and. + & tform(i)(j:j) .le. '9')then + c2=j + else + go to 15 + end if +10 continue +15 continue + if (c2 .eq. 0)then +C no explicit width, so assume width of 1 character + tnull(i+tstart(ibuff))=1 + else + call ftc2ii(tform(i)(2:c2),tnull(i+tstart(ibuff)) + & ,status) + if (status .gt. 0)then +C error parsing TFORM to determine field width + status=261 + ctemp=tform(i) + call ftpmsg('Error parsing TFORM to get field' + & //' width: '//ctemp) + return + end if + end if + +C check that column fits within the table + if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) + & .gt. lenrow .and. lenrow .ne. 0)then + status=236 + write(cnum,1000)i + write(cbcol,1001)bcol(i) + write(caxis1,1001)lenrow +1000 format(i3) +1001 format(i10) + call ftpmsg('Column '//cnum//' will not fit '// + & 'within the specified width of the ASCII table.') + + call ftpmsg('TFORM='//cform(i+tstart(ibuff))// + & ' TBCOL='//cbcol//' NAXIS1='//caxis1) + return + end if +20 continue + +C calculate the start of the next header unit, based on the +C size of the data unit + rowlen(ibuff)=lenrow + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880 + +C initialize the fictitious heap starting address (immediately following +C the table data) and a zero length heap. This is used to find the +C end of the table data when checking the fill values in the last block. +C ASCII tables have no special data area + scount(ibuff)=0 + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=0 + end if + end |