Initial commit

1 files changed, 219 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/tmatch/infomatch.x b/pkg/utilities/nttools/tmatch/infomatch.x
new file mode 100644
index 00000000..d90f89a8
--- /dev/null
+++ b/pkg/utilities/nttools/tmatch/infomatch.x
@@ -0,0 +1,219 @@
+include	<tbset.h>
+
+#* HISTORY *
+#* B.Simon	25-Aug-94	original
+
+# INFOMATCH -- Print diagnostic information for tmatch
+
+procedure infomatch (diagfile, in1, in2, nmcol1, nmcol2, maxnorm, 
+		     nclosest, closest, dist)
+
+char	diagfile[ARB]	# i: diagnostic output file
+pointer	in1		# i: first table's descriptor
+pointer	in2		# i: second table's descriptor
+char	nmcol1[ARB]	# i: name columns in first table
+char	nmcol2[ARB]	# i: name columns in second table
+double	maxnorm		# i: maximum allowed distance between matched rows
+int	nclosest	# i: length of closest array
+int	closest[ARB]	# i: array of closest matches between tables
+double	dist[ARB]	# i: distance between matched rows
+#--
+bool	first, same
+int	fd, namelen, mxcol1, mxcol2, ncol1, ncol2, idx, jdx, irow, jrow
+pointer	sp, index, name, col1, col2
+
+string	ziptitle  "\nThe following objects were not matched:\n"
+string	duptitle  "\nThe following objects matched the same object:\n"
+string	bigtitle  "\nThe following objects have the largest norms:\n"
+string	normfmt   "Norm = %0.7g\n"
+string	rowformat "%d:%d %s\n"
+
+bool	is_blank()
+int	open(), envgeti(), tbpsta()
+
+begin
+	# Open the diagnostics file
+
+	if (is_blank (diagfile))
+	    return
+
+	fd = open (diagfile, WRITE_ONLY, TEXT_FILE)
+
+	# Get maximum length of diagnostic string
+
+	iferr {
+	    namelen = envgeti ("ttyncols") - 10
+	} then {
+	    namelen = 70
+	}
+
+	# Allocate dynamic memory
+
+	call smark (sp)
+	call salloc (index, nclosest, TY_INT)
+	call salloc (name, namelen, TY_CHAR)
+
+	# Get column descriptors for name columns
+
+	mxcol1 = tbpsta (in1, TBL_NCOLS)
+	mxcol2 = tbpsta (in2, TBL_NCOLS)
+
+	call salloc (col1, mxcol1, TY_INT)
+	call salloc (col2, mxcol2, TY_INT)
+
+	if (is_blank (nmcol1)) {
+	    ncol1 = 0
+	} else {
+	    call tctexp (in1, nmcol1, mxcol1, ncol1, Memi[col1])
+	}
+
+	if (is_blank (nmcol2)) {
+	    ncol2 = 0
+	} else {
+	    call tctexp (in2, nmcol2, mxcol2, ncol2, Memi[col2])
+	}
+
+	# Sort the closest array
+
+	call setindex (Memi[index], nclosest)
+	call sortclose (nclosest, closest, Memi[index])
+
+	# Print the objects that were not matched
+
+	first = true
+	do idx = 1, nclosest {
+	    irow = Memi[index+idx-1]
+	    if (closest[irow] != 0)
+		break
+
+	    if (first) {
+		first = false
+		call fprintf (fd, ziptitle)
+	    }
+
+	    call rowname (in1, irow, ncol1, Memi[col1], Memc[name], namelen)
+	    call fprintf (fd, rowformat)
+	    call pargi (1)
+	    call pargi (irow)
+	    call pargstr (Memc[name])
+	}
+
+	# Print the objects which are matched more than once
+
+	same = false
+	first = true
+	do idx = 2, nclosest {
+	    irow = Memi[index+idx-1]
+	    jrow = Memi[index+idx-2]
+
+	    if (closest[irow] == 0)
+		next
+
+	    if (closest[irow] == closest[jrow]) {
+		same = true
+
+		if (first) {
+		    first = false
+		    call fprintf (fd, duptitle)
+		}
+
+		call rowname (in1, jrow, ncol1, Memi[col1], 
+			      Memc[name], namelen)
+
+		call fprintf (fd, rowformat)
+		call pargi (1)
+		call pargi (jrow)
+		call pargstr (Memc[name])
+
+	    } else if (same) {
+		same = false
+
+		call rowname (in1, jrow, ncol1, Memi[col1], 
+			      Memc[name], namelen)
+
+		call fprintf (fd, rowformat)
+		call pargi (1)
+		call pargi (jrow)
+		call pargstr (Memc[name])
+
+		call rowname (in2, closest[jrow], ncol2, Memi[col2],
+			      Memc[name], namelen)
+
+		call fprintf (fd, rowformat)
+		call pargi (2)
+		call pargi (closest[jrow])
+		call pargstr (Memc[name])
+
+		call fprintf (fd, "\n")
+	    }
+	}
+
+	if (same) {
+	    same = false
+	    irow = Memi[index+nclosest-1]
+
+	    call rowname (in1, irow, ncol1, Memi[col1], 
+			  Memc[name], namelen)
+
+	    call fprintf (fd, rowformat)
+	    call pargi (1)
+	    call pargi (irow)
+	    call pargstr (Memc[name])
+
+	    call rowname (in2, closest[irow], ncol2, Memi[col2],
+			  Memc[name], namelen)
+
+	    call fprintf (fd, rowformat)
+	    call pargi (2)
+	    call pargi (closest[irow])
+	    call pargstr (Memc[name])
+
+	    call fprintf (fd, "\n")
+	}
+
+	# Sort the dist array
+
+	call setindex (Memi[index], nclosest)
+	call sortdist (nclosest, dist, Memi[index])
+
+	# Print the ten objects with the largest norms
+
+	jdx = 0
+	do idx = nclosest, 1, -1 {
+	    irow = Memi[index+idx-1]
+	    if (dist[irow] == maxnorm)
+		next
+
+	    if (jdx == 0)
+		call fprintf (fd, bigtitle)
+
+	    jdx = jdx + 1
+	    if (jdx > 10)
+		break
+
+	    call fprintf (fd, normfmt)
+	    call pargd (dist[irow])
+
+	    call rowname (in1, irow, ncol1, Memi[col1], 
+			  Memc[name], namelen)
+
+	    call fprintf (fd, rowformat)
+	    call pargi (1)
+	    call pargi (irow)
+	    call pargstr (Memc[name])
+
+	    call rowname (in2, closest[irow], ncol2, Memi[col2],
+			  Memc[name], namelen)
+
+	    call fprintf (fd, rowformat)
+	    call pargi (2)
+	    call pargi (closest[irow])
+	    call pargstr (Memc[name])
+
+	    call fprintf (fd, "\n")
+
+	}
+
+	call close (fd)
+	call sfree (sp)
+end