nialptr arithconvert(nialptr x, int *newk) { int k, ki, changed; nialint i, t = tally(x); nialptr z, x0, xi; if (t == 0) { /* x is empty */ *newk = kind(x); return (x); } /* set k based on kind of first item */ x0 = fetch_array(x, 0); /* first item */ k = kind(x0); /* loop to find maximum kind in x */ for (i = 1; i < t; i++) { xi = fetch_array(x, i); ki = kind(xi); if (ki > k) k = ki; } /* convert to highest kind */ changed = true; if (homotype(k) && k != chartype) { switch (k) { case inttype: z = to_int(x); break; case realtype: z = to_real(x); break; default: z = x; changed = false; break; } } else { z = x; changed = false; } if (changed) /* argument has been converted */ freeup(x); *newk = k; return (z); }
void iinnerproduct() { nialptr z, a, b, x; int va, vb, vx, replicatea, replicateb; nialint m, n, bn, p, i, j, k, sh[2]; double sum, *ap, *bp, *xp; z = apop(); if (tally(z) != 2) { buildfault("arg to innerproduct not a pair"); freeup(z); return; } splitfb(z, &a, &b); va = valence(a); vb = valence(b); if (va > 2 || vb > 2) { buildfault("incorrect valence in innerproduct"); freeup(a); freeup(b); freeup(z); return; } /* ensure b is realtype */ switch (kind(b)) { case booltype: b = bool_to_real(b); break; case inttype: b = int_to_real(b); break; case realtype: break; case chartype: case phrasetype: case faulttype: { buildfault("second arg not numeric type in innerproduct"); freeup(a); freeup(b); freeup(z); return; } case atype: { nialint i = 0; if (!simple(b)) { buildfault("arg not simple in innerproduct"); freeup(a); freeup(b); freeup(z); return; } while (i < tally(b)) { if (!numeric(kind(fetch_array(b, i)))) { buildfault("second arg not numeric type in innerproduct"); freeup(a); freeup(b); freeup(z); return; } i++; } b = to_real(b); /* safe because freeup(z) will clear old b */ } } /* ensure a is realtype */ switch (kind(a)) { case booltype: a = bool_to_real(a); break; case inttype: a = int_to_real(a); break; case realtype: break; case chartype: case phrasetype: case faulttype: { buildfault("first arg not numeric type in innerproduct"); freeup(a); freeup(b); freeup(z); return; } case atype: { nialint i = 0; if (!simple(a)) { buildfault("first arg not simple in innerproduct"); freeup(a); freeup(b); freeup(z); return; } while (i < tally(a)) { if (!numeric(kind(fetch_array(a, i)))) { buildfault("first arg not numeric type in innerproduct"); freeup(a); freeup(b); freeup(z); return; } i++; } a = to_real(a); /* safe becasue freeup of z clears old a */ } } if (va == 0) { m = 1; n = 1; } else if (va == 1) { m = 1; n = pickshape(a, 0); } else { m = pickshape(a, 0); n = pickshape(a, 1); } if (vb == 0) { bn = 1; p = 1; } else if (vb == 1) { bn = pickshape(b, 0); p = 1; } else { bn = pickshape(b, 0); p = pickshape(b, 1); } replicatea = (va == 0); replicateb = (vb == 0); if (!(replicatea || replicateb) && n != bn) { buildfault("conform error in innerproduct"); freeup(a); freeup(b); freeup(z); return; } /* get valence for the result */ vx = (va <= 1 ? (vb <= 1 ? 0 : 1) : (vb <= 1 ? 1 : 2)); if (vx == 2) { sh[0] = m; sh[1] = p; } else if (vx == 1) sh[0] = (va == 2 ? m : p); /* if vx==0 then sh is not used */ /* allocate space for the result matrix */ x = new_create_array(realtype, vx, 0, sh); ap = pfirstreal(a); /* safe: no allocations */ bp = pfirstreal(b); /* safe: no allocations */ xp = pfirstreal(x); /* safe: no allocations */ /* type of loop chosen on the kind of ip being done */ if (vx == 2) { /* matrix - matrix */ for (i = 0; i < m; i++) { for (j = 0; j < p; j++) { sum = 0.; for (k = 0; k < n; k++) sum += *(ap + (n * i + k)) * *(bp + (p * k + j)); *(xp + (p * i + j)) = sum; } checksignal(NC_CS_NORMAL); } } else if (va == 2) { /* matrix - vector */ for (i = 0; i < m; i++) { sum = 0.; if (replicateb) for (k = 0; k < n; k++) sum += *(ap + (n * i + k)) * *bp; else for (k = 0; k < n; k++) sum += *(ap + (n * i + k)) * *(bp + k); *(xp + i) = sum; } } else if (vb == 2) { /* vector - matrix */ for (j = 0; j < p; j++) { sum = 0.; if (replicatea) for (k = 0; k < bn; k++) sum += *ap * *(bp + (p * k + j)); else for (k = 0; k < bn; k++) sum += *(ap + k) * *(bp + (p * k + j)); *(xp + j) = sum; } } else { /* vector - vector */ sum = 0.; if (replicatea) for (k = 0; k < bn; k++) sum += *ap * *(bp + k); else if (replicateb) for (k = 0; k < n; k++) sum += *(ap + k) * *bp; else for (k = 0; k < n; k++) sum += *(ap + k) * *(bp + k); *xp = sum; } apush(x); freeup(a); freeup(b); freeup(z); }
void isolve() { nialptr z, a, aa = Null, b, x = Null; int va, vb, afreed, bfreed; nialint n, nrhs; char errmsg[80]; z = apop(); if (tally(z) != 2) { buildfault("arg to solve not a pair"); freeup(z); return; } splitfb(z, &a, &b); va = valence(a); vb = valence(b); if (va != 2 || vb > 2) { buildfault("incorrect valence in solve"); freeup(a); freeup(b); freeup(z); return; } n = pickshape(a, 0); if (n != pickshape(a, 1) || n != pickshape(b, 0)) { buildfault("shapes do not conform in solve"); freeup(a); freeup(b); freeup(z); return; } bfreed = false; switch (kind(b)) { case booltype: x = bool_to_real(b); bfreed = true; break; case inttype: x = int_to_real(b); bfreed = true; break; case realtype: { /* make a copy of b in x */ x = new_create_array(realtype, vb, 0, shpptr(b, vb)); copy(x, 0, b, 0, tally(b)); break; } case chartype: case phrasetype: case faulttype: { buildfault("second arg not numeric type in solve"); freeup(a); freeup(b); freeup(z); return; } case atype: { nialint i = 0; if (!simple(b)) { buildfault("second arg not simple in solve"); freeup(a); freeup(b); freeup(z); return; } while (i < tally(b)) { if (!numeric(kind(fetch_array(b, i)))) { buildfault("second arg not numeric type in solve"); freeup(a); freeup(b); freeup(z); return; } i++; } x = to_real(b); /* makes a copy of b as reals */ } } afreed = false; switch (kind(a)) { case booltype: aa = bool_to_real(a); /* makes a copy of a as reals */ afreed = true; break; case inttype: aa = int_to_real(a); /* makes a copy of a as reals */ afreed = true; break; case realtype: { /* makes a copy of a */ aa = new_create_array(realtype, va, 0, shpptr(a, va)); copy(aa, 0, a, 0, tally(a)); break; } case chartype: case phrasetype: case faulttype: { buildfault("first arg not numeric type in solve"); freeup(a); if (!bfreed) freeup(b); freeup(z); freeup(x); return; } case atype: { nialint i = 0; if (!simple(a)) { buildfault("first arg not simple in solve"); freeup(a); if (!bfreed) freeup(b); freeup(z); freeup(x); return; } while (i < tally(a)) { if (!numeric(kind(fetch_array(a, i)))) { buildfault("first arg not numeric type in solve"); freeup(a); if (!bfreed) freeup(b); freeup(z); freeup(x); return; } i++; } aa = to_real(a); /* makes a copy of a as reals */ } } nrhs = (vb == 1 ? 1 : pickshape(x, 1)); /* use the Gaussian elimination algorithm to solve the equation(s) */ if (Gausselim(pfirstreal(aa), pfirstreal(x), n, nrhs, errmsg)) { apush(x); } else { buildfault(errmsg); freeup(x); } freeup(aa); /* the modified copy of a has to be freed */ if (!bfreed) freeup(b); if (!afreed) freeup(a); freeup(z); }
void iinverse() { nialptr a, aa = Null, x; int va, afreed; nialint n, i, j; double *ptr; char errmsg[80]; a = apop(); va = valence(a); if (va != 2) { buildfault("incorrect valence in inverse"); freeup(a); return; } n = pickshape(a, 0); if (n != pickshape(a, 1)) { buildfault("matrix is not square in inverse"); freeup(a); return; } afreed = false; switch (kind(a)) { case booltype: aa = bool_to_real(a); /* makes a real copy of a */ afreed = true; break; case inttype: aa = int_to_real(a); /* makes a real copy of a */ afreed = true; break; case realtype: { /* make a real copy of a */ aa = new_create_array(realtype, va, 0, shpptr(a, va)); copy(aa, 0, a, 0, tally(a)); break; } case chartype: case phrasetype: case faulttype: { buildfault("arg not numeric type in inverse"); freeup(a); return; } case atype: { nialint i = 0; if (!simple(a)) { buildfault("arg not simple in inverse"); freeup(a); return; } while (i < tally(a)) { if (!numeric(kind(fetch_array(a, i)))) { buildfault("arg not numeric type in inverse"); freeup(a); return; } i++; } aa = to_real(a); /* makes a real copy of a */ } } /* initialize x to a real identity matrix */ x = new_create_array(realtype, va, 0, shpptr(aa, va)); ptr = pfirstreal(x); for (i = 0; i < n; i++) for (j = 0; j < n; j++) *ptr++ = (i == j ? 1.0 : 0.0); if (Gausselim(pfirstreal(aa), pfirstreal(x), n, n, errmsg)) { apush(x); } else { buildfault(errmsg); freeup(x); } freeup(aa); /* the modified copy of a has to be freed */ /* if a direct copies of a was made, then it needs to be freed up. the * conversion routine does its own freeup. */ if (!afreed) freeup(a); }
template <> _BASE_API void call_param::push<float>(size_t i, float value) { push_real(i, to_real(value)); }