diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftgtbn.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftgtbn.f | 123 |
1 files changed, 123 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftgtbn.f b/pkg/tbtables/fitsio/ftgtbn.f new file mode 100644 index 00000000..cf3c73bc --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbn.f @@ -0,0 +1,123 @@ +C---------------------------------------------------------------------- + subroutine ftgtbn(iunit,ncols,nrows,pcount,nfield,status) + +C check that this is a valid binary table and get parameters +C +C iunit i Fortran i/o unit number +C ncols i width of each row of the table, in bytes +C nrows i number of rows in the table +C pcount i size of special data area following the table (usually = 0) +C nfield i number of fields in the table +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,ncols,nrows,nfield,pcount,status + character keynam*8,value*10,comm*8,rec*80 + + if (status .gt. 0)return + +C check for correct type of extension + call ftgrec(iunit,1,rec,status) + if (status .gt. 0)go to 900 + + keynam=rec(1:8) + + if (keynam .eq. 'XTENSION')then + call ftpsvc(rec,value,comm,status) + if (status .gt. 0)go to 900 + + if (value(2:9) .ne. 'BINTABLE' .and. + & value(2:9) .ne. 'A3DTABLE' .and. + & value(2:9) .ne. '3DTABLE ')then +C this is not a binary table extension + status=227 + go to 900 + end if + else + status=225 + go to 900 + end if + +C check that the second keyword is BITPIX = 8 + call fttkyn(iunit,2,'BITPIX','8',status) + if (status .eq. 208)then +C BITPIX keyword not found + status=222 + else if (status .eq. 209)then +C illegal value of BITPIX + status=211 + end if + if (status .gt. 0)go to 900 + +C check that the third keyword is NAXIS = 2 + call fttkyn(iunit,3,'NAXIS','2',status) + if (status .eq. 208)then +C NAXIS keyword not found + status=223 + else if (status .eq. 209)then +C illegal NAXIS value + status=212 + end if + if (status .gt. 0)go to 900 + +C check that the 4th keyword is NAXIS1 and get it's value + call ftgtkn(iunit,4,'NAXIS1',ncols,status) + if (status .eq. 208)then +C NAXIS1 keyword not found + status=224 + else if (status .eq. 209)then +C illegal value of NAXISnnn + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 5th keyword is NAXIS2 and get it's value + call ftgtkn(iunit,5,'NAXIS2',nrows,status) + if (status .eq. 208)then +C NAXIS2 keyword not found + status=224 + else if (status .eq. 209)then +C illegal value of NAXISnnn + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 6th keyword is PCOUNT and get it's value + call ftgtkn(iunit,6,'PCOUNT',pcount,status) + if (status .eq. 208)then +C PCOUNT keyword not found + status=228 + else if (status .eq. 209)then +C illegal PCOUNT value + status=214 + end if + if (status .gt. 0)go to 900 + +C check that the 7th keyword is GCOUNT = 1 + call fttkyn(iunit,7,'GCOUNT','1',status) + if (status .eq. 208)then +C GCOUNT keyword not found + status=229 + else if (status .eq. 209)then +C illegal value of GCOUNT + status=215 + end if + if (status .gt. 0)go to 900 + +C check that the 8th keyword is TFIELDS and get it's value + call ftgtkn(iunit,8,'TFIELDS',nfield,status) + if (status .eq. 208)then +C TFIELDS keyword not found + status=230 + else if (status .eq. 209)then +C illegal value of TFIELDS + status=216 + end if + +900 continue + if (status .gt. 0)then + call ftpmsg('Failed to parse the required keywords in '// + & 'the binary BINTABLE header (FTGTTB).') + end if + end |