diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftgatp.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftgatp.f | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftgatp.f b/pkg/tbtables/fitsio/ftgatp.f new file mode 100644 index 00000000..1556915e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgatp.f @@ -0,0 +1,169 @@ +C-------------------------------------------------------------------------- + subroutine ftgatp(ibuff,keynam,value,status) + +C Get ASCII Table Parameter +C test if the keyword is one of the table column definition keywords +C of an ASCII table. If so, decode it and update the value in the common +C block + +C ibuff i sequence number of the data buffer +C keynam c name of the keyword +C value c value of the keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ibuff,status + character keynam*8,value*70 + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- +C nb = number of file buffers = max. number of FITS file opened at once +C nf = maximum number of fields allowed in a table + integer nf,nb + parameter (nb = 20) + parameter (nf = 3000) + +C tfield = number of fields in the table +C tbcol = byte offset in the row of the beginning of the column +C rowlen = length of one row of the table, in bytes +C tdtype = integer code representing the datatype of the column +C trept = the repeat count = number of data values/element in the column +C tnull = the value used to represent an undefined value in the column +C tscale = the scale factor for the column +C tzero = the scaling zero point for the column +C scount = the total size of the binary table heap (+ gap if any) +C theap = the starting byte offset for the binary table heap, relative +C to the start of the binary table data +C nxheap = the next empty heap location + 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) + +C cnull = character string representing nulls in character columns +C cform = the Fortran format of the column + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer nfield,i,c2,bcol,tstat + character tform*16 + + if (status .gt. 0)return + tstat=status + + if (keynam(1:5) .eq. 'TFORM')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TFORMn keyword + status=tstat + else +C get the TFORM character string, without quotes + call ftc2s(value,tform,status) + if (status .gt. 0)return + if (tform(1:1) .ne. 'A' .and. tform(1:1) .ne. 'I' + & .and. tform(1:1) .ne. 'F' .and. tform(1:1) .ne. 'E' + & .and. tform(1:1) .ne. 'D')then + status=311 + call ftpmsg('Illegal '//keynam//' format code: ' + & //tform) + return + end if + + cform(nfield+tstart(ibuff))=tform +C set numeric data type code to indicate an ASCII table field + tdtype(nfield+tstart(ibuff))=16 +C set the repeat count to 1 + trept(nfield+tstart(ibuff))=1 +C set the TNULL parameter to the width of the field: + c2=0 + do 10 i=2,8 + if (tform(i:i) .ge. '0' .and. tform(i:i) + & .le. '9')then + c2=i + else + go to 20 + end if +10 continue +20 continue + + if (status .gt. 0)return + if (c2 .eq. 0)then +C no explicit field width, so assume width=1 character + tnull(nfield+tstart(ibuff))=1 + else + call ftc2ii(tform(2:c2),tnull(nfield+ + & tstart(ibuff)),status) + if (status .gt. 0)then +C error parsing the TFORM value string + status=261 + call ftpmsg('Error parsing '//keynam//' field width: ' + & //tform) + end if + end if + end if + else if (keynam(1:5) .eq. 'TBCOL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TBCOLn keyword + status=tstat + else +C get the beginning column number + call ftc2ii(value,bcol,status) + if (status .gt. 0)then + call ftpmsg('Error reading value of '//keynam + & //' as an integer: '//value) + else + tbcol(nfield+tstart(ibuff))=bcol-1 + end if + end if + else if (keynam(1:5) .eq. 'TSCAL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TSCALn keyword + status=tstat + else +C get the scale factor + call ftc2dd(value,tscale(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TZERO')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TZEROn keyword + status=tstat + else +C get the scaling zero point + call ftc2dd(value,tzero(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TNULL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TNULLn keyword + status=tstat + else +C get the Null value flag (character) + call ftc2s(value,cnull(nfield+tstart(ibuff)),status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a character string: '//value) + end if + end if + end if + end |