1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
include <tbset.h>
define BUFSIZE 1024 # max number of elements copied at one time
# taextract -- copy an entry from one table to another
# This task extracts an entry at a specified row & column (presumably
# an array of values) and writes it as a column of scalar values to
# another table. If the output table exists it will be written to in-place;
# otherwise, it will be created. The same column name is used in both
# tables. The input row number is written to the header of the output
# table using keyword ORIG_ROW.
#
# Phil Hodge, 28-Jul-1994 Task created.
# Phil Hodge, 15-Dec-1995 Add nremain, fix while loop on ncopy.
# Phil Hodge, 29-Jul-1997 Rename delete to delete_flag to avoid confusion
# with the delete subroutine.
# Phil Hodge, 30-Jan-1998 Add optional parameters to define new column.
# Phil Hodge, 8-Apr-1999 Call tbfpri.
procedure taextract()
pointer intable
pointer outtable
int row # row number at which to extract
char column[SZ_COLNAME] # name of column from which to extract
char outcolumn[SZ_COLNAME] # name to use for column in output table
char colunits[SZ_COLUNITS] # units for new column
char colfmt[SZ_COLFMT] # display format for new column
pointer dtype # data type of new column
#--
pointer sp
pointer x # scratch for array of data
pointer itp, otp # pointers to table structs
pointer icp, ocp # pointers to column structs
int datatype # data type of column
char icolname[SZ_COLNAME] # from tbcinf for input table column
char icolunits[SZ_COLUNITS] # from tbcinf, units for column
char icolfmt[SZ_COLFMT] # from tbcinf, display format
int idatatype # from tbcinf, data type of column
int colnum, lenfmt # output from tbcinf and ignored
int nelem # input length of array, output number of rows
int nremain # number of elements that remain to be copied
int ncopy # number of elements to copy at once
int i # loop index
int first, last # first and last elements (or rows)
int slen # length of string to copy
int phu_copied # set by tbfpri and ignored
bool inplace # true if output table already exists
bool newcolumn # true if output column does not already exist
int delete_flag # should we delete output table if error?
pointer tbtopn()
int clgeti(), tbpsta(), tbtacc(), tbcigi()
int tbagtr(), tbagtd(), tbagti(), tbagts(), tbagtb(), tbagtt()
bool isblank()
begin
call smark (sp)
call salloc (intable, SZ_FNAME, TY_CHAR)
call salloc (outtable, SZ_FNAME, TY_CHAR)
call salloc (dtype, SZ_FNAME, TY_CHAR)
call clgstr ("intable", Memc[intable], SZ_FNAME)
call clgstr ("outtable", Memc[outtable], SZ_FNAME)
row = clgeti ("row")
call clgstr ("column", column, SZ_COLNAME)
call clgstr ("outcolumn", outcolumn, SZ_COLNAME)
# The input column name is the default for the output.
if (isblank (outcolumn))
call strcpy (column, outcolumn, SZ_COLNAME)
# Open input and output tables.
itp = tbtopn (Memc[intable], READ_ONLY, NULL)
if (tbtacc (Memc[outtable]) == YES) {
otp = tbtopn (Memc[outtable], READ_WRITE, NULL)
inplace = true
} else {
call tbfpri (Memc[intable], Memc[outtable], phu_copied)
otp = tbtopn (Memc[outtable], NEW_FILE, NULL)
inplace = false
}
if (inplace)
delete_flag = NO
else
delete_flag = YES # delete output table in case of error
if (row < 1 || row > tbpsta (itp, TBL_NROWS)) {
call taex_disaster (itp, otp, NO, "row not found in input table")
}
# Find input column.
call tbcfnd (itp, column, icp, 1)
if (icp == NULL)
call taex_disaster (itp, otp, NO, "column not found in input table")
# Find or create output column.
call tbcfnd (otp, outcolumn, ocp, 1)
if (ocp == NULL) {
# Column not found in output. Create it using the input column
# as a template, except that the output will not be an array.
# The name might also be different.
call tbcinf (icp, colnum, icolname, icolunits, icolfmt,
idatatype, nelem, lenfmt)
# Get optional parameters if creating new column.
call clgstr ("colunits", colunits, SZ_COLUNITS)
call clgstr ("colfmt", colfmt, SZ_COLFMT)
call clgstr ("datatype", Memc[dtype], SZ_FNAME)
# Assign default values if not specified.
if (isblank (colunits))
call strcpy (icolunits, colunits, SZ_COLUNITS)
if (isblank (colfmt))
call strcpy (icolfmt, colfmt, SZ_COLFMT)
if (isblank (Memc[dtype]))
datatype = idatatype
else
call tbbtyp (Memc[dtype], datatype)
call tbcdef (otp, ocp, outcolumn, colunits, colfmt,
datatype, 1, 1) # a column of scalars
newcolumn = true
} else {
newcolumn = false
}
if (!inplace)
call tbtcre (otp)
# Save the row number as a header parameter.
call tbhadi (otp, "orig_row", row)
# Get number of elements to copy.
nelem = tbcigi (icp, TBL_COL_LENDATA)
nremain = nelem # initialize to total number to copy
ncopy = min (nremain, BUFSIZE)
first = 1
last = ncopy
# Copy the data.
datatype = tbcigi (icp, TBL_COL_DATATYPE)
if (datatype == TY_REAL) {
call salloc (x, ncopy, TY_REAL)
while (ncopy > 0) {
if (tbagtr (itp, icp, row, Memr[x], first, ncopy) < ncopy)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbcptr (otp, ocp, Memr[x], first, last)
call taex_incr (nremain, ncopy, first, last, BUFSIZE)
}
} else if (datatype == TY_DOUBLE) {
call salloc (x, ncopy, TY_DOUBLE)
while (ncopy > 0) {
if (tbagtd (itp, icp, row, Memd[x], first, ncopy) < ncopy)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbcptd (otp, ocp, Memd[x], first, last)
call taex_incr (nremain, ncopy, first, last, BUFSIZE)
}
} else if (datatype == TY_INT) {
call salloc (x, ncopy, TY_INT)
while (ncopy > 0) {
if (tbagti (itp, icp, row, Memi[x], first, ncopy) < ncopy)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbcpti (otp, ocp, Memi[x], first, last)
call taex_incr (nremain, ncopy, first, last, BUFSIZE)
}
} else if (datatype == TY_SHORT) {
call salloc (x, ncopy, TY_SHORT)
while (ncopy > 0) {
if (tbagts (itp, icp, row, Mems[x], first, ncopy) < ncopy)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbcpts (otp, ocp, Mems[x], first, last)
call taex_incr (nremain, ncopy, first, last, BUFSIZE)
}
} else if (datatype == TY_BOOL) {
call salloc (x, ncopy, TY_BOOL)
while (ncopy > 0) {
if (tbagtb (itp, icp, row, Memb[x], first, ncopy) < ncopy)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbcptb (otp, ocp, Memb[x], first, last)
call taex_incr (nremain, ncopy, first, last, BUFSIZE)
}
} else if (datatype < 0) { # character string
slen = -datatype + 3 # a little extra space
call salloc (x, slen, TY_CHAR)
do i = 1, nelem {
if (tbagtt (itp, icp, row, Memc[x], slen, i, 1) < 1)
call taex_disaster (itp, otp, delete_flag,
"error reading input")
call tbeptt (otp, ocp, i, Memc[x])
}
} else {
call taex_disaster (itp, otp, delete_flag, "unknown data type")
}
# If we wrote to an existing column in an existing table, and the
# output table has more rows than we just wrote, then we should set
# the remaining rows in this column to INDEF.
if (!newcolumn) {
do i = nelem+1, tbpsta (otp, TBL_NROWS)
call tbrudf (otp, ocp, 1, i)
}
call tbtclo (otp)
call tbtclo (itp)
call sfree (sp)
end
|
