Repatch (from linux) of OSX IRAF

1 files changed, 250 insertions, 0 deletions

diff --git a/pkg/obsolete/fits/fits_cards.x b/pkg/obsolete/fits/fits_cards.x
new file mode 100644
index 00000000..fe4829c9
--- /dev/null
+++ b/pkg/obsolete/fits/fits_cards.x
@@ -0,0 +1,250 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <imhdr.h>
+include "wfits.h"
+
+# WFT_STANDARD_CARD -- Procedure for fetching the minimum header
+# parameters required by fits. The end card is encoded separately.
+
+int procedure wft_standard_card (cardno, im, fits, axisno, card)
+
+int	cardno		# number of FITS standard card
+pointer	im		# pointer to the IRAF image
+pointer	fits		# pointer to the FITS structure
+int	axisno		# axis number
+char	card[ARB]	# FITS card image
+
+char	keyword[LEN_KEYWORD]
+errchk	wft_encodeb, wft_encodei, wft_encodel, wft_encode_axis
+include "wfits.com"
+
+begin
+	# Get mandatory keywords.
+	switch (cardno) {
+	case FIRST_CARD:
+	    call wft_encodeb ("SIMPLE", YES, card, "FITS STANDARD")
+	case SECOND_CARD:
+	    call wft_encodei ("BITPIX", FITS_BITPIX(fits), card,
+	    "FITS BITS/PIXEL")
+	case THIRD_CARD:
+	    call wft_encodei ("NAXIS", NAXIS(im), card, "NUMBER OF AXES")
+	default:
+	    call wft_encode_axis ("NAXIS", keyword, axisno)
+	    call wft_encodel (keyword, NAXISN(im, axisno), card, "")
+	    axisno = axisno + 1
+	}
+
+	return (YES)
+end
+
+
+# WFT_OPTION_CARD -- Procedure for fetching  optional FITS header parameters.
+# At present these are bscale, bzero, bunit, blank, object, origin, date,
+# irafmax, irafmin, iraf type and iraf bits per pixel. Blank is only encoded
+# if there are a nonzero number of blanks in the IRAF image. Bunit and object
+# are only encoded if the appropriate IRAF strings are defined. Bzero, bscale,
+# irafmax, irafmin, iraf type and iraf bits per pixel are only encoded if
+# there is a pixel file.
+
+int procedure wft_option_card (im, fits, optiono, card)
+
+pointer	im		# pointer to the IRAF image
+pointer	fits		# pointer to FITS structure
+int	optiono		# number of the option card
+char	card[ARB]	# FITS card image
+
+char	datestr[LEN_STRING]
+int	len_object, stat
+int	strlen()
+errchk	wft_encoded, wft_encodec, wft_encode_blank, wft_encoder, wft_encodei
+errchk	wft_encode_date 
+
+begin
+	 stat = YES
+
+	 # get optional keywords
+	 switch (optiono) {
+	 case KEY_BSCALE:
+	    if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0))
+		stat = NO
+	    else {
+	        call wft_encoded ("BSCALE", BSCALE(fits), card,
+	        "REAL = TAPE*BSCALE + BZERO", NDEC_DOUBLE)
+	    }
+	 case KEY_BZERO:
+	    if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0))
+		stat = NO
+	    else
+	        call wft_encoded ("BZERO", BZERO(fits), card, "", NDEC_DOUBLE)
+	 case KEY_BUNIT:
+	    stat = NO
+	 case KEY_BLANK:
+	    stat = NO
+	    #if (NBPIX(im) == 0)
+		#stat = NO
+	    #else
+		#call wft_encode_blank ("BLANK", BLANK_STRING(fits), card,
+		#"TAPE VALUE OF BLANK PIXEL")
+	case KEY_OBJECT:
+	    if (OBJECT(im) == EOS)
+		stat = NO
+	    else {
+		len_object = max (min (LEN_OBJECT, strlen (OBJECT(im))),
+		    LEN_STRING)
+		call wft_encodec ("OBJECT", OBJECT(im), len_object, card, "")
+	    }
+	case KEY_ORIGIN:
+	    call wft_encodec ("ORIGIN", "KPNO-IRAF", LEN_ORIGIN, card, "")
+	case KEY_DATE:
+	    call wft_encode_date (datestr, LEN_STRING)
+	    call wft_encodec ("DATE", datestr, LEN_STRING, card, "")
+	case KEY_IRAFNAME:
+	    len_object = max (min (LEN_OBJECT, strlen (IRAFNAME(fits))),
+		LEN_STRING)
+	    call wft_encodec ("IRAFNAME", IRAFNAME(fits), len_object, card, 
+		"NAME OF IRAF IMAGE FILE")
+	case KEY_IRAFMAX:
+	    if (NAXIS(im) <= 0)
+		stat = NO
+	    else
+	        call wft_encoder ("IRAF-MAX", IRAFMAX(fits), card, "DATA MAX",
+				NDEC_REAL)
+	case KEY_IRAFMIN:
+	    if (NAXIS(im) <= 0)
+		stat = NO
+	    else
+	        call wft_encoder ("IRAF-MIN", IRAFMIN(fits), card, "DATA MIN",
+		NDEC_REAL)
+	case KEY_IRAFBP:
+	    if (NAXIS(im) <= 0)
+		stat = NO
+	    else
+	        call wft_encodei ("IRAF-BPX", DATA_BITPIX(fits), card,
+	    	    "DATA BITS/PIXEL")
+	case KEY_IRAFTYPE:
+	    if (NAXIS(im) <= 0)
+		stat = NO
+	    else
+	        call wft_encodec ("IRAFTYPE", TYPE_STRING(fits), LEN_STRING,
+	    		    card, "PIXEL TYPE")
+	default:
+	    stat = NO
+	}
+
+	optiono = optiono + 1
+
+	return (stat)
+end
+
+
+# WFT_HISTORY_CARD -- Procedure to fetch a single history line, trim newlines
+# and pad with blanks to size LEN_CARD in order to create a FITS HISTORY card.
+
+int procedure wft_history_card (im, hp, card)
+
+pointer	im		# pointer to the IRAF image
+int	hp		# pointer to first character to extract from string
+char	card[ARB]	# FITS card image
+
+char	cval
+char	chfetch()
+
+begin
+	if (chfetch (HISTORY(im), hp, cval) == EOS)
+	    return (NO)
+	else {
+	    hp = hp - 1
+	    call strcpy ("HISTORY ", card, LEN_KEYWORD)
+	    call wft_fits_card (HISTORY(im), hp, card, COL_VALUE - 2, LEN_CARD,
+		'\n')
+	    return (YES)
+	}
+end
+
+
+# WFT_UNKNOWN_CARD  -- Procedure to fetch a single unknown
+# "line", trim newlines and pad blanks to size LEN_CARD in order to
+# create an unknown keyword card. At present user area information is
+# assumed to be in the form of FITS card images, less then or equal to
+# 80 characters and delimited by a newline.
+
+int procedure wft_unknown_card (im, up, card)
+
+pointer	im		# pointer to the IRAF image
+int	up		# pointer to next character in the unknown string
+char	card[ARB]	# FITS card image
+
+char	cval
+int	stat, axis, index
+char	chfetch()
+int	strmatch(), ctoi()
+
+begin
+	if (chfetch (UNKNOWN(im), up, cval) == EOS)
+	    return (NO)
+	else {
+	    up = up - 1
+	    stat = NO
+	    while (stat == NO)  {
+	        call wft_fits_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n')
+		if (card[1] == EOS)
+		    break
+	        if (strmatch (card, "^GROUPS  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^SIMPLE  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^BITPIX  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^NAXIS   ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^NAXIS") != 0) {
+		    index = LEN_NAXIS_KYWRD + 1
+		    if (ctoi (card, index, axis) > 0)
+		        stat = NO
+		    else
+			stat = YES
+	        } else if (strmatch (card, "^GCOUNT  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^PCOUNT  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^PSIZE   ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^BSCALE  ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^BZERO   ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^BLANK   ") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^IRAF-MAX") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^IRAF-MIN") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^IRAFTYPE") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^IRAF-B/P") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^IRAF-BPX") != 0) {
+		    stat = NO
+	        } else if (strmatch (card, "^END     ") != 0) {
+		    stat = NO
+	        } else
+                    stat = YES
+	    }
+
+	    return (stat)
+	}
+end
+
+
+# WFT_LAST_CARD -- Procedure to encode the FITS end card.
+
+int procedure wft_last_card (card)
+
+char	card[ARB]	# FITS card image
+
+begin
+	call sprintf (card, LEN_CARD, "%-8.8s  %70w")
+	    call pargstr ("END")
+
+	return (YES)
+end