1 files changed, 113 insertions, 0 deletions
diff --git a/pkg/tbtables/tbfcal.x b/pkg/tbtables/tbfcal.x
new file mode 100644
index 00000000..51c380ee
--- /dev/null
+++ b/pkg/tbtables/tbfcal.x
@@ -0,0 +1,113 @@
+include <ctype.h>		# for IS_WHITE
+include <tbset.h>
+include "tbtables.h"
+
+# tbfcal -- copy all header parameters for FITS table
+# All header parameters are copied from the input to the output table,
+# both of which must be open.  This version should be used when either
+# the input or output table is in a FITS file.
+#
+# Phil Hodge,  6-Jul-1995  Subroutine created
+# Phil Hodge, 13-Nov-1995  Change type of tbfres from bool to int.
+# Phil Hodge, 14-Aug-1997  Don't clobber EXTVER if it's already present.
+
+procedure tbfcal (itp, otp)
+
+pointer itp		# i: pointer to descriptor of input table
+pointer otp		# i: pointer to descriptor of output table
+#--
+pointer sp
+pointer value		# buffer for header record for parameter
+pointer comment		# scratch for comment string
+pointer extname		# buffer for copying extname
+char	keyword[SZ_KEYWORD]	# parameter name
+int	dtype		# data type of parameter
+int	i
+int	ip
+
+# buffers for copying the value
+double	dval
+real	rval
+int	ival
+bool	bval
+
+bool	streq()
+int	tbhgti()
+int	tbfres()
+errchk	tbferr, tbhgnp, tbhgti, tbhgtt
+
+begin
+	call smark (sp)
+	call salloc (value, SZ_LINE, TY_CHAR)
+	call salloc (comment, SZ_FNAME, TY_CHAR)
+	call salloc (extname, SZ_LINE, TY_CHAR)
+
+	# Copy each parameter except for the reserved keywords,
+	# such as XTENSION, TTYPEn.
+	do i = 1, TB_NPAR(itp) {
+
+	    # Get Nth keyword and value from the input table.
+	    call tbhgnp (itp, i, keyword, dtype, Memc[value])
+
+	    if (tbfres (keyword) == YES)	# ignore reserved keywords
+		next
+
+	    # Don't clobber EXTNAME or EXTVER if they're already present in
+	    # the output.
+	    if (streq (keyword, "EXTNAME")) {
+		ifnoerr (call tbhgtt (otp, "EXTNAME", Memc[extname], SZ_LINE))
+		    next
+	    }
+	    if (streq (keyword, "EXTVER")) {
+		ifnoerr (ip = tbhgti (otp, "EXTVER"))	# use ip as scratch
+		    next
+	    }
+
+	    # Read the value into an appropriate buffer, and add it
+	    # to the output table header.
+	    switch (dtype) {
+	    case TY_REAL:
+		dval = INDEFD
+		call sscan (Memc[value])
+		    call gargd (dval)
+		rval = dval
+		call tbhadr (otp, keyword, rval)
+	    case TY_DOUBLE:
+		dval = INDEFD
+		call sscan (Memc[value])
+		    call gargd (dval)
+		call tbhadd (otp, keyword, dval)
+	    case TY_INT:
+		ival = INDEFI
+		call sscan (Memc[value])
+		    call gargi (ival)
+		call tbhadi (otp, keyword, ival)
+	    case TY_CHAR:
+		call tbhadt (otp, keyword, Memc[value])
+	    case TY_BOOL:
+		ip = 0
+		while (IS_WHITE(Memc[value+ip]))
+		    ip = ip + 1
+		if (Memc[value+ip] == 'T' || Memc[value+ip] == 't') {
+		    bval = true
+		} else if (Memc[value+ip] == 'F' || Memc[value+ip] == 'f') {
+		    bval = false
+		} else {
+		    # Read 1 or 0 for true or false respectively.
+		    ival = NO
+		    call sscan (Memc[value+ip])
+			call gargi (ival)
+		    bval = (ival != NO)
+		}
+		call tbhadb (otp, keyword, bval)
+	    default:
+		call error (1, "tbhcal:  bad data type")
+	    }
+
+	    # Copy the comment from input to output.
+	    call tbhgcm (itp, keyword, Memc[comment], SZ_FNAME)
+	    call tbhpcm (otp, keyword, Memc[comment])
+	}
+
+	call sfree (sp)
+end