Initial commit

1 files changed, 72 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftirec.f b/pkg/tbtables/fitsio/ftirec.f
new file mode 100644
index 00000000..a3c47d85
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftirec.f
@@ -0,0 +1,72 @@
+C--------------------------------------------------------------------------
+        subroutine ftirec(ounit,pos,record,status)
+
+C       insert a 80-char keyword record into the header at the pos-th keyword
+C       position (i.e., immediately before the current keyword at position POS.
+C
+C       ounit   i  fortran output unit number
+C       pos     i  keyword will be inserted at this position (1 = 1st keyword)
+C       record  c*80  keyword record
+C       OUTPUT PARAMETERS
+C       status  i  output error status (0 = ok)
+C
+C       written by Wm Pence, HEASARC/GSFC, Jan 1995
+
+        character*(*) record
+        integer ounit,pos,status
+
+C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
+        integer nb,ne
+        parameter (nb = 20)
+        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
+C-------END OF COMMON BLOCK DEFINITIONS:------- -----------------------------
+
+        character*80 outrec, inrec
+        integer ibuff, fkey, lkey, i, nexthd, nkey
+
+        if (status .gt. 0)return
+
+C       get the number of the data buffer used for this unit
+        ibuff=bufnum(ounit)
+
+C       calculate number of existing keywords
+        nkey=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80
+
+        if (pos .eq. nkey+1)then
+C               simply append the record to the header
+                call ftprec(ounit,record,status)
+                return
+        else if (pos .lt. 1 .or. pos .gt.  nkey)then
+                status=203
+                return
+        end if
+
+        outrec=record
+
+C       move to the insert position
+        nexthd=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80
+        call ftmbyt(ounit,nexthd,.false.,status)
+        nxthdr(ibuff)=nexthd
+
+C       calculated the first and last keyword to be rewritten
+        fkey=pos
+        lkey=fkey + (hdend(ibuff)-nexthd)/80 - 1
+
+C       now sequentially read each keyword and overwrite it with the previous
+        do 10 i=fkey,lkey
+                call ftgrec(ounit,i,inrec,status)
+                call ftmodr(ounit,outrec,status)
+                outrec=inrec
+10      continue
+
+C       finally, write the last keyword
+        call ftprec(ounit,outrec,status)
+
+C       reset the next keyword pointer to follow the inserted keyword
+        nxthdr(ibuff)=nexthd+80
+        end