Repatch (from linux) of OSX IRAF

1 files changed, 212 insertions, 0 deletions

diff --git a/pkg/xtools/mef/mefwrhdr.x b/pkg/xtools/mef/mefwrhdr.x
new file mode 100644
index 00000000..90ec337e
--- /dev/null
+++ b/pkg/xtools/mef/mefwrhdr.x
@@ -0,0 +1,212 @@
+include <error.h>
+include <pkg/mef.h>
+
+# MEF_WRHDR -- Append the header from an input PHU or extension to output file.
+
+procedure mef_wrhdr (mefi, mefo, in_phdu)
+
+pointer	mefi		#I input mef descriptor
+pointer	mefo		#I output mef descriptor
+bool	in_phdu		#I true if input header is Primary Header Unit.
+
+pointer hb, sp, ln
+int	output_lines, out, offset
+int	i, index, naxis, mef_kctype(), strncmp(), note()
+bool    endk, new_outf
+errchk  open, fcopyo
+
+define	nextb_ 99
+
+begin
+	call smark (sp)
+	call salloc (ln, LEN_CARDNL, TY_CHAR)
+
+	# At this point the input first header has been read
+
+	hb = MEF_HDRP(mefi)
+	if (Memc[hb] == NULL)
+	   call error(13,"mef_wrhdr: input header buffer is empty")
+
+	out = MEF_FD(mefo)
+
+	new_outf = false
+	if (MEF_ACMODE(mefo) == NEW_IMAGE)
+	   new_outf = true
+
+	output_lines = 0
+	endk = false
+
+	# If we want to copy the header with no modification
+	if (MEF_KEEPXT(mefo) == YES) {
+	    for (i=1; i<37; i=i+1) {
+	       switch (mef_kctype(Memc[hb], index)) {
+	       case END:
+		   call mef_pakwr (out, Memc[hb])
+		   endk = true
+		   output_lines = i
+		   break
+	       default:
+		   call mef_pakwr (out, Memc[hb])
+		   hb = hb + LEN_CARDNL
+	       }
+	    }
+	    goto nextb_
+	} 
+
+	# Check for 1st card
+	if (strncmp (Memc[hb], "SIMPLE  ", 8) == 0) {
+	    # Append extension to existing file
+	    if (!new_outf) {            
+	        call mef_encodec ("XTENSION", "IMAGE", 5, Memc[ln],
+		    "Image extension")
+	        call mef_pakwr (out, Memc[ln])
+	    } else
+	        call mef_pakwr (out, Memc[hb])
+	} else if (strncmp (Memc[hb], "XTENSION", 8) == 0 ) {
+	    if (new_outf) {
+	        # Create a PHU
+	        # Must create a dummy header if input extension is not image
+		if (strncmp (MEF_EXTTYPE(mefi), "IMAGE", 5) != 0) {
+		    Memc[ln] = EOS
+		    call mef_dummyhdr (out, Memc[ln])
+		    new_outf = false
+	            call mef_pakwr (out, Memc[hb])
+	        } else {
+	            call mef_encodeb ("SIMPLE", YES, Memc[ln],
+		        "Standard FITS format")
+	            call mef_pakwr (out, Memc[ln])
+		}
+	    } else
+	        call mef_pakwr (out, Memc[hb])
+	} else {
+	    # Is the wrong kind of header
+#	    call eprintf ("File %s is not FITS\n")
+#		call erract (EA_FATAL)
+	    call sprintf (Memc[ln],LEN_CARD, "File %s is not FITS")
+	        call pargstr(MEF_FNAME(mefi))
+            call error(13, Memc[ln])			
+	}
+	hb = hb + LEN_CARDNL
+
+	for (i=2; i<37; i=i+1) {
+	   switch (mef_kctype(Memc[hb], index)) {
+	   case BITPIX:
+	      # Get to calculate totpix value
+	      call mef_gvali (Memc[hb], MEF_BITPIX(mefi))
+	   case NAXIS:
+	      naxis = index
+	      MEF_NDIM(mefi) = index
+	      if (in_phdu && !new_outf && naxis == 0) {
+	         call mef_pakwr (out, Memc[hb])
+		 call mef_wrpgcount (out)
+	         output_lines = output_lines + 2
+		 hb = hb + LEN_CARDNL
+		 next
+	      }
+	   case NAXISN:
+	      call mef_gvali (Memc[hb], MEF_NAXIS(mefi,index))
+	      call mef_pakwr (out, Memc[hb])
+	      if (index == naxis) {
+	          if (in_phdu && !new_outf ) {
+		      # We are writing from a phu to ehu.
+		      # 2 new cards PCOUNT and GCOUNT
+
+		      call mef_wrpgcount (out)
+		      output_lines = output_lines + 2
+	          }			
+	          if (!in_phdu && new_outf) {
+		      # We are writing from a ehu to a phu
+		      call mef_encodeb ("EXTEND", YES, Memc[ln],
+			  "There may be extensions")
+		      call mef_pakwr (out, Memc[ln])
+		      output_lines = output_lines + 1
+		  }   
+	      }
+	      hb = hb + LEN_CARDNL
+	      next
+	   case EXTEND, FILENAME:
+	      if (!new_outf) {
+		  # Do not put these cards  when going to an ehu
+	          output_lines = output_lines - 1
+	          hb = hb + LEN_CARDNL
+		  next
+	      }
+	   case INHERIT:
+	      # Eliminate INHERIT keyword from an input IMAGE extension
+	      # when creating a new output file. If file already exists
+	      # then pass the card along.
+
+	      if (new_outf) {
+	          output_lines = output_lines - 1
+	          hb = hb + LEN_CARDNL
+		  next
+	      } 
+	   case PCOUNT,GCOUNT,EXTNAME,EXTVER:   
+	      # Do not put these cards into PHU
+	      if (new_outf) {
+	         output_lines = output_lines - 1
+	         hb = hb + LEN_CARDNL
+		 next
+	      } 
+	   case END:
+	      call mef_pakwr (out, Memc[hb])
+	      endk = true
+	      output_lines = i + output_lines
+	      break
+	   default:
+	      ;
+	   }
+	   call mef_pakwr (out, Memc[hb])
+	   hb = hb + LEN_CARDNL
+
+	} # end for loop
+
+nextb_
+	# See if we need to keep reading header
+	#
+	if (!endk) 
+	   repeat {
+	      for (i=1; i<37; i=i+1) {
+	        if (strncmp (Memc[hb], "END     ", 8) == 0) {
+	           call mef_pakwr (out, Memc[hb])
+		   endk = true
+		   output_lines = i + output_lines
+		   break
+	        }
+	        call mef_pakwr (out, Memc[hb])
+		hb = hb + LEN_CARDNL
+	      }
+              if (endk) break
+	      
+	   } #end repeat
+           
+	   offset = note(out)-1     # to base zero
+	   call mef_padfile (out, offset)
+	   call flush(out)
+
+	call sfree(sp)
+end
+
+procedure mef_padfile (fd, offset)
+
+int	fd	  # file descriptor
+int	offset    # file position in chars
+
+int     pad, nlines,i
+char	card[LEN_CARDNL]
+
+begin
+        i = mod(offset, 1440)
+	if (i == 0) return
+
+	pad = 1440 - i
+	nlines = pad/40
+
+        do i =1, 80
+              card[i] = ' '
+        call achtcb (card, card, 80)
+
+        for(i=1; i<=nlines; i=i+1)
+           call write(fd, card, 40)
+
+end