Repatch (from linux) of OSX IRAF

4 files changed, 216 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/tproject/mkpkg b/pkg/utilities/nttools/tproject/mkpkg
new file mode 100644
index 00000000..f7c30ad4
--- /dev/null
+++ b/pkg/utilities/nttools/tproject/mkpkg
@@ -0,0 +1,13 @@
+# Update the tproject application code in the ttools package library
+# Author: B.Simon, 25-NOV-1987
+
+$checkout libpkg.a ../
+$update   libpkg.a
+$checkin  libpkg.a ../
+$exit
+
+libpkg.a:
+        nextuniq.x              <tbset.h>
+ 	tproject.x     		<tbset.h>
+	wproject.x     		<tbset.h> 
+	;
diff --git a/pkg/utilities/nttools/tproject/nextuniq.x b/pkg/utilities/nttools/tproject/nextuniq.x
new file mode 100644
index 00000000..2a2b8e8d
--- /dev/null
+++ b/pkg/utilities/nttools/tproject/nextuniq.x
@@ -0,0 +1,39 @@
+include <tbset.h>
+
+# NEXTUNIQ -- Retrieve the next unique row from a table
+
+procedure nextuniq (tp, numptr, colptr, irow)
+
+pointer tp              # i: Table descriptor
+int     numptr          # i: Number of column pointers
+pointer colptr[ARB]     # i: Array of column pointers
+int     irow		# u: Current unique row
+#--
+bool	fold
+int	jrow, krow, nrow
+
+data	fold  / false /
+
+int	tbpsta(), tbrcmp()
+
+begin
+	# Get number of rows in table
+
+	nrow = tbpsta (tp, TBL_NROWS)
+
+	# Loop until a row that does not match the preceding rows is found
+
+	for (jrow = irow+1; jrow <= nrow; jrow = jrow + 1) {
+	    for (krow = 1; krow < jrow; krow = krow + 1) {
+		if (tbrcmp (tp, numptr, colptr, fold, jrow, krow) == 0)
+		    break
+	    }
+
+	    if (krow == jrow)
+		break
+	}
+
+	# Set irow to the first row that does not match any preceding row
+
+	irow = jrow
+end
diff --git a/pkg/utilities/nttools/tproject/tproject.x b/pkg/utilities/nttools/tproject/tproject.x
new file mode 100644
index 00000000..6f74e272
--- /dev/null
+++ b/pkg/utilities/nttools/tproject/tproject.x
@@ -0,0 +1,100 @@
+include <fset.h>	# for F_REDIR
+include <tbset.h>
+
+# T_PROJECT -- Create a new table from selected columns of an old table
+#
+# B.Simon	20-Oct-1987	First Code
+# Phil Hodge	07-Sep-1988	Change parameter names for tables.
+# B.Simon	31-Mar-1992	Set output table type from input table
+# Phil Hodge	 4-Oct-1995	Use table name template routines tbnopenp, etc.
+# Phil Hodge	 8-Apr-1999	Call tbfpri.
+# B.Simon	30-Apr-1999	Replace call to unique with nextuniq
+# Phil Hodge	 9-Jun-1999	Set input/output to STDIN/STDOUT if redirected.
+
+procedure t_project()
+
+pointer ilist			# Input table name template
+pointer olist			# Output table name template
+pointer	columns			# Table column template
+bool	uniq			# Should output rows be unique?
+#--
+int	junk, numcol, numptr, type
+int	phu_copied		# set by tbfpri and ignored
+pointer sp, itp, otp, intable, outtable, colptr
+
+string	nomatch		"Number of input tables must match output tables"
+string	notfound	"Column(s) not found in table"
+
+bool	clgetb()
+int	fstati()
+int	tbnget(), tbnlen(), tbpsta()
+pointer	tbtopn(), tbnopenp(), tbnopen()
+
+begin
+	# Allocate stack memory for strings
+
+	call smark (sp)
+	call salloc (intable, SZ_FNAME, TY_CHAR)
+	call salloc (outtable, SZ_FNAME, TY_CHAR)
+	call salloc (columns, SZ_LINE, TY_CHAR)
+
+	# Read the task parameters
+
+	if (fstati (STDIN, F_REDIR) == YES)
+	    ilist = tbnopen ("STDIN")
+	else
+	    ilist = tbnopenp ("intable")
+
+	if (fstati (STDOUT, F_REDIR) == YES)
+	    olist = tbnopen ("STDOUT")
+	else
+	    olist = tbnopenp ("outtable")
+
+	call clgstr ("columns", Memc[columns], SZ_LINE)
+	uniq = clgetb ("uniq")
+
+	# Loop over all table names in the input file name template
+
+	if (tbnlen (ilist) != tbnlen (olist))
+	    call error (1, nomatch)
+
+	while (tbnget (ilist, Memc[intable], SZ_FNAME) != EOF) {
+
+	    junk = tbnget (olist, Memc[outtable], SZ_FNAME)
+
+	    # Open the tables and set output table type
+
+	    itp = tbtopn (Memc[intable], READ_ONLY, NULL)
+	    call tbfpri (Memc[intable], Memc[outtable], phu_copied)
+	    otp = tbtopn (Memc[outtable], NEW_FILE, NULL)
+
+	    type = tbpsta (itp, TBL_WHTYPE)
+	    call tbpset (otp, TBL_WHTYPE, type)
+
+	    # Create an array of column pointers from the column template
+
+	    numcol = tbpsta (itp, TBL_NCOLS)
+	    call malloc (colptr, numcol, TY_INT)
+
+	    call tctexp (itp, Memc[columns], numcol, numptr, Memi[colptr])
+
+	    if (numptr == 0)
+		call error (1, notfound)
+
+	    # Copy header and selected columns to output table
+
+	    call wproject (itp, otp, numptr, Memi[colptr], uniq)
+
+	    # Close the tables and free dynamic memory
+
+	    call tbtclo (itp)
+	    call tbtclo (otp)
+	    call mfree (colptr, TY_INT)
+	}
+
+	# Close the filename template lists
+
+	call tbnclose (ilist)
+	call tbnclose (olist)
+	call sfree (sp)
+end
diff --git a/pkg/utilities/nttools/tproject/wproject.x b/pkg/utilities/nttools/tproject/wproject.x
new file mode 100644
index 00000000..176032ab
--- /dev/null
+++ b/pkg/utilities/nttools/tproject/wproject.x
@@ -0,0 +1,64 @@
+include	<tbset.h>
+
+# WPROJECT -- Copy selected columns and rows to output table
+#
+# B.Simon	19-Oct-87	First Code
+# B.Simon	30-Apr-1999	Replace call to unique with nextuniq
+
+procedure wproject (itp, otp, numptr, colptr, uniq)
+
+pointer	itp		# i: Input table descriptor
+pointer	otp		# i: Output table descriptor
+int	numptr		# i: Number of column pointers
+pointer	colptr[ARB]	# i: Array of column pointers
+bool	uniq		# i: Only output unique rows?
+#--
+int	iptr, irow, jrow, nrow
+int	colnum[1], datatype[1], lendata[1], lenfmt[1]
+pointer	sp, ocp, newcol, colname, colunits, colfmt
+
+int	tbpsta()
+
+begin
+	# Set up arrays in dynamic memory
+
+	call smark (sp)
+	call salloc (newcol, numptr, TY_INT)
+	call salloc (colname, SZ_COLNAME, TY_CHAR)
+	call salloc (colunits, SZ_COLUNITS, TY_CHAR)
+	call salloc (colfmt, SZ_COLFMT, TY_CHAR)
+
+
+	# Copy column information from the input table to the output table
+
+	do iptr = 1, numptr {
+    	    call tbcinf (colptr[iptr], colnum, Memc[colname], Memc[colunits],
+			 Memc[colfmt], datatype[1], lendata[1], lenfmt[1])
+	    call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt],
+			 datatype[1], lendata[1], 1)
+	    Memi[newcol+iptr-1] = ocp    
+	}
+
+	# Copy the table columns a row at a time
+
+	call tbtcre (otp)
+	call tbhcal (itp, otp)
+
+	irow = 1
+	jrow = 1
+	nrow = tbpsta (itp, TBL_NROWS)
+
+	while (irow <= nrow) {
+	    call tbrcsc (itp, otp, colptr, Memi[newcol], irow, jrow, numptr)
+
+	    if (uniq) {
+		call nextuniq (itp, numptr, colptr, irow)
+	    } else {
+		irow = irow + 1
+	    }
+
+	    jrow = jrow + 1
+	}
+
+	call sfree (sp)
+end