Repatch (from linux) of OSX IRAF

1 files changed, 189 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftiblk.f b/pkg/tbtables/fitsio/ftiblk.f
new file mode 100644
index 00000000..9c61fd12
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftiblk.f
@@ -0,0 +1,189 @@
+C--------------------------------------------------------------------------
+        subroutine ftiblk(ounit,nblock,hdrdat,status)
+
+C       insert a 2880-byte block at the end of the current header or data.
+
+C       ounit   i  fortran output unit number
+C       nblock  i  number of blocks to insert
+C       hdrdat  i  insert space in header (0) or data (1)
+C       status  i  returned error status (0=ok)
+
+        integer ounit,nblock,hdrdat,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
+        character*1 buff(2880,2)
+        common/ftheap/buff
+C       END OF COMMON BLOCK DEFINITIONS:------------------------------------
+
+        integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin
+        character*1 cfill
+
+        if (status .gt. 0)return
+        tstat=status
+
+C       get the number of the data buffer used for this unit
+        ibuff=bufnum(ounit)
+
+C       set the appropriate fill value
+        if (hdrdat .eq. 0 .or. hdutyp(ibuff) .eq. 1)then
+C               fill  header or ASCII table with space
+                cfill=char(32)
+        else
+C               fill with Null (0) in image or bintable data area        
+                cfill=char(0)
+        end if
+
+C       find position in file to insert new block
+        if (hdrdat .eq. 0)then
+            ipoint=dtstrt(ibuff)
+        else
+            ipoint=hdstrt(ibuff,chdu(ibuff)+1)
+        end if
+
+
+        if (nblock .eq. 1 .and. hdrdat .eq. 0)then
+C******************************************************************
+C  Don't use this algoritm, even though it may be faster (but initial
+C  tests showed it didn't make any difference on a SUN) because it is
+C  less safe than the other more general algorithm.  If there is
+C  not enough disk space available for the added block, this faster
+C  algorithm won't fail until it tries to move the last block, thus leaving
+C  the FITS file in a corrupted state.   The other more general
+C  algorithm tries to add a new empty block to the file as the
+C  first step.  If this fails, it still leaves the current FITS
+C  file unmodified, which is better for the user.  
+C******************************************************************
+C  (Note added later:)
+C  Will use this algorithm anyway when inserting one block in a FITS
+C  header because the more general algorithm results in a status=252 error
+C  in cases where the number of rows in a table has not yet been defined
+C******************************************************************
+C           use this more efficient algorithm if just adding a single block
+C           initialize the first buffer
+            do 5 i=1,2880
+               buff(i,1)=cfill
+5           continue
+
+            in=2
+            out=1
+
+C           move to the read start position
+10          call ftmbyt(ounit,ipoint,.false.,status)
+
+C           read one 2880-byte FITS logical record into the input buffer
+            call ftgcbf(ounit,0,2880,buff(1,in),status)
+
+C           check for End-Of-File
+            if (status .eq. 107)go to 20
+
+C           move back to the write start postion
+            call ftmbyt(ounit,ipoint,.false.,status)
+
+C           write the 2880-byte FITS logical record stored in the output buffer
+            call ftpcbf(ounit,0,2880,buff(1,out),status)
+
+C           check for error during write (the file may not have write access)
+            if (status .gt. 0)return
+
+C           swap the input and output buffer pointers and move to next block
+            tin=in
+            in=out
+            out=tin
+            ipoint=ipoint+2880
+
+C           now repeat the process until we reach the End-Of-File
+            go to 10
+
+C           we have reached the end of file; now append the last block
+20          status=tstat
+
+C           move back to the write start postion
+            call ftmbyt(ounit,ipoint,.true.,status)
+
+C           write the 2880-byte FITS logical record stored in the output buffer
+            call ftpcbf(ounit,0,2880,buff(1,out),status)
+
+        else
+C           use this general algorithm for adding arbitrary number of blocks
+
+C           first, find the end of file
+            thdu=chdu(ibuff)
+
+30          call ftmahd(ounit,maxhdu(ibuff)+1,i,status)
+
+            if (status .eq. 107)then
+                status=tstat
+C               move back to the current extension
+                call ftmahd(ounit,thdu,i,status)
+                go to 100
+            else if (status .le. 0)then
+                go to 30
+            else
+                call ftpmsg('Error while seeking End of File (FTIBLK)')
+                return
+            end if
+
+C           calculate number of 2880-byte blocks that have to be shifted down
+100         continue
+            nshift=(hdstrt(ibuff,maxhdu(ibuff)+1)-ipoint)/2880
+            jpoint=hdstrt(ibuff,maxhdu(ibuff)+1)-2880
+
+C           move all the blocks, one at a time, starting at end of file and
+C           working back to the insert position
+            do 110 i=1,nshift
+
+C               move to the read start position
+                call ftmbyt(ounit,jpoint,.false.,status)
+
+C               read one 2880-byte FITS logical record
+                call ftgcbf(ounit,0,2880,buff,status)
+
+C               move forward to the write start postion
+                call ftmbyt(ounit,jpoint+nblock*2880,.true.,status)
+
+C               write the 2880-byte FITS logical record
+                call ftpcbf(ounit,0,2880,buff,status)
+
+C               check for error 
+                if (status .gt. 0)then
+                    call ftpmsg('Error inserting empty FITS block(s) '//
+     &              '(FTIBLK)')
+                    return
+                end if
+                jpoint=jpoint-2880
+110         continue
+
+            do 120 i=1,2880
+                buff(i,1)=cfill
+120         continue
+             
+C           move back to the write start postion
+            call ftmbyt(ounit,ipoint,.true.,status)
+
+            do 130 i=1,nblock
+C               write the 2880-byte FITS logical record 
+                call ftpcbf(ounit,0,2880,buff,status)
+130         continue
+        end if
+
+        if (hdrdat .eq. 0)then
+C               recalculate the starting location of the current data unit
+                dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock
+        end if
+
+C       recalculate the starting location of all subsequent HDUs
+        do 140 i=chdu(ibuff)+1,maxhdu(ibuff)+1
+                    hdstrt(ibuff,i)=hdstrt(ibuff,i)+2880*nblock
+140     continue
+        if (status .gt. 0)then
+            call ftpmsg('Error inserting FITS block(s) (FTIBLK)')
+        end if
+        end