Initial commit

1 files changed, 241 insertions, 0 deletions

diff --git a/pkg/tbtables/tbfhg.x b/pkg/tbtables/tbfhg.x
new file mode 100644
index 00000000..4799909a
--- /dev/null
+++ b/pkg/tbtables/tbfhg.x
@@ -0,0 +1,241 @@
+include <tbset.h>
+include "tbtables.h"
+
+# Get a parameter from a FITS table header.
+#
+# Phil Hodge,  6-Jul-1995  Subroutine created
+# Phil Hodge, 14-Aug-1997  In tbfhgt, allocate local buffer.
+# Phil Hodge,  5-Aug-1999  In tbfhgt, for history or comment, copy the
+#		comment field to output, rather than the value field.
+
+# tbfhgd -- get double-precision header parameter
+
+procedure tbfhgd (tp, keyword, value)
+
+pointer tp		# i: pointer to table descriptor
+char	keyword[ARB]	# i: name of parameter to get
+double	value		# o: value of parameter
+#--
+pointer sp
+pointer sval		# for getting the value as a string
+pointer comment		# for getting the comment
+int	status		# zero is OK
+int	ip, junk, ctod()
+errchk	tbferr
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_LINE, TY_CHAR)
+	call salloc (comment, SZ_LINE, TY_CHAR)
+
+	status = 0
+
+	# Get the value as a string.
+	call fsgkey (TB_FILE(tp), keyword, Memc[sval], Memc[comment], status)
+	if (status != 0)
+	    call tbferr (status)
+
+	ip = 1
+	if (Memc[sval] == '\'')
+	    ip = 2				# skip over the quote
+	else if (Memc[sval] == 'T')
+	    Memc[sval] = '1'
+	else if (Memc[sval] == 'F')
+	    Memc[sval] = '0'
+
+	value = INDEFD
+	junk = ctod (Memc[sval], ip, value)
+
+	call sfree (sp)
+end
+
+# tbfhgr -- get single-precision header parameter
+
+procedure tbfhgr (tp, keyword, value)
+
+pointer tp		# i: pointer to table descriptor
+char	keyword[ARB]	# i: name of parameter to get
+real	value		# o: value of parameter
+#--
+pointer sp
+pointer sval		# for getting the value as a string
+pointer comment		# for getting the comment
+int	status		# zero is OK
+int	ip, junk, ctor()
+errchk	tbferr
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_LINE, TY_CHAR)
+	call salloc (comment, SZ_LINE, TY_CHAR)
+
+	status = 0
+
+	# Get the value as a string.
+	call fsgkey (TB_FILE(tp), keyword, Memc[sval], Memc[comment], status)
+	if (status != 0)
+	    call tbferr (status)
+
+	ip = 1
+	if (Memc[sval] == '\'')
+	    ip = 2				# skip over the quote
+	else if (Memc[sval] == 'T')
+	    Memc[sval] = '1'
+	else if (Memc[sval] == 'F')
+	    Memc[sval] = '0'
+
+	value = INDEFR
+	junk = ctor (Memc[sval], ip, value)
+
+	call sfree (sp)
+end
+
+# tbfhgi -- get integer header parameter
+
+procedure tbfhgi (tp, keyword, value)
+
+pointer tp		# i: pointer to table descriptor
+char	keyword[ARB]	# i: name of parameter to get
+int	value		# o: value of parameter
+#--
+pointer sp
+pointer sval		# for getting the value as a string
+pointer comment		# for getting the comment
+double	dval
+int	status		# zero is OK
+int	ip, junk, ctod()
+errchk	tbferr
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_LINE, TY_CHAR)
+	call salloc (comment, SZ_LINE, TY_CHAR)
+
+	status = 0
+
+	# Get the value as a string.
+	call fsgkey (TB_FILE(tp), keyword, Memc[sval], Memc[comment], status)
+	if (status != 0)
+	    call tbferr (status)
+
+	ip = 1
+	if (Memc[sval] == '\'')
+	    ip = 2				# skip over the quote
+	else if (Memc[sval] == 'T')
+	    Memc[sval] = '1'
+	else if (Memc[sval] == 'F')
+	    Memc[sval] = '0'
+
+	dval = INDEFD
+	junk = ctod (Memc[sval], ip, dval)
+	if (IS_INDEFD(dval))
+	    value = INDEFI
+	else
+	    value = nint (dval)
+
+	call sfree (sp)
+end
+
+# tbfhgb -- get Boolean header parameter
+# If the header keyword is not T or F, then zero is interpreted as false,
+# and any other numerical value is true.
+
+procedure tbfhgb (tp, keyword, value)
+
+pointer tp		# i: pointer to table descriptor
+char	keyword[ARB]	# i: name of parameter to get
+bool	value		# o: value of parameter
+#--
+pointer sp
+pointer sval		# for getting the value as a string
+pointer comment		# for getting the comment
+double	dval
+int	status		# zero is OK
+int	ip, junk, ctod()
+errchk	tbferr
+
+begin
+	call smark (sp)
+	call salloc (sval, SZ_LINE, TY_CHAR)
+	call salloc (comment, SZ_LINE, TY_CHAR)
+
+	status = 0
+
+	# Get the value as a string.
+	call fsgkey (TB_FILE(tp), keyword, Memc[sval], Memc[comment], status)
+	if (status != 0)
+	    call tbferr (status)
+
+	call strupr (Memc[sval])
+
+	ip = 1
+	if (Memc[sval] == '\'')
+	    ip = 2				# skip over the quote
+
+	if (Memc[sval+ip-1] == 'T') {
+	    value = true
+	    call sfree (sp)
+	    return
+	} else if (Memc[sval+ip-1] == 'F') {
+	    value = false
+	    call sfree (sp)
+	    return
+	}
+
+	dval = INDEFD
+	junk = ctod (Memc[sval], ip, dval)
+	if (IS_INDEFD(dval))
+	    value = false
+	else if (nint (dval) == 0)
+	    value = false
+	else
+	    value = true
+
+	call sfree (sp)
+end
+
+# tbfhgt -- get text-string header parameter
+
+procedure tbfhgt (tp, keyword, text, maxch)
+
+pointer tp		# i: pointer to table descriptor
+char	keyword[ARB]	# i: name of parameter to get
+char	text[ARB]	# o: value of parameter
+int	maxch		# i: maximum number of characters to get
+#--
+pointer sp
+pointer temp		# for getting the value
+pointer comment		# for getting the comment
+int	i
+int	status		# zero is OK
+int	strlen()
+bool	tbhisc()
+errchk	tbferr
+
+begin
+	call smark (sp)
+	call salloc (temp, max (maxch, SZ_FNAME), TY_CHAR)
+	call salloc (comment, SZ_FNAME, TY_CHAR)
+
+	status = 0
+
+	call fsgkys (TB_FILE(tp), keyword, Memc[temp], Memc[comment], status)
+	if (status != 0)
+	    call tbferr (status)
+
+	# For COMMENT and HISTORY keywords, FITSIO returns the value in
+	# the comment argument rather than the value argument.
+	if (tbhisc (keyword))
+	    call strcpy (Memc[comment], Memc[temp], SZ_FNAME)
+
+	# Trim trailing blanks.
+	do i = strlen (Memc[temp]), 1, -1 {
+	    if (Memc[temp+i-1] == ' ')
+		Memc[temp+i-1] = EOS
+	    else
+		break
+	}
+	call strcpy (Memc[temp], text, maxch)
+
+	call sfree (sp)
+end