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); } } } } }