void matrix_daxpy(size_t m, size_t n, double alpha, const double *x, size_t ldx, double *y, size_t ldy) { if (ldx == m && ldy == m) { blas_daxpy(m * n, alpha, x, 1, y, 1); } else { size_t j; for (j = 0; j < n; j++) { blas_daxpy(m, alpha, x + j * ldx, 1, y + j * ldy, 1); } } }
void update_dx(struct mlogit *m) { if (!mlogit_dim(m)) return; const size_t dim = mlogit_dim(m); double *dx = m->work->dx; // compute dx const size_t *ind; size_t iz, nz; uintset_get_vals(&m->ind, &ind, &nz); for (iz = 0; iz < nz; iz++) { size_t i = ind[iz]; const double *x0_i = m->x0 + iz * dim; const double *x_i = m->x + i * dim; double *dx_i = dx + iz * dim; /* copy x */ memcpy(dx_i, x_i, dim * sizeof(double)); /* dx[i] := x[i] - x0[i] */ blas_daxpy(dim, -1.0, x0_i, 1, dx_i, 1); } }
void spblas_dcscar(char trans, int n, int m, const double *A, const int *colptr, const int *rowind, int nnz, const double *x, int incx, double *h, int ldh, double *v, int ldv, int ite, double *rnorm, double tol, double *work, int *info) { int i, j, l; double beta, r; *rnorm = blas_dnrm2(nnz, A, 1); beta = blas_dnrm2(n, x, incx); for (i=0; i<m; i++) { blas_dfill(m, 0.0, &h[i*ldh], 1); blas_dfill(n, 0.0, &v[i*ldv], 1); } blas_daxpy(n, 1.0/beta, x, incx, &v[0], 1); for (j=0; j<m; j++) { spblas_dcscmv(trans, n, n, 1.0, A, colptr, rowind, nnz, &v[j*ldv], 1, 0.0, work, 1); for (i=0; i<=j; i++) { for (l=0; l<ite; l++) { r = blas_ddot(n, work, 1, &v[i*ldv], 1); h[i+j*ldh] += r; blas_daxpy(n, -r, &v[i*ldv], 1, work, 1); } } if (j != m-1) { h[j+1+j*ldh] = blas_dnrm2(n, work, 1); if (h[j+1+j*ldh] < *rnorm * tol) { *rnorm = beta; *info = j+1; return; } blas_daxpy(n, 1.0/h[j+1+j*ldh], work, 1, &v[(j+1)*ldv], 1); } } *rnorm = beta; *info = j; }
static void update(struct bfgs *opt, double f, const double *grad) { size_t i, n = opt->dim; double *H = opt->inv_hess; double *s = opt->step; double *y = opt->dg; /* update step */ memcpy(s, opt->search, n * sizeof(s[0])); blas_dscal(n, linesearch_step(&opt->ls), s, 1); /* update df */ opt->df = f - opt->f0; /* update dg */ memcpy(y, grad, n * sizeof(y[0])); blas_daxpy(n, -1.0, opt->grad0, 1, y, 1); double s_y = blas_ddot(n, s, 1, y, 1); /* NOTE: could use damped update instead (Nocedal and Wright, p. 537) */ assert(s_y > 0); /* initialize inv hessian on first step (Nocedal and Wright, p. 143) */ if (opt->first_step) { /* */ double y_y = blas_ddot(n, y, 1, y, 1); assert(y_y > 0); double scale = s_y / y_y; memset(H, 0, n * n * sizeof(H[0])); for (i = 0; i < n; i++) { H[i * n + i] = scale; } opt->first_step = 0; } /* compute H_y */ double *H_y = opt->H_dg; blas_gemv(n, n, BLAS_NOTRANS, 1.0, H, n, y, 1, 0.0, H_y, 1); double y_H_y = blas_ddot(n, H_y, 1, y, 1); double scale1 = (1.0 + (y_H_y / s_y)) / s_y; double rho = 1.0 / s_y; /* update inverse hessian */ blas_dger(n, n, scale1, s, 1, s, 1, H, n); blas_dger(n, n, -rho, H_y, 1, s, 1, H, n); blas_dger(n, n, -rho, s, 1, H_y, 1, H, n); /* update search direction */ blas_dgemv(BLAS_NOTRANS, n, n, -1.0, opt->inv_hess, n, grad, 1, 0.0, opt->search, 1); assert(isfinite(blas_dnrm2(n, opt->search, 1))); /* update initial position, value, and grad */ memcpy(opt->x0, opt->x, n * sizeof(opt->x0[0])); opt->f0 = f; memcpy(opt->grad0, grad, n * sizeof(opt->grad0[0])); }
enum bfgs_task bfgs_advance(struct bfgs *opt, double f, const double *grad) { size_t n = opt->dim; assert(isfinite(f)); assert(isfinite(blas_dnrm2(n, grad, 1))); assert(opt->task == BFGS_STEP); double g = blas_ddot(n, grad, 1, opt->search, 1); enum linesearch_task lstask = linesearch_advance(&opt->ls, f, g); int ok = linesearch_sdec(&opt->ls) && linesearch_curv(&opt->ls); switch (lstask) { case LINESEARCH_CONV: break; case LINESEARCH_STEP: opt->ls_it++; if (opt->ls_it < opt->ctrl.ls_maxit) { memcpy(opt->x, opt->x0, n * sizeof(opt->x[0])); blas_daxpy(n, linesearch_step(&opt->ls), opt->search, 1, opt->x, 1); assert(opt->task == BFGS_STEP); goto out; } else if (ok) { break; } else { opt->task = BFGS_ERR_LNSRCH; /* maximum number of iterations */ } default: if (ok) { break; } else { opt->task = BFGS_ERR_LNSRCH; goto out; } } update(opt, f, grad); /* test for convergence */ if (converged(opt)) { opt->task = BFGS_CONV; } else { assert(opt->task == BFGS_STEP); double step0 = 1.0; double f0 = f; double g0 = blas_ddot(n, grad, 1, opt->search, 1); assert(g0 < 0); linesearch(opt, step0, f0, g0); } out: return opt->task; }
void update_cov(struct mlogit *m) { if (mlogit_moments(m) < 2 || !mlogit_dim(m)) return; /* if (uintset_count(&m->ind) >= mlogit_ncat(m) / 2) { if (!(m->mean_err == 0.0)) recompute_mean(m); recompute_cov(m); return; } */ size_t dim = mlogit_dim(m); size_t cov_dim = dim * (dim + 1) / 2; const double dpsi = m->work->dpsi; const double log_scale = m->log_cov_scale_; const double log_scale1 = log_scale + dpsi; //const double W = exp(log_scale); const double W1 = exp(log_scale1); double *dcov = m->work->cov_diff; compute_cov_diff(m); blas_daxpy(cov_dim, W1, dcov, 1, m->cov_, 1); m->log_cov_scale_ = log_scale1; m->cov_err += 1.0; m->log_cov_scale_err += 0.5 * DBL_EPSILON * (fabs(dpsi) + fabs(log_scale1)); const double tol = 1.0 / ROOT4_DBL_EPSILON; double err = (m->cov_err) / exp(log_scale1 - m->log_cov_scale_err); if (!(err < tol)) { blas_dcopy(cov_dim, m->cov_, 1, dcov, 1); if (!(m->mean_err == 0.0)) recompute_mean(m); recompute_cov(m); /* printf("!"); */ blas_dscal(cov_dim, -exp(m->log_cov_scale_ - log_scale1), dcov, 1); blas_daxpy(cov_dim, 1.0, m->cov_, 1, dcov, 1); } }
static void linesearch(struct bfgs *opt, double step0, double f0, double g0) { size_t n = opt->dim; opt->ls_it = 0; memcpy(opt->x, opt->x0, n * sizeof(opt->x[0])); blas_daxpy(n, step0, opt->search, 1, opt->x, 1); linesearch_start(&opt->ls, step0, f0, g0, &opt->ctrl.ls); }
void recompute_cov(struct mlogit *m) { size_t i, ncat = mlogit_ncat(m); size_t dim = mlogit_dim(m); if (dim == 0) return; const double *x = m->x; const double *mean = m->mean_; double *cov = m->cov_; double *cov_full = m->work->cov_diff_full; double *diff = m->work->xbuf1; double ptot; size_t nk = 0; double *diff_i = diff; // cov := 0; ptot := 0 memset(cov_full, 0, dim * dim * sizeof(*cov_full)); ptot = 0; for (i = 0; i < ncat; i++) { double p = catdist_prob(&m->dist_, i); if (p) { /* diff := mean - x[i,:] */ memcpy(diff_i, x + i * dim, dim * sizeof(*diff_i)); blas_daxpy(dim, -1.0, mean, 1, diff_i, 1); blas_dscal(dim, sqrt(p), diff_i, 1); ptot += p; diff_i += dim; nk++; } if (nk == BLOCK_SIZE || i + 1 == ncat) { blas_dsyrk(F77_COV_UPLO, BLAS_NOTRANS, dim, nk, 1.0, diff, dim, 1.0, cov_full, dim); diff_i = diff; nk = 0; } } assert(nk == 0); assert(diff_i == diff); packed_dgthr(F77_COV_UPLO, dim, cov_full, dim, cov); m->log_cov_scale_ = log(ptot); m->cov_err = 0.0; m->log_cov_scale_err = 0.0; }
void update_dist(struct mlogit *m) { if (!mlogit_dim(m)) return; /* if (uintset_count(&m->ind) >= mlogit_ncat(m) / 2) { recompute_dist(m); return; } */ const size_t dim = mlogit_dim(m); const double psi = catdist_psi(&m->dist_); const double *x = m->x; double *eta = m->work->w0; double *eta1 = m->work->dw; // copy old values of eta and compute new eta values const size_t *ind; size_t iz, nz; uintset_get_vals(&m->ind, &ind, &nz); for (iz = 0; iz < nz; iz++) { size_t i = ind[iz]; eta[iz] = catdist_eta(&m->dist_, i); eta1[iz] = blas_ddot(dim, m->beta, 1, x + i * dim, 1); } // update dist for (iz = 0; iz < nz; iz++) { size_t i = ind[iz]; catdist_set_eta(&m->dist_, i, eta1[iz]); } // compute new value of psi const double psi1 = catdist_psi(&m->dist_); m->work->dpsi = psi1 - psi; // eta (w0) := exp(eta - psi1); for (iz = 0; iz < nz; iz++) { eta[iz] = exp(eta[iz] - psi1); } // eta1 := exp(eta1 - psi1) for (iz = 0; iz < nz; iz++) { eta1[iz] = exp(eta1[iz] - psi1); } // eta1 (dw) := eta1 - eta (w0) blas_daxpy(nz, -1.0, eta, 1, eta1, 1); }
static void recompute() { struct catdist c; double *eta = xmalloc(N * sizeof(*eta)); double *diff = xcalloc(P, sizeof(*diff)); enum blas_uplo uplo = COV_UPLO == BLAS_LOWER ? BLAS_UPPER : BLAS_LOWER; double p, ptot; size_t i; catdist_init(&c, N); memset(MEAN, 0, P * sizeof(*MEAN)); memset(COV, 0, (P * (P + 1) / 2) * sizeof(*COV)); if (P == 0) goto cleanup; blas_dgemv(BLAS_TRANS, P, N, 1.0, X, P, BETA, 1, 0.0, eta, 1.0); catdist_set_all_eta(&c, eta); blas_dcopy(P, X, 1, MEAN, 1); ptot = catdist_prob(&c, 0); for (i = 1; i < N; i++) { /* diff := x[i,:] - mean */ blas_dcopy(P, X + i * P, 1, diff, 1); blas_daxpy(P, -1.0, MEAN, 1, diff, 1); /* ptot += p */ p = catdist_prob(&c, i); ptot += p; /* mean := mean + p/ptot * diff */ if (ptot > 0) blas_daxpy(P, p/ptot, diff, 1, MEAN, 1); } ptot = 0; for (i = 0; i < N; i++) { /* diff := x[i,:] - mean */ blas_dcopy(P, X + i * P, 1, diff, 1); blas_daxpy(P, -1.0, MEAN, 1, diff, 1); /* ptot += p */ p = catdist_prob(&c, i); ptot += p; /* COV += sqrt(n) * diff^2 */ blas_dspr(uplo, P, p, diff, 1, COV); } /* COV /= ptot */ blas_dscal(P * (P + 1) / 2, 1.0 / ptot, COV, 1); cleanup: catdist_deinit(&c); free(diff); free(eta); }
int mlogit_check(const struct mlogit *m) { int fail = 0; size_t n = mlogit_ncat(m); size_t p = mlogit_dim(m); const double *x = mlogit_x(m); const double *beta = mlogit_coefs(m); const double *mean = mlogit_mean(m); double cov_scale; const double *cov = mlogit_cov(m, &cov_scale); size_t i, j; double *eta0 = xcalloc(n, sizeof(*eta0)); double *prob0 = xcalloc(n, sizeof(*prob0)); double *mean0 = xcalloc(p, sizeof(*mean0)); double *cov0 = xcalloc(p * (p + 1) / 2, sizeof(*cov0)); double *cov0_copy = xcalloc(p * (p + 1) / 2, sizeof(*cov0_copy)); double *cov_err = xcalloc(p * (p + 1) / 2, sizeof(*cov_err)); double *z = xmalloc(p * p * sizeof(*z)); double *w = xmalloc(p * sizeof(*w)); double *diff = xcalloc(p, sizeof(*diff)); double *err_z = xmalloc(p * sizeof(*err_z)); const enum blas_uplo uplo = F77_COV_UPLO; double probtot0 = 0; size_t lwork, liwork; lwork = lapack_dspevd_lwork(LA_EIG_VEC, p, &liwork); double *work = xmalloc(lwork * sizeof(*work)); ptrdiff_t *iwork = xmalloc(liwork * sizeof(*iwork)); CHECK(!catdist_check(&m->dist_)); blas_dcopy(n, m->offset, 1, eta0, 1); if (p > 0) blas_dgemv(BLAS_TRANS, p, n, 1.0, x, p, beta, 1, 1.0, eta0, 1); for (i = 0; i < n; i++) { CHECK_APPROX(eta0[i], catdist_eta(&m->dist_, i)); } for (i = 0; i < n; i++) { prob0[i] = catdist_prob(&m->dist_, i); probtot0 += prob0[i]; } if (m->moments < 1) goto out; if (p > 0) blas_dgemv(BLAS_NOTRANS, p, n, 1.0, x, p, prob0, 1, 0.0, mean0, 1); for (j = 0; j < p; j++) { CHECK_APPROX(mean0[j], mean[j]); } if (m->moments < 2) goto out; for (i = 0; i < n; i++) { blas_dcopy(p, x + i * p, 1, diff, 1); blas_daxpy(p, -1.0, mean0, 1, diff, 1); blas_dspr(uplo, p, prob0[i], diff, 1, cov0); } blas_dscal(p * (p + 1) / 2, 1.0 / probtot0, cov0, 1); // cov_err := cov0 - (1/cov_scale) * cov blas_dcopy(p * (p + 1) / 2, cov0, 1, cov_err, 1); blas_daxpy(p * (p + 1) / 2, -1.0 / cov_scale, cov, 1, cov_err, 1); // compute cov0 eigendecomp blas_dcopy(p * (p + 1) / 2, cov0, 1, cov0_copy, 1); ptrdiff_t info = lapack_dspevd(LA_EIG_VEC, uplo, p, cov0_copy, w, z, MAX(1, p), work, lwork, iwork, liwork); assert(info == 0); (void)info; // check for relative equality of cov0 and (1/cov_scale) * cov // on the eigenspaces of cov0 for (i = p; i > 0; i--) { const double *zi = z + (i - 1) * p; blas_dspmv(uplo, p, 1.0, cov_err, zi, 1, 0.0, err_z, 1); double z_err_z = blas_ddot(p, zi, 1, err_z, 1); CHECK(fabs(z_err_z) <= 2 * p * SQRT_DBL_EPSILON * (1 + fabs(w[i - 1]))); } out: free(iwork); free(work); free(err_z); free(diff); free(w); free(z); free(cov_err); free(cov0_copy); free(cov0); free(mean0); free(prob0); free(eta0); return fail; }
void compute_cov_diff(struct mlogit *m) { size_t dim = mlogit_dim(m); const double *x0 = m->x0; const double *x1 = m->x; const double *w0 = m->work->w0; const double *mean0 = m->work->mean0; const double *dmean = m->work->dmean; const double log_scale = m->log_cov_scale_; const double dpsi = m->work->dpsi; const double W1 = exp(log_scale + dpsi); double *dcov = m->work->cov_diff_full; double *diff = m->work->xbuf1; const size_t *ind; size_t iz, nz; size_t nk = 0; double *diff_i = diff; uintset_get_vals(&m->ind, &ind, &nz); assert(dim > 0); memset(dcov, 0, dim * dim * sizeof(*dcov)); // handle positive terms for (iz = 0; iz < nz; iz++) { const size_t i = ind[iz]; const double *x1_i = x1 + i * dim; const double w1_i = catdist_prob(&m->dist_, i); if (w1_i > 0) { blas_dcopy(dim, x1_i, 1, diff_i, 1); blas_daxpy(dim, -1.0, mean0, 1, diff_i, 1); blas_dscal(dim, sqrt(w1_i), diff_i, 1); m->cov_err += 64 * W1 * w1_i; diff_i += dim; nk++; } if (nk == BLOCK_SIZE || iz + 1 == nz) { blas_dsyrk(F77_COV_UPLO, BLAS_NOTRANS, dim, nk, 1.0, diff, dim, 1.0, dcov, dim); diff_i = diff; nk = 0; } } assert(nk == 0); assert(diff_i == diff); // handle dmean and negative terms blas_dcopy(dim, dmean, 1, diff_i, 1); m->cov_err += W1; diff_i += dim; nk++; for (iz = 0; iz < nz; iz++) { const double *x0_i = x0 + iz * dim; const double w0_i = w0[iz]; if (w0_i > 0) { blas_dcopy(dim, x0_i, 1, diff_i, 1); blas_daxpy(dim, -1.0, mean0, 1, diff_i, 1); blas_dscal(dim, sqrt(w0_i), diff_i, 1); m->cov_err += 64 * W1 * w0_i; diff_i += dim; nk++; } if (nk == BLOCK_SIZE || iz + 1 == nz) { blas_dsyrk(F77_COV_UPLO, BLAS_NOTRANS, dim, nk, -1.0, diff, dim, 1.0, dcov, dim); diff_i = diff; nk = 0; } } // note: nz = 0 implies dmean = 0; no need to call dsyrk packed_dgthr(F77_COV_UPLO, dim, dcov, dim, m->work->cov_diff); }
void update_mean(struct mlogit *m) { if (mlogit_moments(m) < 1 || !mlogit_dim(m)) return; /* if (uintset_count(&m->ind) >= mlogit_ncat(m) / 2) { recompute_mean(m); return; } */ size_t dim = mlogit_dim(m); const double *one = m->work->one; const double *mean0 = m->mean_; const double *dx = m->work->dx; const double *dw = m->work->dw; const double *w0 = m->work->w0; double *dmean = m->work->dmean; double *xresid = m->work->xbuf1; memset(dmean, 0, dim * sizeof(*dmean)); const size_t *ind; size_t iz, nz; double *xresid_i = xresid; size_t nk = 0; uintset_get_vals(&m->ind, &ind, &nz); for (iz = 0; iz < nz; iz++) { size_t i = ind[iz]; double dw_i = dw[iz]; double w0_i = w0[iz]; const double *x_i = m->x + i * dim; const double *dx_i = dx + iz * dim; // xresid[i] := dw[i] * (x1[i] - mu0) if (dw_i != 0) { blas_dcopy(dim, x_i, 1, xresid_i, 1); blas_daxpy(dim, -1.0, mean0, 1, xresid_i, 1); blas_dscal(dim, dw_i, xresid_i, 1); } else { memset(xresid_i, 0, dim * sizeof(*xresid_i)); } // xresid[i] := dw[i] * (x1[i] - mu0) + w0[i] * dx[i] if (w0_i != 0) { blas_daxpy(dim, w0_i, dx_i, 1, xresid_i, 1); } m->mean_err += 8 * (fabs(dw_i) + w0_i); xresid_i += dim; nk++; if (nk == BLOCK_SIZE || iz + 1 == nz) { blas_dgemv(BLAS_NOTRANS, dim, nk, 1.0, xresid, dim, one, 1, 1.0, dmean, 1); xresid_i = xresid; nk = 0; } } blas_dcopy(dim, mean0, 1, m->work->mean0, 1); m->mean_err += 1.0; blas_daxpy(dim, 1.0, dmean, 1, m->mean_, 1); const double tol = 1.0 / ROOT4_DBL_EPSILON; if (!(m->mean_err < tol)) { recompute_mean(m); blas_dcopy(dim, m->mean_, 1, dmean, 1); blas_daxpy(dim, -1.0, m->work->mean0, 1, dmean, 1); } }
static void test_imat() { const struct message *msgs; size_t i, j, n; history_get_messages(HISTORY, &msgs, &n); const struct message *msg = NULL; size_t dim = recv_model_dim(RECV_MODEL); size_t cov_dim = dim * (dim + 1) / 2; const struct design *r = RECV_DESIGN; const struct design2 *d = DYAD_DESIGN; struct recv_params mean, diff; double *diff_vec = xmalloc(dim * sizeof(double)); double *cov0 = xmalloc(cov_dim * sizeof(double)); double *cov1 = xmalloc(cov_dim * sizeof(double)); double *scaled_cov0 = xmalloc(cov_dim * sizeof(double)); double *scaled_cov1 = xmalloc(cov_dim * sizeof(double)); double *last_cov0 = xmalloc(cov_dim * sizeof(double)); double *last_cov1 = xmalloc(cov_dim * sizeof(double)); recv_params_init(&mean, r, d); recv_params_init(&diff, r, d); const struct catdist1 *dist = NULL; const enum blas_uplo uplo = MLOGIT_COV_UPLO; const enum blas_uplo fuplo = uplo == BLAS_UPPER ? BLAS_LOWER : BLAS_UPPER; memset(cov0, 0, cov_dim * sizeof(*cov0)); for (i = 0; i < MIN(1000, n); i++) { printf("."); fflush(stdout); msg = &msgs[i]; recv_loglik_add(RECV_LOGLIK, msg); /* compute mean */ recv_params_set(&mean, NULL, r, d); recv_loglik_axpy_last_mean(1.0 / (msg->nto), RECV_LOGLIK, &mean); /* compute last_cov0 */ dist = recv_model_dist(RECV_MODEL, msg->from); memset(last_cov0, 0, cov_dim * sizeof(double)); for (j = 0; j < NRECV; j++) { recv_params_set(&diff, &mean, r, d); design_axpy(-1.0, r, j, &diff.recv); design2_axpy(-1.0, d, msg->from, j, &diff.dyad); double w = catdist1_prob(dist, j); size_t off = 0; memcpy(diff_vec + off, diff.recv.traits, design_trait_dim(r) * sizeof(double)); off += design_trait_dim(r); memcpy(diff_vec + off, diff.recv.tvars, design_tvar_dim(r) * sizeof(double)); off += design_tvar_dim(r); memcpy(diff_vec + off, diff.dyad.traits, design2_trait_dim(d) * sizeof(double)); off += design2_trait_dim(d); memcpy(diff_vec + off, diff.dyad.tvars, design2_tvar_dim(d) * sizeof(double)); off += design2_tvar_dim(d); blas_dspr(fuplo, dim, w, diff_vec, 1, last_cov0); } blas_dscal(cov_dim, msg->nto, last_cov0, 1); /* compute last_cov1 */ memset(last_cov1, 0, cov_dim * sizeof(double)); recv_loglik_axpy_last_imat(1.0, RECV_LOGLIK, last_cov1); assert_sym_approx(last_cov0, last_cov1, uplo, dim); /* compute cov0 */ blas_daxpy(cov_dim, 1.0, last_cov0, 1, cov0, 1); /* compute cov1 */ memset(cov1, 0, cov_dim * sizeof(double)); recv_loglik_axpy_imat(1.0, RECV_LOGLIK, cov1); double n = (double)recv_loglik_count(RECV_LOGLIK); memcpy(scaled_cov0, cov0, cov_dim * sizeof(double)); memcpy(scaled_cov1, cov1, cov_dim * sizeof(double)); blas_dscal(cov_dim, 1.0/n, scaled_cov0, 1); blas_dscal(cov_dim, 1.0/n, scaled_cov1, 1); assert_sym_approx(scaled_cov0, scaled_cov1, BLAS_UPPER, dim); blas_dcopy(dim, cov1, 1, cov0, 1); } recv_params_deinit(&diff); recv_params_deinit(&mean); free(last_cov1); free(last_cov0); free(scaled_cov1); free(scaled_cov0); free(cov1); free(cov0); free(diff_vec); }
LVAL xslpdqrdc(V) { LVAL x, a, j, w, r, q; double *dx, *da, *dw, *dr, *dq; int offx, ldx, n, p, *dj, job; x = xlgetarg(); offx = getfixnum(xlgafixnum()); ldx = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); p = getfixnum(xlgafixnum()); a = xlgetarg(); j = xlgetarg(); w = xlgetarg(); job = getfixnum(xlgafixnum()); r = moreargs() ? xlgetarg() : NIL; q = moreargs() ? xlgetarg() : NIL; xllastarg(); if (p > n && (! null(r) || ! null(q))) xlfail("more columns than rows"); checkldim(ldx, n); dx = getlinalgdvec(offx, ldx * p, x); da = getlinalgdvec(0, p, a); dj = job != 0 ? getlinalgivec(0, p, j) : NULL; dw = job != 0 ? getlinalgdvec(0, p, w) : NULL; dr = null(r) ? NULL : getlinalgdvec(0, p * p, r); dq = null(q) ? NULL : getlinalgdvec(0, n * p, q); linpack_dqrdc(dx, ldx, n, p, da, dj, dw, job); if (! null(r)) { int i, j, ip, jn; /* copy the upper triangle of X to R in row major order */ for (i = 0, ip = 0; i < p; i++, ip += p) { for (j = 0; j < i; j++) dr[ip + j] = 0.0; for (j = i, jn = j * n; j < p; j++, jn += n) dr[ip + j] = dx[jn + i]; } } if (! null(q)) { int i, j, ip, jn, jp; double t; /* copy X into Q in row major order */ for (i = 0, ip = 0; i < n; i++, ip += p) for (j = 0, jn = 0; j < p; j++, jn += n) dq[ip + j] = dx[jn + i]; /* accumulate the Q transformation */ for (i = 0, ip = 0; i < p; i++, ip += p) { dq[ip + i] = da[i]; for (j = i + 1; j < p; j++) dq[ip + j] = 0.0; } for (i = p - 1, ip = i * p; i >= 0; i--, ip -= p) { if (i == n - 1) dq[ip + i] = 1.0; else { for (j = i, jp = ip; j < n; j++, jp += p) dq[jp + i] = -dq[jp + i]; dq[ip + i] += 1.0; } for (j = i - 1, jp = ip - p; j >= 0; j--, jp -= p) { if (dq[jp + j] != 0.0) { t = -blas_ddot(n - j, dq + jp + j, p, dq + jp + i, p) / dq[jp + j]; blas_daxpy(n - j, t, dq + jp + j, p, dq + jp + i, p); } } } } return NIL; }