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
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
|
.help prexit
Parser Exit Handling.
After the compilation has finished without errors, the parser runs the
pr_exit() routine in order to make sure that there are no inconsistencies in
the parser symbol table, and to perform all steps that can be done only
with the full symbol table. This procedure performs the following actions:
- Builds the list of sequential tables for each type of variable, parameter,
and equation in the symbol table. These tables are used later to access
each type sequentially.
- Sets the minimum and maximum values for observational and catalog variables.
- Checks that there are no duplications in either the observational or catalog
input columns.
- Checks that all the derivatives for transformation equations are defined.
If an error or inconsistency is detected an error message is issued.
Entry point:
pr_exit() Exit procedure
.endhelp
include <mach.h>
include "../lib/parser.h"
include "../lib/prdefs.h"
# PR_EXIT - Parser exit procedure.
procedure pr_exit ()
bool derflag, dltflag
int i1, i2, incol, errcol, wtscol, mincol, maxcol, par, type
int npar, sym
pointer sp, aux, symtab, der
#real delta
#bool clgetb()
int mct_nrows(), mct_geti(), pr_geti(), pr_gsymi(), pr_gpari()
pointer sthead(), stnext(), pr_xgetname(), pr_offset, pr_getp(), pr_gderp()
real pr_gsymr()
begin
# Debug ?
#if (clgetb ("debug.parcode"))
#call eprintf ("pr_exit.in\n")
# Allocate working space
call smark (sp)
call salloc (aux, SZ_LINE, TY_CHAR)
# Initialize minimum and maximum column values.
# Check for empty sections to initialize with the
# right value.
if (pr_geti (NOBSVARS) > 0) {
call pr_puti (MINOBSCOL, MAX_INT)
call pr_puti (MAXOBSCOL, -MAX_INT)
} else {
call pr_puti (MINOBSCOL, INDEFI)
call pr_puti (MAXOBSCOL, INDEFI)
}
if (pr_geti (NCATVARS) > 0) {
call pr_puti (MINCATCOL, MAX_INT)
call pr_puti (MAXCATCOL, -MAX_INT)
} else {
call pr_puti (MINCATCOL, INDEFI)
call pr_puti (MAXCATCOL, INDEFI)
}
# Build sequential tables from the parser symbol table,
# and compute minimum and maximum column numbers.
symtab = sthead (pr_getp (SYMTABLE))
while (symtab != NULL) {
# Convert SYMTAB pointer into symbol offset.
sym = pr_offset (symtab)
# Get symbol type.
type = pr_gsymi (sym, PSYMTYPE)
# Check symbol type consistency, and enter each symbol in a
# sequential table acording with its type
switch (type) {
case PTY_OBSVAR:
call mct_sputi (pr_getp (OBSTABLE), sym)
incol = pr_gsymi (sym, PINPCOL)
mincol = incol
maxcol = incol
errcol = pr_gsymi (sym, PINPERRCOL)
if (! IS_INDEFI(errcol)) {
mincol = min (mincol, errcol)
maxcol = max (maxcol, errcol)
}
wtscol = pr_gsymi (sym, PINPWTSCOL)
if (! IS_INDEFI(wtscol)) {
mincol = min (mincol, wtscol)
maxcol = max (maxcol, wtscol)
}
if (mincol < pr_geti (MINOBSCOL))
call pr_puti (MINOBSCOL, mincol)
if (maxcol > pr_geti (MAXOBSCOL))
call pr_puti (MAXOBSCOL, maxcol)
case PTY_CATVAR:
call mct_sputi (pr_getp (CATTABLE), sym)
incol = pr_gsymi (sym, PINPCOL)
mincol = incol
maxcol = incol
errcol = pr_gsymi (sym, PINPERRCOL)
if (! IS_INDEFI(errcol)) {
mincol = min (mincol, errcol)
maxcol = max (maxcol, errcol)
}
wtscol = pr_gsymi (sym, PINPWTSCOL)
if (! IS_INDEFI(wtscol)) {
mincol = min (mincol, wtscol)
maxcol = max (maxcol, wtscol)
}
if (mincol < pr_geti (MINCATCOL))
call pr_puti (MINCATCOL, mincol)
if (maxcol > pr_geti (MAXCATCOL))
call pr_puti (MAXCATCOL, maxcol)
case PTY_FITPAR, PTY_CONST:
call mct_sputi (pr_getp (PARTABLE), sym)
case PTY_SETEQ:
call mct_sputi (pr_getp (SETTABLE), sym)
case PTY_EXTEQ:
call mct_sputi (pr_getp (EXTTABLE), sym)
case PTY_TRNEQ:
call mct_sputi (pr_getp (TRNTABLE), sym)
default:
call sprintf (Memc[aux], SZ_LINE,
"pr_exit: unknown symbol type [%d] for [%d] [%s]")
call pargi (type)
call pargi (sym)
call pargstr (Memc[pr_xgetname (sym)])
call error (0, Memc[aux])
}
# Advance to next SYMTAB symbol.
symtab = stnext (pr_getp (SYMTABLE), symtab)
}
# Check for input, error, and weight column duplications.
call pr_excol (pr_getp (CATTABLE))
call pr_excol (pr_getp (OBSTABLE))
# Check transfomation equation deltas and derivatives.
do i1 = 1, mct_nrows (pr_getp (TRNTABLE)) {
# Get equation symbol.
sym = mct_geti (pr_getp (TRNTABLE), i1, 1)
# Get number of parameters.
npar = pr_gsymi (sym, PTEQNPAR)
# Check if there are deltas and derivatives defined for the
# current equation. The code has been modified so that there
# will always be a defined PFITDELTA.
derflag = false
dltflag = false
do i2 = 1, npar {
der = pr_gderp (sym, i2, PTEQRPNDER)
if (der != NULL)
derflag = true
par = pr_gpari (sym, i2, PTEQPAR)
if (IS_INDEFI (par))
next
if (IS_INDEFR (pr_gsymr (par, PFITDELTA))) {
call pr_psymr (par, PFITDELTA, DEF_PFITDELTA)
} else if (der != NULL) {
call sprintf (Memc[aux], SZ_LINE,
"Parameter delta and derivative defined for [%s] in equation [%s]")
call pargstr (Memc[pr_xgetname (par)])
call pargstr (Memc[pr_xgetname (sym)])
call pr_error (Memc[aux], PERR_WARNING)
}
dltflag = true
}
# Continue with next equation if no deltas or derivatives are
# defined. This error check should now never be tripped since the
# code has been modified so that dltflag is always true.
if (! (derflag || dltflag) && (npar > 0)) {
call sprintf (Memc[aux], SZ_LINE,
"No parameter deltas or derivatives defined for equation [%s]")
call pargstr (Memc[pr_xgetname (sym)])
call pr_error (Memc[aux], PERR_POSTPROC)
next
}
# Loop over all fitting parameters of the equation.
# Comment out this code since there are now reasonable defaults
# and eventually delete.
#do i2 = 1, npar {
# Get parameter offset, parameter delta, and derivative
# code pointer. Skip parameters that are not used in
# the equation.
#par = pr_gpari (sym, i2, PTEQPAR)
#if (IS_INDEFI (par))
#next
#delta = pr_gsymr (par, PFITDELTA)
#der = pr_gderp (sym, i2, PTEQRPNDER)
# Check for exclusion between deltas and derivatives,
# missing derivative equations, and missing deltas.
#if (!IS_INDEFR (delta) && der != NULL) {
#call sprintf (Memc[aux], SZ_LINE,
#"Parameter delta and derivative defined for [%s] in equation [%s]")
#call pargstr (Memc[pr_xgetname (par)])
#call pargstr (Memc[pr_xgetname (sym)])
#call pr_error (Memc[aux], PERR_POSTPROC)
#} else if (der == NULL && derflag) {
#call sprintf (Memc[aux], SZ_LINE,
#"Missing derivative for parameter [%s] in equation [%s]")
#call pargstr (Memc[pr_xgetname (par)])
#call pargstr (Memc[pr_xgetname (sym)])
#call pr_error (Memc[aux], PERR_POSTPROC)
#} else if (IS_INDEFR (delta) && dltflag) {
#call sprintf (Memc[aux], SZ_LINE,
#"Missing delta for parameter [%s] in equation [%s]")
#call pargstr (Memc[pr_xgetname (par)])
#call pargstr (Memc[pr_xgetname (sym)])
#call pr_error (Memc[aux], PERR_POSTPROC)
#}
#}
}
# Debug ?
#if (clgetb ("debug.parcode"))
#call eprintf ("pr_exit.out\n")
call sfree (sp)
end
# PR_EXCOL -- Check for input variable column duplications.
procedure pr_excol (table)
pointer table # table pointer
int i1, i2, sym1, sym2, col1, col2, errcol1, errcol2, wtscol1, wtscol2
pointer sp, aux
int mct_nrows(), mct_geti(), pr_gsymi()
pointer pr_xgetname()
begin
call smark (sp)
call salloc (aux, SZ_LINE, TY_CHAR)
do i1 = 1, mct_nrows (table) - 1 {
# Get first symbol columns.
sym1 = mct_geti (table, i1, 1)
col1 = pr_gsymi (sym1, PINPCOL)
errcol1 = pr_gsymi (sym1, PINPERRCOL)
wtscol1 = pr_gsymi (sym1, PINPWTSCOL)
# Skip spare variable.
if (pr_gsymi (sym1, PINPSPARE) == YES)
next
# Check the first symbol against itself.
if ((!IS_INDEFI (errcol1) && (col1 == errcol1)) ||
(!IS_INDEFI (wtscol1) && (col1 == wtscol1)) ||
(!IS_INDEFI (errcol1) && !IS_INDEFI (wtscol1) &&
(errcol1 == wtscol1))) {
call sprintf (Memc[aux], SZ_LINE,
"Duplicate column for input variable [%s]")
call pargstr (Memc[pr_xgetname (sym1)])
call pr_error (Memc[aux], PERR_WARNING)
}
# Compare the first symbol against all others in the table.
do i2 = i1 + 1, mct_nrows (table) {
# Get second symbol columns.
sym2 = mct_geti (table, i2, 1)
col2 = pr_gsymi (sym2, PINPCOL)
errcol2 = pr_gsymi (sym2, PINPERRCOL)
wtscol2 = pr_gsymi (sym2, PINPWTSCOL)
# Skip spare variable.
if (pr_gsymi (sym2, PINPSPARE) == YES)
next
# Check first symbol against the second symbol.
if ((col1 == col2) ||
#(!IS_INDEFI (errcol2) && (col1 == errcol2)) ||
#(!IS_INDEFI (wtscol2) && (col1 == wtscol2)) ||
#(!IS_INDEFI (errcol1) && (col2 == errcol1)) ||
#(!IS_INDEFI (wtscol1) && (col2 == wtscol1)) ||
(!IS_INDEFI (errcol1) && !IS_INDEFI (errcol2) &&
(errcol1 == errcol2)) ||
(!IS_INDEFI (wtscol1) && !IS_INDEFI (wtscol2) &&
(wtscol1 == wtscol2)) ||
(!IS_INDEFI (errcol1) && !IS_INDEFI (wtscol2) &&
(errcol1 == wtscol2)) ||
(!IS_INDEFI (errcol2) && !IS_INDEFI (wtscol1) &&
(errcol2 == wtscol1))) {
call sprintf (Memc[aux], SZ_LINE,
"Duplicate column for input variables [%s] and [%s]")
call pargstr (Memc[pr_xgetname (sym1)])
call pargstr (Memc[pr_xgetname (sym2)])
call pr_error (Memc[aux], PERR_WARNING)
}
}
}
call sfree (sp)
end
|
