SEXP cfilter(SEXP sx, SEXP sfilter, SEXP ssides, SEXP scircular)
{
if (TYPEOF(sx) != REALSXP || TYPEOF(sfilter) != REALSXP)
error("invalid input");
R_xlen_t nx = XLENGTH(sx), nf = XLENGTH(sfilter);
int sides = asInteger(ssides), circular = asLogical(scircular);
if(sides == NA_INTEGER || circular == NA_LOGICAL) error("invalid input");
SEXP ans = allocVector(REALSXP, nx);
R_xlen_t i, j, nshift;
double z, tmp, *x = REAL(sx), *filter = REAL(sfilter), *out = REAL(ans);
if(sides == 2) nshift = nf /2;
else nshift = 0;
if(!circular) {
for(i = 0; i < nx; i++) {
z = 0;
if(i + nshift - (nf - 1) < 0 || i + nshift >= nx) {
out[i] = NA_REAL;
continue;
}
for(j = max(0, nshift + i - nx); j < min(nf, i + nshift + 1) ; j++) {
tmp = x[i + nshift - j];
if(my_isok(tmp)) z += filter[j] * tmp;
else {
out[i] = NA_REAL;
goto bad;
}
}
out[i] = z;
bad:
continue;
}
} else { /* circular */
for(i = 0; i < nx; i++)
{
z = 0;
for(j = 0; j < nf; j++) {
R_xlen_t ii = i + nshift - j;
if(ii < 0) ii += nx;
if(ii >= nx) ii -= nx;
tmp = x[ii];
if(my_isok(tmp)) z += filter[j] * tmp;
else {
out[i] = NA_REAL;
goto bad2;
}
}
out[i] = z;
bad2:
continue;
}
}
return ans;
}
/* recursive filtering */
SEXP rfilter(SEXP x, SEXP filter, SEXP out)
{
if (TYPEOF(x) != REALSXP || TYPEOF(filter) != REALSXP
|| TYPEOF(out) != REALSXP) error("invalid input");
R_xlen_t nx = XLENGTH(x), nf = XLENGTH(filter);
double sum, tmp, *rx = REAL(x), *rf = REAL(filter);
// SHOULD NOT assume that we can modify the contents of
// an incoming SEXP !!
SEXP out_copy = duplicate(out);
double *r = REAL(out_copy);
for(R_xlen_t i = 0; i < nx; i++) {
sum = rx[i];
for (R_xlen_t j = 0; j < nf; j++) {
tmp = r[nf + i - j - 1];
if(my_isok(tmp)) {
sum += tmp * rf[j];
} else {
r[nf + i] = NA_REAL;
goto bad3;
}
}
r[nf + i] = sum;
bad3:
continue;
}
return out_copy;
}
/* recursive filtering */
SEXP rfilter(SEXP x, SEXP filter, SEXP out)
{
if (TYPEOF(x) != REALSXP || TYPEOF(filter) != REALSXP
|| TYPEOF(out) != REALSXP) error("invalid input");
R_xlen_t nx = XLENGTH(x), nf = XLENGTH(filter);
double sum, tmp, *r = REAL(out), *rx = REAL(x), *rf = REAL(filter);
for(R_xlen_t i = 0; i < nx; i++) {
sum = rx[i];
for (R_xlen_t j = 0; j < nf; j++) {
tmp = r[nf + i - j - 1];
if(my_isok(tmp)) sum += tmp * rf[j];
else { r[nf + i] = NA_REAL; goto bad3; }
}
r[nf + i] = sum;
bad3:
continue;
}
return out;
}
void
sriv_system(double *U, double *Y, double *X, int *len, int *warmup,
int *order, int *delay, double *xz, double *xy, double *xx)
{
// z: regressors { Qf[k-1] ... Qf[k-n], Uf[k] ... Uf[k-m] }
// x: instrumental variable { Xf[k-1] ... Xf[k-n], Uf[k] ... Uf[k-m] }
// form the system E(xz') %*% theta == E(xy)
// i.e. (xz) compute mean of outer products of x_t and z_t for all times t
// also compute information matrix E(xx')
int t;
int i, j;
int n = order[0];
int m = order[1];
int p = n + m + 1;
int d = *delay;
double *xt, *zt;
xt = (double *) R_alloc(p, sizeof(double));
zt = (double *) R_alloc(p, sizeof(double));
// initialise outputs
for (i = 0; i < p*p; i++) xz[i] = 0;
for (i = 0; i < p; i++) xy[i] = 0;
for (i = 0; i < p*p; i++) xx[i] = 0;
for (t = *warmup; t < *len; t++) {
// form the vectors x_t and z_t
if (!my_isok(Y[t]))
goto badsriv;
for (j = 1; j <= n; j++) {
i = j - 1;
if (!my_isok(X[t-j]) || !my_isok(Y[t-j]))
goto badsriv;
xt[i] = X[t - j];
zt[i] = Y[t - j];
}
for (j = 0; j <= m; j++) {
i = n + j;
if (!my_isok(U[t-(j+d)]))
goto badsriv;
xt[i] = zt[i] = U[t - (j + d)];
}
// add outer product to coefficient matrix xz
for (i = 0; i < p; i++) {
for (j = 0; j < p; j++) {
xz[i + p*j] += xt[i] * zt[j];
}
}
// add scalar product of x_t with Y_t to response vector xy
for (i = 0; i < p; i++) {
xy[i] += xt[i] * Y[t];
}
// add outer product to information matrix xx
for (i = 0; i < p; i++) {
for (j = 0; j < p; j++) {
xx[i + p*j] += xt[i] * xt[j];
}
}
badsriv:
continue;
}
}
int main(int argc, char **argv) {
int j, opt, error, i_width;
long i, elements, size, columns, entry_width;
char* value_end;
unsigned char x[16]; /* Up to 128 bit */
char buf[100];
FILE* f;
/* Default values */
program = argv[0];
package = 0; /* auto-detect */
width = 4;
bigendian = 1;
verbose = 0;
size = -1; /* file size */
/* Process the command-line */
while ((opt = getopt(argc, argv, "w:p:s:blvh")) != -1) {
switch (opt) {
case 'w':
width = strtol(optarg, &value_end, 0);
if (*value_end || /* bad integer */
((width-1)&width) != 0 || /* not a power of 2 */
width == 0 ||
width > 16) {
fprintf(stderr, "%s: invalid value width -- '%s'\n", program, optarg);
error = 1;
}
break;
case 'p':
package = optarg;
break;
case 's':
size = strtol(optarg, &value_end, 0);
if (*value_end) {
fprintf(stderr, "%s: invalid value size -- '%s'\n", program, optarg);
error = 1;
}
break;
case 'b':
bigendian = 1;
break;
case 'l':
bigendian = 0;
break;
case 'v':
verbose = 1;
break;
case 'h':
help();
return 1;
case ':':
case '?':
error = 1;
break;
default:
fprintf(stderr, "%s: bad getopt result\n", program);
return 1;
}
}
if (optind + 1 != argc) {
fprintf(stderr, "%s: expecting one non-optional argument: <filename>\n", program);
return 1;
}
filename = argv[optind];
/* Confirm the filename exists */
if ((f = fopen(filename, "r")) == 0) {
fprintf(stderr, "%s: %s while opening '%s'\n", program, strerror(errno), filename);
return 1;
}
/* Deduce if it's aligned */
fseek(f, 0, SEEK_END);
elements = ftell(f);
rewind(f);
if (size == -1) {
size = elements;
}
if (size < elements) {
fprintf(stderr, "%s: length of initialization file '%s' (%ld) exceeds specified size (%ld)\n", program, filename, elements, size);
return 1;
}
if (elements % width != 0) {
fprintf(stderr, "%s: initialization file '%s' is not a multiple of %ld bytes\n", program, filename, width);
return 1;
}
elements /= width;
if (size % width != 0) {
fprintf(stderr, "%s: specified size '%ld' is not a multiple of %ld bytes\n", program, size, width);
return 1;
}
size /= width;
/* Find a suitable package name */
if (package == 0) {
if (strlen(filename) >= sizeof(buf)-5) {
fprintf(stderr, "%s: filename too long to deduce package name -- '%s'\n", program, filename);
return 1;
}
/* Find the first alpha character */
while (*filename && !my_isalpha(*filename)) ++filename;
/* Start copying the filename to the package */
for (i = 0; filename[i]; ++i) {
if (my_isok(filename[i]))
buf[i] = filename[i];
else
buf[i] = '_';
}
buf[i] = 0;
if (i == 0) {
fprintf(stderr, "%s: no appropriate characters in filename to use for package name -- '%s'\n", program, filename);
return 1;
}
package = &buf[0];
} else {
/* Check for valid VHDL identifier */
if (!my_isalpha(package[0])) {
fprintf(stderr, "%s: invalid package name -- '%s'\n", program, package);
return 1;
}
for (i = 1; package[i]; ++i) {
if (!my_isok(package[i])) {
fprintf(stderr, "%s: invalid package name -- '%s'\n", program, package);
return 1;
}
}
}
/* Find how many digits it takes to fit 'size' */
i_width = 1;
for (i = 10; i <= size; i *= 10)
++i_width;
/* How wide is an entry of the table? */
entry_width = i_width + 6 + width*2 + 3;
columns = 76 / entry_width;
printf("-- AUTOGENERATED FILE (from genramvhd.c run on %s) --\n", argv[1]);
printf("library IEEE;\n");
printf("use IEEE.std_logic_1164.all;\n");
printf("use IEEE.numeric_std.all;\n");
printf("\n");
printf("library work;\n");
printf("use work.memory_loader_pkg.all;\n");
printf("\n");
printf("package %s_pkg is\n", package);
printf(" constant %s_init : t_meminit_array(%ld downto 0, %ld downto 0) := (\n", package, size-1, (width*8)-1);
for (i = 0; i < size; ++i) {
if (i % columns == 0) printf(" ");
if (i < elements) {
if (fread(x, 1, width, f) != width) {
perror("fread");
return 1;
}
} else {
memset(x, 0, sizeof(x));
}
printf("%*ld => x\"", i_width, i);
if (bigendian) {
for (j = 0; j < width; ++j)
printf("%02x", x[j]);
} else {
for (j = width-1; j >= 0; --j)
printf("%02x", x[j]);
}
printf("\"");
if ((i+1) == size) printf(");\n");
else if ((i+1) % columns == 0) printf(",\n");
else printf(", ");
}
fclose(f);
printf("end %s_pkg;\n", package);
return 0;
}