1 files changed, 141 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/threed/tscopy/tcpyone.x b/pkg/utilities/nttools/threed/tscopy/tcpyone.x
new file mode 100644
index 00000000..23c86316
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/tcpyone.x
@@ -0,0 +1,141 @@
+include	<tbset.h>
+
+#* HISTORY *
+#* B.Simon	07-Nov-1994	original
+#  Phil Hodge	 8-Apr-1999	call tbfpri
+
+# TCPYONE -- Copy a single table to the output table
+
+procedure tcpyone (input, output)
+
+char	input[ARB]	# i: input table name
+char	output[ARB]	# i: output table name
+#--
+int     numrow, numcol, numptr, type, iptr, irow, jrow
+int     colnum, datatype, lendata, lenfmt
+int	phu_copied	# returned by tbfpri and ignored
+pointer	sp, root, extend, rowselect, colselect, colname, colunits, colfmt
+pointer errmsg, icp, ocp, itp, otp, colptr, newcol, pcode
+
+string	nosect  "Sections not permitted on output table name (%s)"
+string	nocols  "Column names not found (%s)"
+
+errchk	tbfpri, tbtopn, tctexp, tbracket, trsopen, trseval
+
+bool	trseval(), streq()
+int	tbpsta(), tcs_totsize()
+pointer	tbtopn(), tcs_column, trsopen()
+
+begin
+	# Allocate memory for temporary strings
+
+	call smark (sp)
+	call salloc (root, SZ_FNAME, TY_CHAR)
+	call salloc (extend, SZ_FNAME, TY_CHAR)
+	call salloc (rowselect, SZ_FNAME, TY_CHAR)
+	call salloc (colselect, SZ_FNAME, TY_CHAR)
+        call salloc (colname, SZ_COLNAME, TY_CHAR)
+        call salloc (colunits, SZ_COLUNITS, TY_CHAR)
+        call salloc (colfmt, SZ_COLFMT, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	# Check output table name for sections
+
+#	call getsects (output, Memc[root], Memc[extend], Memc[rowselect], 
+#		       Memc[colselect], SZ_FNAME)
+
+call rdselect (output, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME)
+
+	if (Memc[rowselect] != EOS || Memc[colselect] != EOS) {
+	    call sprintf (Memc[errmsg], SZ_LINE, nosect)
+	    call pargstr (output)
+	    call error (1, Memc[errmsg])
+	}
+
+	# Break input file names into bracketed sections
+
+#	call getsects (input, Memc[root], Memc[extend], Memc[rowselect], 
+#		       Memc[colselect], SZ_FNAME)
+
+call rdselect (input, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME)
+
+	if (Memc[rowselect] == EOS && Memc[colselect] == EOS) {
+	    # Perform straight file copy if no sections on input name
+
+	    call tbfpri (input, output, phu_copied)
+	    call tbtcpy (input, output)
+
+	} else {
+            # Open the tables and set output table type
+
+#	    call strcat (Memc[extend], Memc[root], SZ_FNAME)
+
+            itp = tbtopn (Memc[root], READ_ONLY, NULL)
+	    call tbfpri (Memc[root], output, phu_copied)
+            otp = tbtopn (output, NEW_FILE, NULL)
+
+            type = tbpsta (itp, TBL_WHTYPE)
+	    # Support for ASCII output (11/20/96, IB)
+	    if (streq (output, "STDOUT"))
+	        type = TBL_TYPE_TEXT
+            call tbpset (otp, TBL_WHTYPE, type)
+
+            # Create an array of column pointers from the column template
+
+	    numrow = tbpsta (itp, TBL_NROWS)
+            numcol = tbpsta (itp, TBL_NCOLS)
+
+            call salloc (colptr, numcol, TY_INT)
+	    call salloc (newcol, numcol, TY_INT)
+
+	    call tcs_open (itp, Memc[colselect], Memi[colptr], numptr, numcol)
+
+	    # Take an error exit if no columns were matched
+
+            if (numptr == 0) {
+		call sprintf (Memc[errmsg], SZ_LINE, nocols)
+		call pargstr (input)
+		call error (1, Memc[errmsg])
+	    }
+
+	    # Copy column information from the input table to the output table
+
+	    do iptr = 1, numptr {
+		icp = tcs_column (Memi[colptr+iptr-1])
+		call tbcinf (icp, colnum, Memc[colname], Memc[colunits], 
+			     Memc[colfmt], datatype, lendata, lenfmt)
+
+		if (lendata > 1)
+		    lendata = tcs_totsize (Memi[colptr+iptr-1])
+
+		call tbcdef (otp, ocp, Memc[colname], Memc[colunits], 
+			     Memc[colfmt], datatype, lendata, 1)
+		Memi[newcol+iptr-1] = ocp    
+	    }
+
+	    # Copy header keywords
+
+	    call tbtcre (otp)
+	    call tbhcal (itp, otp)
+
+	    # Copy selected rows from input to output table
+
+	    jrow = 1
+	    pcode = trsopen (itp, Memc[rowselect])
+
+	    do irow = 1, numrow {
+		if (trseval (itp, irow, pcode)) {
+		    call tcpyrow (itp, otp, Memi[colptr], Memi[newcol], 
+				  irow, jrow, numptr)
+		    jrow = jrow + 1
+		}
+	    }
+
+	    call trsclose (pcode)
+	    call tcs_close (Memi[colptr], numptr)
+            call tbtclo (itp)
+            call tbtclo (otp)
+	}
+
+	call sfree (sp)
+end