aboutsummaryrefslogtreecommitdiff
path: root/pkg/utilities/nttools/tcalc/tcalc.x
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/utilities/nttools/tcalc/tcalc.x')
-rw-r--r--pkg/utilities/nttools/tcalc/tcalc.x132
1 files changed, 132 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/tcalc/tcalc.x b/pkg/utilities/nttools/tcalc/tcalc.x
new file mode 100644
index 00000000..854df2e3
--- /dev/null
+++ b/pkg/utilities/nttools/tcalc/tcalc.x
@@ -0,0 +1,132 @@
+include <tbset.h>
+define HARMLESS 0.1d0
+define MAXROWS 10000
+
+# T_TCALC -- perform arithmetic operation on columns of a table
+#
+# B.Simon 03-May-91 Original
+# B.Simon 24-Jun-97 Long columns done in pieces
+# B.Simon 16-Jul-97 Error message for string columns
+# B.Simon 30-Mar-00 Allow wild cards in table names
+
+procedure t_tcalc()
+
+#--
+pointer table # input/output table name
+pointer outcol # output column
+pointer equals # expression
+pointer colunits # output col units
+pointer colfmt # output col format
+pointer datatype # output col datatype
+
+include "../tabvar.com"
+
+bool done
+double nil
+pointer sp, tp, list, buffer, colptr, code
+int nrows, nbuf, coltype, exptype
+
+string badtype "Invalid data type for output column"
+
+int tbnget(), tbpsta(), tbcigi()
+pointer tbnopenp(), tbtopn(), vex_compile()
+
+extern tabvar
+
+begin
+ call smark (sp)
+ call salloc (table, SZ_FNAME, TY_CHAR)
+ call salloc (outcol, SZ_FNAME, TY_CHAR)
+ call salloc (equals, SZ_FNAME, TY_CHAR)
+ call salloc (datatype, SZ_FNAME, TY_CHAR)
+ call salloc (colunits, SZ_FNAME, TY_CHAR)
+ call salloc (colfmt, SZ_FNAME, TY_CHAR)
+
+ list = tbnopenp ("table")
+ call clgstr ("outcol", Memc[outcol], SZ_FNAME)
+ call clgstr ("equals", Memc[equals], SZ_FNAME)
+
+ code = vex_compile (Memc[equals])
+
+ while (tbnget (list, Memc[table], SZ_FNAME) != EOF) {
+ tp = tbtopn (Memc[table], READ_WRITE, 0)
+ nrows = tbpsta (tp, TBL_NROWS)
+
+ call tbcfnd (tp, Memc[outcol], colptr, 1)
+ if (colptr != NULL) {
+ coltype = tbcigi (colptr, TBL_COL_DATATYPE)
+
+ } else {
+ call clgstr ("datatype", Memc[datatype], SZ_FNAME)
+ call clgstr ("colunits", Memc[colunits], SZ_FNAME)
+ call clgstr ("colfmt" , Memc[colfmt], SZ_FNAME)
+
+ switch (Memc[datatype]) {
+ case 'r':
+ coltype = TY_REAL
+ case 'd':
+ coltype = TY_DOUBLE
+ case 's':
+ coltype = TY_SHORT
+ case 'i':
+ coltype = TY_INT
+ default:
+ call tbtclo (tp)
+ call error (1, badtype)
+ }
+
+ call tbbftp (Memc[colfmt], Memc[colfmt])
+ call tbcdef (tp, colptr, Memc[outcol], Memc[colunits],
+ Memc[colfmt], coltype, 1, 1)
+ }
+
+ # Initialize common block used by tabvar()
+
+ tabptr = tp
+ firstrow = 1
+ lastrow = MAXROWS
+ nullval = HARMLESS
+
+ done = false
+ nil = HARMLESS
+
+ repeat {
+ if (lastrow >= nrows) {
+ done = true
+ lastrow = nrows
+ }
+
+ nbuf = (lastrow - firstrow) + 1
+ call vex_eval (code, tabvar, nil, exptype)
+
+ switch (coltype) {
+ case TY_SHORT, TY_INT, TY_LONG:
+ call malloc (buffer, nbuf, TY_INT)
+ call vex_copyi (code, INDEFI, Memi[buffer], nbuf)
+ call tbcpti (tp, colptr, Memi[buffer], firstrow, lastrow)
+ call mfree (buffer, TY_INT)
+ case TY_REAL:
+ call malloc (buffer, nbuf, TY_REAL)
+ call vex_copyr (code, INDEFR, Memr[buffer], nbuf)
+ call tbcptr (tp, colptr, Memr[buffer], firstrow, lastrow)
+ call mfree (buffer, TY_REAL)
+ case TY_DOUBLE:
+ call malloc (buffer, nbuf, TY_DOUBLE)
+ call vex_copyd (code, INDEFD, Memd[buffer], nbuf)
+ call tbcptd (tp, colptr, Memd[buffer], firstrow, lastrow)
+ call mfree (buffer, TY_DOUBLE)
+ default:
+ call tbtclo (tp)
+ call error (1, badtype)
+ }
+
+ firstrow = firstrow + MAXROWS
+ lastrow = lastrow + MAXROWS
+ } until (done)
+
+ call tbtclo(tp)
+ }
+
+ call vex_free (code)
+ call sfree (sp)
+end