diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftaini.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftaini.f | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftaini.f b/pkg/tbtables/fitsio/ftaini.f new file mode 100644 index 00000000..1f7d2d70 --- /dev/null +++ b/pkg/tbtables/fitsio/ftaini.f @@ -0,0 +1,183 @@ +C-------------------------------------------------------------------------- + subroutine ftaini(iunit,status) + +C initialize the parameters defining the structure of an ASCII 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 nrows,tfld,nkey,ibuff,i,nblank + character keynam*8,value*70,comm*72,rec*80 + character cnum*3,cbcol*10,caxis1*10 + + 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 (1 = ASCII table extension) + hdutyp(ibuff)=1 + +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 ASCII table, and get parameters + call ftgttb(iunit,rowlen(ibuff),nrows,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 ASCII table has too many fields '// + & 'to be read with FITSIO (FTAINI).') + 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. +C choose special value to indicate that null value is not defined + cnull(i+tstart(ibuff))=char(1) +C pre-set required keyword values to a null value + tbcol(i+tstart(ibuff))=-1 + tdtype(i+tstart(ibuff))=-9999 +5 continue + +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 there is no special data following an ASCII table + scount(ibuff)=0 + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=0 + +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 ASCII table'// + & ' header (FTAINI).') + 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 ASCII table parameter (if it is one) + call ftpsvc(rec,value,comm,status) + call ftgatp(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 (tbcol(i+tstart(ibuff)) .eq. -1)then + status=231 + call ftkeyn('TBCOL',i,keynam,status) + call ftpmsg('Required '//keynam// + & ' keyword not found (FTAINI).') + return + else if (tbcol(i+tstart(ibuff)) .lt. 0 .or. + & tbcol(i+tstart(ibuff)) .ge. rowlen(ibuff) + & .and. rowlen(ibuff) .ne. 0)then + status=234 + call ftkeyn('TBCOL',i,keynam,status) + call ftpmsg('Value of the '//keynam// + & ' keyword is out of range (FTAINI).') + return + +C check that column fits within the table + else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) .gt. + & rowlen(ibuff) .and. rowlen(ibuff) .ne. 0)then + status=236 + write(cnum,1000)i + write(cbcol,1001)tbcol(i+tstart(ibuff))+1 + write(caxis1,1001)rowlen(ibuff) +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 + else 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, +C ignoring 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+2879)/2880*2880 + +900 continue + end |