Repatch (from linux) of OSX IRAF

1 files changed, 140 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftgcnn.f b/pkg/tbtables/fitsio/ftgcnn.f
new file mode 100644
index 00000000..d8348147
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftgcnn.f
@@ -0,0 +1,140 @@
+C--------------------------------------------------------------------------
+        subroutine ftgcnn(iunit,casesn,templt,colnam,colnum,status)
+
+C       determine the column name and number corresponding to an input 
+C       column name template string.  The template may contain the * and ?
+C       wildcards.  Status = 237 is returned if match is not unique.
+C       One may call this routine again with input status=237  to
+C       get the next match.  
+
+C       iunit   i  Fortran i/o unit number
+C       casesn  l  true if an exact case match of the names is required
+C       templt  c  templt for column name
+C       colnam  c  name of (first) column that matchs the template
+C       colnum  i  number of the column (first column = 1)
+C                       (a value of 0 is returned if the column is not found)
+C       status  i  returned error status
+
+C       written by Wm Pence, HEASARC/GSFC, December 1994
+
+        integer iunit,colnum,status
+        character*(*) templt,colnam
+        logical casesn
+
+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)
+        integer colpnt,untpnt
+        common/ftname/colpnt,untpnt
+C       END OF COMMON BLOCK DEFINITIONS------------------------------------
+
+        integer ibuff,i,nfound,tstat,ival
+        logical match,exact,founde,foundw,unique
+        character*80 errmsg
+        character*68 tname(999)
+        save tname
+
+        ibuff=bufnum(iunit)
+
+C       load the common block with names, if not already defined
+        if (colpnt .eq. -999 .or. iunit .ne. untpnt)then
+            do 10 i=1,tfield(ibuff)
+                tname(i)=' '
+10          continue
+            call ftgkns(iunit,'TTYPE',1,nf,tname,nfound,status)
+            if (status .gt. 0)return
+            untpnt=iunit
+            colpnt=1
+        end if
+
+        if (status .le. 0)then
+            tstat=0
+            colpnt=1
+        else if (status .eq. 237)then
+C           search for next non-unique match, starting from the previous match
+            tstat=237
+            status=0
+        else
+            return
+        end if
+
+        colnam=' '
+        colnum=0
+
+
+C       set the 'found exact' and 'found wildcard' flags to false
+        founde=.false.
+        foundw=.false.
+       
+        do 100 i=colpnt,tfield(ibuff)
+C               test for match between template and column name
+                call ftcmps(templt,tname(i),casesn,match,exact)
+
+                if (match)then
+                    if (founde .and. exact)then
+C                       warning: this is the second exact match we've found
+C                       reset pointer to first match so next search starts there
+                        colpnt=colnum+1
+                        status=237
+                        return
+                    else if (founde)then
+C                       already found exact match so ignore this non-exact match
+                    else if (exact)then
+C                       this is the first exact match we have found, so save it.
+                        colnam=tname(i)
+                        colnum=i
+                        founde=.true.
+                    else if (foundw)then
+C                       we have already found a wild card match, so not unique
+C                       continue searching for other matches
+                        unique=.false.
+                    else
+C                       this is the first wild card match we've found. save it
+                        colnam=tname(i)
+                        colnum=i
+                        foundw=.true.
+                        unique=.true.
+                    end if
+                end if
+100     continue        
+
+C       OK, we've checked all the names now see if we got any matches
+        if (founde)then
+C           we did find 1 exact match
+            if (tstat .eq. 237)status=237
+        else if (foundw)then
+C           we found one or more wildcard matches
+C           report error if not unique
+            if (.not. unique .or. tstat .eq. 237)status=237
+        else
+C           didn't find a match; check if template is a simple positive integer
+            call ftc2ii(templt,ival,tstat)
+            if (tstat .eq. 0 .and. ival .le. tfield(ibuff) 
+     &          .and. ival .gt. 0)then
+                colnum=ival
+                colnam=tname(ival)
+            else
+                status=219
+                if (tstat .ne. 237)then
+                  errmsg='FTGCNN: Could not find column: '//templt
+                  call ftpmsg(errmsg)
+                end if
+            end if
+        end if
+
+C       reset pointer so next search starts here if input status=237
+        colpnt=colnum+1
+        end