Repatch (from linux) of OSX IRAF

1 files changed, 99 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/lib/select.x b/pkg/utilities/nttools/lib/select.x
new file mode 100644
index 00000000..02cc73f8
--- /dev/null
+++ b/pkg/utilities/nttools/lib/select.x
@@ -0,0 +1,99 @@
+include	"reloperr.h"
+
+# SELECT -- Select table rows according to expression
+#
+# This procedure evaluates a boolean expession for selected rows in a table.
+# If the expression is true and does not involve null elements, the index
+# of that row is kept in the index array.
+#
+# B.Simon	 7-Oct-87	First Code
+# B.Simon	16-Dec-87	Changed to handle table subsets
+# B.Simon	06-Jan-93	Changed to use ftnexpr
+
+procedure select (tp, expr, nindex, index)
+
+pointer	tp		#  i: Table descriptor
+char	expr[ARB]	#  i: Algebraic expression used in selection
+int	nindex		# io: Number of rows selected
+int	index[ARB]	# io: Indices of selected rows
+#--
+char	ch
+pointer	sp, oldexp, newexp, ic, aryptr, nulptr
+int	fd, sd, jc, dtype, nary, iary
+
+int	open(), stropen(), stridx()
+
+errchk	open, stropen, tbl_eval
+
+string	badtype	"Expression is not boolean"
+
+begin
+	# Allocate dynamic memory for strings
+
+	call smark (sp)
+	call salloc (oldexp, SZ_COMMAND, TY_CHAR)
+	call salloc (newexp, SZ_COMMAND, TY_CHAR)
+
+	# Check to see if the expression is a file name
+
+	if (expr[1] == '@') {
+
+	    # Copy the file into a string
+
+	    fd = open (expr[2], READ_ONLY, TEXT_FILE)
+	    sd = stropen (Memc[oldexp], SZ_COMMAND, WRITE_ONLY)
+	    call fcopyo (fd, sd)
+	    call close (fd)
+	    call strclose (sd)
+
+	    # Replace the newlines with blanks
+
+	    ic = oldexp
+	    ch = '\n'
+	    repeat {
+		jc = stridx (ch, Memc[ic])
+		if (jc == 0)
+		    break
+		ic = ic + jc
+		Memc[ic-1] = ' '
+	    }
+
+	    # Convert Fortran relational operators to SPP
+
+	    call ftnexpr (Memc[oldexp], Memc[newexp], SZ_COMMAND)
+
+	} else {
+
+	    # Convert Fortran relational operators to SPP
+
+	    call ftnexpr (expr, Memc[newexp], SZ_COMMAND)
+	}
+	    
+	# Evaluate the expression
+
+	dtype = TY_BOOL
+	call tbl_eval (tp, nindex, index, Memc[newexp], dtype, aryptr, nulptr)
+
+	# Check to see if result is boolean
+
+	if (dtype != TY_BOOL) {
+	    call mfree (aryptr, dtype)
+	    call mfree (nulptr, TY_BOOL)
+	    call error (SYNTAX, badtype)
+	}
+
+	# Put indices of true, non-null rows in index array
+
+	nary = nindex
+	nindex = 0
+	do iary = 1, nary
+
+	    if (Memb[aryptr+iary-1] && ! Memb[nulptr+iary-1]) {
+		nindex = nindex + 1
+		index[nindex] = index[iary]
+	    }
+
+	call mfree (aryptr, dtype)
+	call mfree (nulptr, TY_BOOL)
+	call sfree (sp)
+end