void la_dposv(int Arow, int Bcol, double **A, double **B)
{
char cholTri = 'L'; // return cholesky decomp of col-major A in lower triangle
int info;
dposv_(&cholTri, &Arow, &Bcol, *A, &Arow, *B, &Arow, &info);
assert(info==0); // if info = -i, i'th arg is wrong. if info > A is not pos-def.
}
template <typename fptype> static inline int
lapack_Cholesky(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, bool* info)
{
int lapackStatus;
int lda = a_step / sizeof(fptype);
char L[] = {'L', '\0'};
if(b)
{
if(n == 1 && b_step == sizeof(fptype))
{
if(typeid(fptype) == typeid(float))
sposv_(L, &m, &n, (float*)a, &lda, (float*)b, &m, &lapackStatus);
else if(typeid(fptype) == typeid(double))
dposv_(L, &m, &n, (double*)a, &lda, (double*)b, &m, &lapackStatus);
}
else
{
int ldb = b_step / sizeof(fptype);
fptype* tmpB = new fptype[m*n];
transpose(b, ldb, tmpB, m, m, n);
if(typeid(fptype) == typeid(float))
sposv_(L, &m, &n, (float*)a, &lda, (float*)tmpB, &m, &lapackStatus);
else if(typeid(fptype) == typeid(double))
dposv_(L, &m, &n, (double*)a, &lda, (double*)tmpB, &m, &lapackStatus);
transpose(tmpB, m, b, ldb, n, m);
delete[] tmpB;
}
}
else
{
if(typeid(fptype) == typeid(float))
spotrf_(L, &m, (float*)a, &lda, &lapackStatus);
else if(typeid(fptype) == typeid(double))
dpotrf_(L, &m, (double*)a, &lda, &lapackStatus);
}
if(lapackStatus == 0) *info = true;
else *info = false; //in opencv Cholesky function false means error
return CV_HAL_ERROR_OK;
}
void ProtoMol::Lapack::dposv(char *transA, int *n, int *nrhs, double *a,
int *lda, double *b, int *ldb, int *info) {
FAHCheckIn();
#if defined(HAVE_LAPACK)
dposv_(transA, n, nrhs, a, lda, b, ldb, info);
#elif defined(HAVE_MKL_LAPACK)
DPOSV(transA, n, nrhs, a, lda, b, ldb, info);
#else
THROW(std::string(__func__) + " not supported");
#endif
}
static int stepy_ (integer *n, integer *p, doublereal *a,
doublereal *d, doublereal *b, doublereal *ada,
integer *info)
{
integer i, m = *p * *p;
int attempt = 0;
int err = 0;
try_again:
for (i=0; i<m; i++) {
ada[i] = 0.0;
}
for (i=0; i<*n; i++) {
dsyr_("U", p, &d[i], &a[i * *p], &one, ada, p);
}
if (attempt == 0) {
dposv_("U", p, &one, ada, p, b, p, info);
if (*info != 0) {
fprintf(stderr, "stepy: dposv gave info = %d\n", *info);
attempt = 1;
goto try_again;
}
} else {
gretl_matrix A, B;
gretl_matrix_init(&A);
gretl_matrix_init(&B);
A.rows = A.cols = *p;
A.val = ada;
B.rows = *p;
B.cols = 1;
B.val = b;
err = gretl_LU_solve(&A, &B);
if (err) {
fprintf(stderr, "stepy: gretl_LU_solve: err = %d\n", err);
}
}
return err;
}
/* method used below is linear least squares */
void get_weights(matrix *X, matrix *Y, matrix *B)
{
matrix * A;
char uplo;
int info;
A = initMatrix();
allocMatrix(A,X->cols,X->cols);
/* X'*X -> A */
multATA(X,A);
/* X'*Y -> B */
multATB(X,Y,B);
/* Solve Ax = B */
uplo = 'u';
dposv_(&uplo,&A->cols,&B->cols,A->data,&A->rows,B->data,&A->rows,&info);
if (info != 0)
printError(1,__FILE__,__LINE__,"dposv returned non-zero info");
freeMatrix(A);
}
/* Subroutine */ int ddrvpo_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
doublereal rcond, roldc, scond;
integer nimat;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *), dpot02_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *), dpot05_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *);
doublereal anorm;
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int dposv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *), alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
logical prefac;
doublereal rcondc;
logical nofact;
integer iequed;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasvm_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, char *), dpoequ_(integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *), dpotrf_(
char *, integer *, doublereal *, integer *, integer *),
dpotri_(char *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *), derrvx_(char *, integer *);
doublereal result[6];
extern /* Subroutine */ int dposvx_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, char *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVPO tests the driver routines DPOSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L120;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L90;
}
rcondc = 0.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by DPOSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
dlaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
scond, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in DGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = dlansy_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
dpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlansy_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
dlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test DPOSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPOSV ", (ftnlen)32, (
ftnlen)6);
dposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from DPOSV . */
if (info != izero) {
alaerh_(path, "DPOSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
&work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "DPOSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test DPOSVX --- */
if (! prefac) {
dlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
lda);
}
dlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
dlaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DPOSVX. */
s_copy(srnamc_1.srnamt, "DPOSVX", (ftnlen)32, (ftnlen)
6);
dposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
&iwork[1], &info);
/* Check the error code from DPOSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DPOSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from DPOSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "DPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "DPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
;
}
/* L100: */
}
L110:
;
}
L120:
;
}
/* L130: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVPO */
} /* ddrvpo_ */
computemix(char *fnames[], int nscores, double *xty)
{
#ifdef HOLDOUT
lg("With holdout\n");
#endif
int ns2=nscores+2;
int ns1=nscores+1;
FILE *fp[NSCORES];
openfiles(fp,fnames,nscores);
double xtx[NSCORES+2][NSCORES+2];
ZERO(xtx);
int u;
for(u=0; u<NUSERS; u++) {
PROGRESS(u,NUSERS);
int base=useridx[u][0];
#ifdef HOLDOUT
if(aopt) error("cant do holdout with -a");
int d0=UNTRAIN(u);
int d1=UNALL(u)-d0;
#else
int d0=0;
int d1=UNTRAIN(u);
#endif
seekfiles(fp,nscores, d0);
base+=d0;
int j;
for(j=0;j<d1;j++) {
unsigned int dd=userent[base+j];
int r = (dd>>USER_LMOVIEMASK)&7;
float s[NSCORES+2];
readfiles(fp,s,nscores);
int f;
for(f=0;f<nscores;f++)
s[f]=r-s[f];
s[nscores]=1.;
s[nscores+1]=r;
int ff;
for(f=0;f<ns2;f++) {
for(ff=0;ff<ns2;ff++)
xtx[f][ff] +=s[f]*s[ff];
}
}
int d2=UNTOTAL(u)-(d1+d0);
seekfiles(fp,nscores, d2);
}
closefiles(fp,nscores);
int count=xtx[nscores][nscores];
int j1,j2;
for(j1=0;j1<nscores;j1++)
lg("File %d RMSE %f\n",j1,sqrt((xtx[j1][j1]+xtx[ns1][ns1]-2*xtx[ns1][j1])/count));
double avgs[NSCORES+2],std[NSCORES+2];
for(j1=0;j1<ns2;j1++) {
avgs[j1]=xtx[nscores][j1]/count;
std[j1]=sqrt(xtx[j1][j1]/count-avgs[j1]*avgs[j1]);
}
for(j1=0;j1<ns2;j1++)
lg("%f\t",avgs[j1]);
lg("\n");
for(j1=0;j1<ns2;j1++)
lg("%f\t",std[j1]);
lg("\n");
lg("-------------------------------------------------\n");
for(j1=0;j1<ns2;j1++) {
for(j2=0;j2<ns2;j2++) {
lg("%f\t",(xtx[j1][j2]/count-avgs[j1]*avgs[j2])/(std[j1]*std[j2]+1.e-6));
}
lg("\n");
}
lg("-------------------------------------------------\n");
double eavgs[NSCORES],estd[NSCORES];
for(j1=0;j1<nscores;j1++) {
eavgs[j1]=avgs[ns1]-avgs[j1];
estd[j1]=sqrt((xtx[ns1][ns1]+ xtx[j1][j1]-2*xtx[j1][ns1])/count);
}
for(j1=0;j1<nscores;j1++)
lg("%f\t",eavgs[j1]);
lg("\n");
for(j1=0;j1<nscores;j1++)
lg("%f\t",estd[j1]);
lg("\n");
lg("-------------------------------------------------\n");
for(j1=0;j1<nscores;j1++) {
for(j2=0;j2<nscores;j2++) {
lg("%f\t",((xtx[j1][j2]+xtx[ns1][ns1]-xtx[ns1][j1]-xtx[ns1][j2])/count-eavgs[j1]*eavgs[j2])/(estd[j1]*estd[j2]+1.e-6));
}
lg("\n");
}
char TRANS='N';
char UFLO='U';
int M=ns1;
int N=ns1;
int NRHS=1;
double A[NSCORES+1][NSCORES+1];
int LDA=NSCORES+1;
double B[NSCORES+1];
int LDB=NSCORES+1;
double S[NSCORES+1];
double RCOND=0.00001; // singular values below this are treated as zero.
int RANK;
double WORK[1000];
int LWORK=1000;
int INFO;
for(j1=0;j1<ns1;j1++) {
B[j1]=xtx[ns1][j1];
for(j2=0;j2<ns1;j2++)
A[j1][j2]=xtx[j1][j2];
}
for(j1=0;j1<ns1;j1++) A[j1][j1]+=LAMBDA;
/*dgesv_(&N,&NRHS,A,&LDA,IPIV,B,&LDB,&INFO);*/
/*dgels_(&TRANS,&M,&N,&NRHS,A,&LDA,B,&LDB,WORK,&LWORK,&INFO);*/
/*dgelss_( &M, &N, &NRHS, A, &LDA, B, &LDB, S, &RCOND, &RANK, WORK, &LWORK, &INFO );*/
dposv_(&UFLO,&N,&NRHS,A,&LDA,B,&LDB,&INFO);
if(INFO) error("failed %d\n",INFO);
for(j1=0;j1<=nscores;j1++)
xty[j1]=B[j1];
lg("Check that the matrix inversion worked:\n");
for(j1=0;j1<=nscores;j1++) {
double sum=LAMBDA*B[j1];
for(j2=0;j2<=nscores;j2++)
sum+=xtx[j1][j2]*B[j2];
lg("%f\t%f\n",sum,xtx[nscores+1][j1]);
}
}
/*
* update2D()
*
* Update current fits given equal width in x and y.
*
* This procedure is also responsible for flagging peaks
* that might be bad & that should be removed from fitting.
*/
void update2D()
{
// Lapack
int n = 5, nrhs = 1, lda = 5, ldb = 5, info;
// Local
int i,j,k,l,m,wx,wy;
double fi,xi,xt,ext,yt,eyt,e_t,t1,t2,a1,width;
double delta[NPEAKPAR];
double jt[5];
double jacobian[5];
double hessian[25];
fitData *cur;
for(i=0;i<NPEAKPAR;i++){
delta[i] = 0.0;
}
for(i=0;i<nfit;i++){
cur = &fit[i];
if(cur->status==RUNNING){
for(j=0;j<5;j++){
jacobian[j] = 0.0;
}
for(j=0;j<25;j++){
hessian[j] = 0.0;
}
l = cur->offset;
wx = cur->wx;
wy = cur->wy;
a1 = cur->params[HEIGHT];
width = cur->params[XWIDTH];
for(j=-wy;j<=wy;j++){
yt = cur->yt[j+wy];
eyt = cur->eyt[j+wy];
for(k=-wx;k<=wx;k++){
m = j*image_size_x+k+l;
fi = f_data[m]+bg_data[m]/((double)bg_counts[m]);
xi = x_data[m];
xt = cur->xt[k+wx];
ext = cur->ext[k+wx];
e_t = ext*eyt;
jt[0] = e_t;
jt[1] = 2.0*a1*width*xt*e_t;
jt[2] = 2.0*a1*width*yt*e_t;
jt[3] = -a1*xt*xt*e_t-a1*yt*yt*e_t;
jt[4] = 1.0;
// calculate jacobian
t1 = 2.0*(1.0 - xi/fi);
jacobian[0] += t1*jt[0];
jacobian[1] += t1*jt[1];
jacobian[2] += t1*jt[2];
jacobian[3] += t1*jt[3];
jacobian[4] += t1*jt[4];
// calculate hessian
t2 = 2.0*xi/(fi*fi);
// calculate hessian without second derivative terms.
hessian[0] += t2*jt[0]*jt[0];
hessian[1] += t2*jt[0]*jt[1];
hessian[2] += t2*jt[0]*jt[2];
hessian[3] += t2*jt[0]*jt[3];
hessian[4] += t2*jt[0]*jt[4];
// hessian[5]
hessian[6] += t2*jt[1]*jt[1];
hessian[7] += t2*jt[1]*jt[2];
hessian[8] += t2*jt[1]*jt[3];
hessian[9] += t2*jt[1]*jt[4];
// hessian[10]
// hessian[11]
hessian[12] += t2*jt[2]*jt[2];
hessian[13] += t2*jt[2]*jt[3];
hessian[14] += t2*jt[2]*jt[4];
// hessian[15]
// hessian[16]
// hessian[17]
hessian[18] += t2*jt[3]*jt[3];
hessian[19] += t2*jt[3]*jt[4];
// hessian[20]
// hessian[21]
// hessian[22]
// hessian[23]
hessian[24] += t2*jt[4]*jt[4];
}
}
// subtract the old peak out of the foreground and background arrays.
subtractPeak(cur);
// Use Lapack to solve AX=B to calculate update vector
dposv_( "Lower", &n, &nrhs, hessian, &lda, jacobian, &ldb, &info );
if(info!=0){
cur->status = ERROR;
if(TESTING){
printf("fitting error! %d %d %d\n", i, info, ERROR);
printf(" %f %f %f %f %f\n", delta[HEIGHT], delta[XCENTER], delta[YCENTER], delta[XWIDTH], delta[BACKGROUND]);
}
}
else{
// update params
delta[HEIGHT] = jacobian[0];
delta[XCENTER] = jacobian[1];
delta[YCENTER] = jacobian[2];
delta[XWIDTH] = jacobian[3];
delta[YWIDTH] = jacobian[3];
delta[BACKGROUND] = jacobian[4];
fitDataUpdate(cur, delta);
// add the new peak to the foreground and background arrays.
// recalculate peak fit area as the peak width may have changed.
if (cur->status != ERROR){
cur->wx = calcWidth(cur->params[XWIDTH],cur->wx);
cur->wy = cur->wx;
addPeak(cur);
}
}
}
}
}
/*
* updateZ()
*
* Update current fits given x, y width determined by z parameter.
*
* This procedure is also responsible for flagging peaks
* that might be bad & that should be removed from fitting.
*/
void updateZ()
{
// Lapack
int n = 5, nrhs = 1, lda = 5, ldb = 5, info;
// Local
int i,j,k,l,m,wx,wy;
double fi,xi,xt,ext,yt,eyt,e_t,t1,t2,a1,a3,a5;
double z0,z1,z2,zt,gx,gy;
double delta[NPEAKPAR];
double jt[5];
double jacobian[5];
double hessian[25];
fitData *cur;
for(i=0;i<NPEAKPAR;i++){
delta[i] = 0.0;
}
for(i=0;i<nfit;i++){
cur = &fit[i];
if(cur->status==RUNNING){
for(j=0;j<5;j++){
jacobian[j] = 0.0;
}
for(j=0;j<25;j++){
hessian[j] = 0.0;
}
l = cur->offset;
wx = cur->wx;
wy = cur->wy;
a1 = cur->params[HEIGHT];
a3 = cur->params[XWIDTH];
a5 = cur->params[YWIDTH];
// dwx/dz calcs
z0 = (cur->params[ZCENTER]-wx_z_params[1])/wx_z_params[2];
z1 = z0*z0;
z2 = z1*z0;
zt = 2.0*z0+3.0*wx_z_params[3]*z1+4.0*wx_z_params[4]*z2;
gx = -2.0*zt/(wx_z_params[0]*cur->wx_term);
// dwy/dz calcs
z0 = (cur->params[ZCENTER]-wy_z_params[1])/wy_z_params[2];
z1 = z0*z0;
z2 = z1*z0;
zt = 2.0*z0+3.0*wy_z_params[3]*z1+4.0*wy_z_params[4]*z2;
gy = -2.0*zt/(wy_z_params[0]*cur->wy_term);
for(j=-wy;j<=wy;j++){
yt = cur->yt[j+wy];
eyt = cur->eyt[j+wy];
for(k=-wx;k<=wx;k++){
m = j*image_size_x+k+l;
fi = f_data[m]+bg_data[m]/((double)bg_counts[m]);
xi = x_data[m];
xt = cur->xt[k+wx];
ext = cur->ext[k+wx];
e_t = ext*eyt;
// first derivatives
jt[0] = e_t;
jt[1] = 2.0*a1*a3*xt*e_t;
jt[2] = 2.0*a1*a5*yt*e_t;
jt[3] = -a1*xt*xt*gx*e_t-a1*yt*yt*gy*e_t;
jt[4] = 1.0;
// calculate jacobian
t1 = 2.0*(1.0 - xi/fi);
jacobian[0] += t1*jt[0];
jacobian[1] += t1*jt[1];
jacobian[2] += t1*jt[2];
jacobian[3] += t1*jt[3];
jacobian[4] += t1*jt[4];
// calculate hessian
t2 = 2.0*xi/(fi*fi);
// calculate hessian without second derivative terms.
hessian[0] += t2*jt[0]*jt[0];
hessian[1] += t2*jt[0]*jt[1];
hessian[2] += t2*jt[0]*jt[2];
hessian[3] += t2*jt[0]*jt[3];
hessian[4] += t2*jt[0]*jt[4];
// hessian[5]
hessian[6] += t2*jt[1]*jt[1];
hessian[7] += t2*jt[1]*jt[2];
hessian[8] += t2*jt[1]*jt[3];
hessian[9] += t2*jt[1]*jt[4];
// hessian[10]
// hessian[11]
hessian[12] += t2*jt[2]*jt[2];
hessian[13] += t2*jt[2]*jt[3];
hessian[14] += t2*jt[2]*jt[4];
// hessian[15]
// hessian[16]
// hessian[17]
hessian[18] += t2*jt[3]*jt[3];
hessian[19] += t2*jt[3]*jt[4];
// hessian[20]
// hessian[21]
// hessian[22]
// hessian[23]
hessian[24] += t2*jt[4]*jt[4];
}
}
// subtract the old peak out of the foreground and background arrays.
subtractPeak(cur);
// Use Lapack to solve AX=B to calculate update vector
dposv_( "Lower", &n, &nrhs, hessian, &lda, jacobian, &ldb, &info );
/*
for(j=0;j<5;j++){
for(k=0;k<5;k++){
printf("%.4f ", hessian[j*5+k]);
}
printf("\n");
}
*/
if(info!=0){
cur->status = ERROR;
if(TESTING){
printf("fitting error! %d %d %d\n", i, info, ERROR);
}
}
else{
// update params
delta[HEIGHT] = jacobian[0];
delta[XCENTER] = jacobian[1];
delta[YCENTER] = jacobian[2];
delta[ZCENTER] = jacobian[3];
delta[BACKGROUND] = jacobian[4];
fitDataUpdate(cur, delta);
// add the new peak to the foreground and background arrays.
if (cur->status != ERROR){
// calculate new x,y width, update fit area.
calcWidthsFromZ(cur);
cur->wx = calcWidth(cur->params[XWIDTH],cur->wx);
cur->wy = calcWidth(cur->params[YWIDTH],cur->wy);
addPeak(cur);
}
}
}
}
if(VERBOSE){
printf("\n");
}
}
/*
* update3D()
*
* Update current fits allowing all parameters to change.
*
* This procedure is also responsible for flagging peaks
* that might be bad & that should be removed from fitting.
*/
void update3D()
{
// Lapack
int n = 6, nrhs = 1, lda = 6, ldb = 6, info;
// Local
int i,j,k,l,m,wx,wy;
double fi,xi,xt,ext,yt,eyt,e_t,t1,t2,a1,a3,a5;
double delta[NPEAKPAR];
double jt[6];
double jacobian[6];
double hessian[36];
fitData *cur;
for(i=0;i<NPEAKPAR;i++){
delta[i] = 0.0;
}
for(i=0;i<nfit;i++){
cur = &fit[i];
if(cur->status==RUNNING){
for(j=0;j<6;j++){
jacobian[j] = 0.0;
}
for(j=0;j<36;j++){
hessian[j] = 0.0;
}
l = cur->offset;
wx = cur->wx;
wy = cur->wy;
a1 = cur->params[HEIGHT];
a3 = cur->params[XWIDTH];
a5 = cur->params[YWIDTH];
for(j=-wy;j<=wy;j++){
yt = cur->yt[j+wy];
eyt = cur->eyt[j+wy];
for(k=-wx;k<=wx;k++){
m = j*image_size_x+k+l;
fi = f_data[m]+bg_data[m]/((double)bg_counts[m]);
xi = x_data[m];
xt = cur->xt[k+wx];
ext = cur->ext[k+wx];
e_t = ext*eyt;
jt[0] = e_t;
jt[1] = 2.0*a1*a3*xt*e_t;
jt[2] = -a1*xt*xt*e_t;
jt[3] = 2.0*a1*a5*yt*e_t;
jt[4] = -a1*yt*yt*e_t;
jt[5] = 1.0;
// calculate jacobian
t1 = 2.0*(1.0 - xi/fi);
jacobian[0] += t1*jt[0];
jacobian[1] += t1*jt[1];
jacobian[2] += t1*jt[2];
jacobian[3] += t1*jt[3];
jacobian[4] += t1*jt[4];
jacobian[5] += t1*jt[5];
// calculate hessian
t2 = 2.0*xi/(fi*fi);
if (0){
// FIXME: not complete
// hessian with second derivative terms.
hessian[0] += t2*jt[0]*jt[0];
hessian[1] += t2*jt[0]*jt[1]+t1*2.0*xt*a3*ext*eyt;
hessian[2] += t2*jt[0]*jt[2];
hessian[3] += t2*jt[0]*jt[3]+t1*2.0*yt*a5*ext*eyt;
hessian[4] += t2*jt[0]*jt[4];
hessian[5] += t2*jt[0]*jt[5];
// hessian[6]
hessian[7] += t2*jt[1]*jt[1]+t1*(-2.0*a1*a3*ext*eyt+4.0*a1*a3*a3*xt*xt*ext*eyt);
hessian[8] += t2*jt[1]*jt[2]+t1*4.0*a1*xt*yt*a3*a3*ext*eyt;
hessian[9] += t2*jt[1]*jt[3];
hessian[10] += t2*jt[1]*jt[4];
hessian[11] += t2*jt[1]*jt[5];
// hessian[12]
// hessian[13]
hessian[14] += t2*jt[2]*jt[2]+t1*(-2.0*a1*a3*ext*eyt+4.0*a1*a3*a3*yt*yt*ext*eyt);
hessian[15] += t2*jt[2]*jt[3];
hessian[16] += t2*jt[2]*jt[4];
hessian[17] += t2*jt[2]*jt[5];
// hessian[18]
// hessian[19]
// hessian[20]
hessian[21] += t2*jt[3]*jt[3];
hessian[22] += t2*jt[3]*jt[4];
hessian[23] += t2*jt[3]*jt[5];
// hessian[24]
// hessian[25]
// hessian[26]
// hessian[27]
hessian[28] += t2*jt[4]*jt[4];
hessian[29] += t2*jt[4]*jt[5];
// hessian[30]
// hessian[31]
// hessian[32]
// hessian[33]
// hessian[34]
hessian[35] += t2*jt[5]*jt[5];
}
else {
// hessian without second derivative terms.
hessian[0] += t2*jt[0]*jt[0];
hessian[1] += t2*jt[0]*jt[1];
hessian[2] += t2*jt[0]*jt[2];
hessian[3] += t2*jt[0]*jt[3];
hessian[4] += t2*jt[0]*jt[4];
hessian[5] += t2*jt[0]*jt[5];
// hessian[6]
hessian[7] += t2*jt[1]*jt[1];
hessian[8] += t2*jt[1]*jt[2];
hessian[9] += t2*jt[1]*jt[3];
hessian[10] += t2*jt[1]*jt[4];
hessian[11] += t2*jt[1]*jt[5];
// hessian[12]
// hessian[13]
hessian[14] += t2*jt[2]*jt[2];
hessian[15] += t2*jt[2]*jt[3];
hessian[16] += t2*jt[2]*jt[4];
hessian[17] += t2*jt[2]*jt[5];
// hessian[18]
// hessian[19]
// hessian[20]
hessian[21] += t2*jt[3]*jt[3];
hessian[22] += t2*jt[3]*jt[4];
hessian[23] += t2*jt[3]*jt[5];
// hessian[24]
// hessian[25]
// hessian[26]
// hessian[27]
hessian[28] += t2*jt[4]*jt[4];
hessian[29] += t2*jt[4]*jt[5];
// hessian[30]
// hessian[31]
// hessian[32]
// hessian[33]
// hessian[34]
hessian[35] += t2*jt[5]*jt[5];
// Ignore off-diagonal terms.
// This approach converges incredibly slowly.
/*
hessian[0] += t2*jt[0]*jt[0];
hessian[7] += t2*jt[1]*jt[1];
hessian[14] += t2*jt[2]*jt[2];
hessian[21] += t2*jt[3]*jt[3];
hessian[28] += t2*jt[4]*jt[4];
hessian[35] += t2*jt[5]*jt[5];
*/
}
}
}
/*
printf("hessian:\n");
for(j=0;j<6;j++){
for(k=0;k<6;k++){
printf("%.4f ", hessian[j*6+k]);
}
printf("\n");
}
printf("\n");
*/
// subtract the old peak out of the foreground and background arrays.
subtractPeak(cur);
// Use Lapack to solve AX=B to calculate update vector
dposv_( "Lower", &n, &nrhs, hessian, &lda, jacobian, &ldb, &info );
if(info!=0){
cur->status = ERROR;
if(TESTING){
printf("fitting error! %d %d %d\n", i, info, ERROR);
}
}
else{
// update params
delta[HEIGHT] = jacobian[0];
delta[XCENTER] = jacobian[1];
delta[XWIDTH] = jacobian[2];
delta[YCENTER] = jacobian[3];
delta[YWIDTH] = jacobian[4];
delta[BACKGROUND] = jacobian[5];
fitDataUpdate(cur, delta);
// add the new peak to the foreground and background arrays.
if (cur->status != ERROR){
cur->wx = calcWidth(cur->params[XWIDTH],cur->wx);
cur->wy = calcWidth(cur->params[YWIDTH],cur->wy);
addPeak(cur);
}
}
}
}
}
