Initial commit

1 files changed, 137 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftbnfm.f b/pkg/tbtables/fitsio/ftbnfm.f
new file mode 100644
index 00000000..92c18590
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftbnfm.f
@@ -0,0 +1,137 @@
+C----------------------------------------------------------------------
+        subroutine ftbnfm(form,dtype,rcount,width,status)
+
+C       'Binary Format'
+C       parse the binary table column format to determine the data
+C       type and the repeat count (and string width, if it is an ASCII field)
+C
+C       form    c  format string
+C       OUTPUT PARAMETERS:
+C       dattyp  i  datatype code
+C       rcount  i  repeat count
+C       width   i  if ASCII field, this is the width of the unit string
+C       status  i  output error status
+C
+C       written by Wm Pence, HEASARC/GSFC, June 1991
+
+        character*(*) form
+        integer dtype,rcount,width,status,tstat
+        character dattyp*1,cform*16
+        integer point,nc,c1,i,nw
+
+        if (status .gt. 0)return
+
+        cform=form
+
+C       find first non-blank character
+        nc=len(form)
+        do 5 i=1,nc
+                if (form(i:i) .ne. ' ')then
+                        c1=i
+                        go to 10
+                end if
+5       continue
+
+C       error: TFORM is a blank string
+        status=261
+        call ftpmsg('The TFORM keyword has a blank value.')
+        return
+
+10      continue
+
+C       find the size of the field repeat count, if present
+        nw=0
+        do 20 i=c1,nc
+                if (form(i:i) .ge. '0' .and. form(i:i) .le. '9')then
+                        nw=nw+1
+                else
+                        go to 30
+                end if
+20      continue
+30      continue
+        if (nw .eq. 0)then
+C               no explicit repeat count, so assume a value of 1
+                rcount=1
+        else
+                call ftc2ii(form(c1:c1+nw-1),rcount,status)
+                if (status .gt. 0)then
+                   call ftpmsg('Error in FTBNFM evaluating TFORM'
+     &             //' repeat value: '//cform)
+                   return
+                 end if
+        end if
+
+        c1=c1+nw
+
+C       see if this is a variable length pointer column (e.g., 'rPt'); if so,
+C       then add 1 to the starting search position in the TFORM string
+        if (form(c1:c1) .eq. 'P')then
+                point=-1
+                c1=c1+1
+                rcount=1
+        else
+                point=1
+        end if
+
+C       now the chararcter at position c1 should be the data type code
+        dattyp=form(c1:c1)
+
+C       set the numeric datatype code
+        if (dattyp .eq. 'I')then
+                dtype=21
+        else if (dattyp .eq. 'J')then
+                dtype=41
+        else if (dattyp .eq. 'E')then
+                dtype=42
+        else if (dattyp .eq. 'D')then
+                dtype=82
+        else if (dattyp .eq. 'A')then
+                dtype=16
+        else if (dattyp .eq. 'L')then
+                dtype=14
+        else if (dattyp .eq. 'X')then
+                dtype=1
+        else if (dattyp .eq. 'B')then
+                dtype=11
+        else if (dattyp .eq. 'C')then
+                dtype=83
+        else if (dattyp .eq. 'M')then
+                dtype=163
+        else
+C               unknown tform datatype code
+                status=262
+                call ftpmsg('Unknown Binary table TFORMn keyword '//
+     &                      'datatype: '//cform)
+                return
+        end if
+                
+C       set dtype negative if this is a variable length field ('P')
+        dtype=dtype*point
+
+C       if this is an ASCII field, determine its width
+        if (dtype .eq. 16)then
+                c1=c1+1
+                nw=0
+                do 40 i=c1,nc
+                    if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then
+                        nw=nw+1
+                else
+                        go to 50
+                end if
+40              continue
+50              continue
+                if (nw .eq. 0)then
+C                       no explicit width field, so assume that the
+C                       width is the same as the repeat count
+                        width=rcount
+                else
+                        tstat=status
+                        call ftc2ii(form(c1:c1+nw-1),width,status)
+                        if (status .gt. 0)then
+C                       unrecognized characters following the 'A', so ignore it
+                               width=rcount
+                               status=tstat
+                        end if
+                end if
+        end if
+        end