/* Right-hand-side equation for wavefunction */
int RHS_WFN(realtype t, N_Vector y, N_Vector ydot, void * data) {
// data is a pointer to the params struct
Params * p;
p = (Params *) data;
// update Hamiltonian if it is time-dependent
if (p->torsion || p->laser_on) {
#ifdef DEBUG
std::cout << "Updating Hamiltonian at time " << t << std::endl;
#endif
// only update if at a new time point
if ((t > 0.0) && (t != p->lastTime)) {
updateHamiltonian(p, t);
// update time point
p->lastTime = t;
}
}
else {
#ifdef DEBUG
std::cout << "Not updating Hamiltonian at time " << t << std::endl;
#endif
}
// extract parameters from p
realtype * H = &(p->H)[0];
//realtype * H = &(p->H_lo)[0];
int N = p->NEQ;
// get pointer to y, ydot data
realtype * yp = N_VGetArrayPointer(y);
realtype * ydotp = N_VGetArrayPointer(ydot);
#ifdef DEBUG_RHS
std::cout << "Pointer to ydot is " << ydotp << std::endl;
#endif
// set up BLAS variables
// const char TRANS = 'n';
const char UPLO = 'l';
double beta = 0.0;
double alpha_re = 1.0; // alpha value for real part of wfn derivative
double alpha_im = -1.0; // alpha value for imag part of wfn derivative
int inc = 1;
// Re(\dot{\psi}) = \hat{H}Im(\psi)
//dgemv_(&TRANS, &N, &N, &alpha_re, &H[0], &N, &yp[N], &inc, &beta, &ydotp[0], &inc);
dsymv_(&UPLO, &N, &alpha_re, &H[0], &N, &yp[N], &inc, &beta, &ydotp[0], &inc);
// Im(\dot{\psi}) = -i\hat{H}Re(\psi)
//dgemv_(&TRANS, &N, &N, &alpha_im, &H[0], &N, &yp[0], &inc, &beta, &ydotp[N], &inc);
dsymv_(&UPLO, &N, &alpha_im, &H[0], &N, &yp[0], &inc, &beta, &ydotp[N], &inc);
return 0;
}
/*! _dsymatrix*_dcovector operator */
inline _dcovector operator*(const _dsymatrix& mat, const _dcovector& vec)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] operator*(const _dsymatrix&, const _dcovector&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(mat.N!=vec.L){
std::cerr << "[ERROR] operator*(const _dsymatrix&, const _dcovector&)"
<< std::endl
<< "These matrix and vector can not make a product." << std::endl
<< "Your input was (" << mat.N << "x" << mat.N << ") * ("
<< vec.L << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
dcovector newvec(mat.N);
dsymv_( 'L', mat.N, 1.0, mat.Array, mat.N,
vec.Array, 1, 0.0, newvec.array, 1 );
mat.destroy();
vec.destroy();
return _(newvec);
}
void DenseSymMatrix::mult ( double beta, double y[], int incy,
double alpha, double x[], int incx )
{
char fortranUplo = 'U';
int n = mStorage->n;
dsymv_( &fortranUplo, &n, &alpha, &mStorage->M[0][0], &n,
x, &incx, &beta, y, &incy );
}
void dsymv(const UPLO Uplo,
const int N,
const double alpha,
const double *A,
const int lda,
const double *X,
const int incX,
const double beta,
double *Y,
const int incY) {
dsymv_(UploChar[Uplo], &N, &alpha, A, &lda, X, &incX, &beta, Y, &incY);
}
int
f2c_dsymv(char* uplo, integer* N,
doublereal* alpha,
doublereal* A, integer* lda,
doublereal* X, integer* incX,
doublereal* beta,
doublereal* Y, integer* incY)
{
dsymv_(uplo, N, alpha, A, lda,
X, incX, beta, Y, incY);
return 0;
}
void DenseSymMatrix::mult ( double beta, OoqpVector& y_in,
double alpha, OoqpVector& x_in )
{
char fortranUplo = 'U';
int n = mStorage->n;
SimpleVector & y = (SimpleVector &) y_in;
SimpleVector & x = (SimpleVector &) x_in;
int incx = 1, incy = 1;
if( n != 0 ) {
dsymv_( &fortranUplo, &n, &alpha, &mStorage->M[0][0], &n,
&x[0], &incx, &beta, &y[0], &incy );
}
}
/* z = alpha * d * y(:,k) + beta * z, where d is dense matrix and y is dense general */
static void
mm_real_d_dot_yk (const bool trans, const double alpha, const mm_dense *d, const mm_dense *y, const int k, const double beta, mm_dense *z)
{
double *yk = y->data + k * y->m;
double *zk = z->data + k * z->m;
if (!mm_real_is_symmetric (d)) {
// z = alpha * d * y + beta * z
dgemv_ ((trans) ? "T" : "N", &d->m, &d->n, &alpha, d->data, &d->m, yk, &ione, &beta, zk, &ione);
} else {
char uplo = (mm_real_is_upper (d)) ? 'U' : 'L';
// z = alpha * d * y + beta * z
dsymv_ (&uplo, &d->m, &alpha, d->data, &d->m, yk, &ione, &beta, zk, &ione);
}
return;
}
/*! dsymatrix*dcovector operator */
inline _dcovector operator*(const dsymatrix& mat, const dcovector& vec)
{VERBOSE_REPORT;
#ifdef CPPL_DEBUG
if(mat.n!=vec.l){
ERROR_REPORT;
std::cerr << "These matrix and vector can not make a product." << std::endl
<< "Your input was (" << mat.n << "x" << mat.n << ") * (" << vec.l << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
dcovector newvec(mat.n);
dsymv_( 'l', mat.n, 1.0, mat.array, mat.n, vec.array, 1, 0.0, newvec.array, 1 );
return _(newvec);
}
/**
* Matrix vector product with MomHamiltonian: y = ham*x + alpha*y
* @param x the input vector
* @param y the output vector
* @param alpha the scaling value
*/
void MomHamiltonian::mvprod(double *x, double *y, double alpha) const
{
double beta = 1;
int incx = 1;
char uplo = 'U';
int offset = 0;
for(int B=0; B<L; B++)
{
int dim = mombase[B].size();
dsymv_(&uplo,&dim,&beta,blockmat[B].get(),&dim,&x[offset],&incx,&alpha,&y[offset],&incx);
offset += dim;
}
}
/* Subroutine */ int dsytd2_(char* uplo, integer* n, doublereal* a, integer *
lda, doublereal* d__, doublereal* e, doublereal* tau, integer* info) {
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern doublereal ddot_(integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal taui;
extern /* Subroutine */ int dsyr2_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal alpha;
extern logical lsame_(char*, char*);
extern /* Subroutine */ int daxpy_(integer*, doublereal*, doublereal*,
integer*, doublereal*, integer*);
logical upper;
extern /* Subroutine */ int dsymv_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
doublereal*, integer*), dlarfg_(integer*, doublereal*,
doublereal*, integer*, doublereal*), xerbla_(char*, integer *
);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the orthogonal matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* D (output) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
/* A(1:i-1,i+1), and tau in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
/* and tau in TAU(i). */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( d e v2 v3 v4 ) ( d ) */
/* ( d e v3 v4 ) ( e d ) */
/* ( d e v4 ) ( v1 e d ) */
/* ( d e ) ( v1 v2 e d ) */
/* ( d ) ( v1 v2 v3 e d ) */
/* where d and e denote diagonal and off-diagonal elements of T, and vi */
/* denotes an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1
+ 1], &c__1, &taui);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
* a_dim1 + 1], &c__1);
daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1,
&tau[1], &c__1, &a[a_offset], lda);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
}
d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
tau[i__] = taui;
/* L10: */
}
d__[1] = a[a_dim1 + 1];
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &taui);
e[i__] = a[i__ + 1 + i__ * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
&tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda);
a[i__ + 1 + i__ * a_dim1] = e[i__];
}
d__[i__] = a[i__ + i__ * a_dim1];
tau[i__] = taui;
/* L20: */
}
d__[*n] = a[*n + *n * a_dim1];
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
double dummy = 0, beta [2], *px, *C, *Ct, *C2, *fil, *Zt, *zt, done=1.0, *zz, dzero=0.0;
cholmod_sparse Amatrix, *A, *Lsparse ;
cholmod_factor *L ;
cholmod_common Common, *cm ;
Int minor, *It2, *Jt2 ;
mwIndex l, k2, h, k, i, j, ik, *I, *J, *Jt, *It, *I2, *J2, lfi, *w, *w2, *r;
mwSize nnz, nnzlow, m, n;
int nz = 0;
mwSignedIndex one=1, lfi_si;
mxArray *Am, *Bm;
char *uplo="L", *trans="N";
/* ---------------------------------------------------------------------- */
/* Only one input. We have to find first the Cholesky factorization. */
/* start CHOLMOD and set parameters */
/* ---------------------------------------------------------------------- */
if (nargin == 1) {
cm = &Common ;
cholmod_l_start (cm) ;
sputil_config (SPUMONI, cm) ;
/* convert to packed LDL' when done */
cm->final_asis = FALSE ;
cm->final_super = FALSE ;
cm->final_ll = FALSE ;
cm->final_pack = TRUE ;
cm->final_monotonic = TRUE ;
/* since numerically zero entries are NOT dropped from the symbolic
* pattern, we DO need to drop entries that result from supernodal
* amalgamation. */
cm->final_resymbol = TRUE ;
cm->quick_return_if_not_posdef = (nargout < 2) ;
}
/* This will disable the supernodal LL', which will be slow. */
/* cm->supernodal = CHOLMOD_SIMPLICIAL ; */
/* ---------------------------------------------------------------------- */
/* get inputs */
/* ---------------------------------------------------------------------- */
if (nargin > 3)
{
mexErrMsgTxt ("usage: Z = sinv(A), or Z = sinv(LD, 1)") ;
}
n = mxGetM (pargin [0]) ;
m = mxGetM (pargin [0]) ;
if (!mxIsSparse (pargin [0]))
{
mexErrMsgTxt ("A must be sparse") ;
}
if (n != mxGetN (pargin [0]))
{
mexErrMsgTxt ("A must be square") ;
}
/* Only one input. We have to find first the Cholesky factorization. */
if (nargin == 1) {
/* get sparse matrix A, use tril(A) */
A = sputil_get_sparse (pargin [0], &Amatrix, &dummy, -1) ;
A->stype = -1 ; /* use lower part of A */
beta [0] = 0 ;
beta [1] = 0 ;
/* ---------------------------------------------------------------------- */
/* analyze and factorize */
/* ---------------------------------------------------------------------- */
L = cholmod_l_analyze (A, cm) ;
cholmod_l_factorize_p (A, beta, NULL, 0, L, cm) ;
if (cm->status != CHOLMOD_OK)
{
mexErrMsgTxt ("matrix is not positive definite") ;
}
/* ---------------------------------------------------------------------- */
/* convert L to a sparse matrix */
/* ---------------------------------------------------------------------- */
Lsparse = cholmod_l_factor_to_sparse (L, cm) ;
if (Lsparse->xtype == CHOLMOD_COMPLEX)
{
mexErrMsgTxt ("matrix is complex") ;
}
/* ---------------------------------------------------------------------- */
/* Set the sparse Cholesky factorization in Matlab format */
/* ---------------------------------------------------------------------- */
/*Am = sputil_put_sparse (&Lsparse, cm) ;
I = mxGetIr(Am);
J = mxGetJc(Am);
C = mxGetPr(Am);
nnz = mxGetNzmax(Am); */
It2 = Lsparse->i;
Jt2 = Lsparse->p;
Ct = Lsparse->x;
nnz = (mwSize) Lsparse->nzmax;
Am = mxCreateSparse(m, m, nnz, mxREAL) ;
I = mxGetIr(Am);
J = mxGetJc(Am);
C = mxGetPr(Am);
for (j = 0 ; j < n+1 ; j++) J[j] = (mwIndex) Jt2[j];
for ( i = 0 ; i < nnz ; i++) {
I[i] = (mwIndex) It2[i];
C[i] = Ct[i];
}
cholmod_l_free_sparse (&Lsparse, cm) ;
/*FILE *out1 = fopen( "output1.txt", "w" );
if( out1 != NULL )
fprintf( out1, "Hello %d\n", nnz );
fclose (out1);*/
} else {
/* The cholesky factorization is given as an input. */
/* We have to copy it into workspace */
It = mxGetIr(pargin [0]);
Jt = mxGetJc(pargin [0]);
Ct = mxGetPr(pargin [0]);
nnz = mxGetNzmax(pargin [0]);
Am = mxCreateSparse(m, m, nnz, mxREAL) ;
I = mxGetIr(Am);
J = mxGetJc(Am);
C = mxGetPr(Am);
for (j = 0 ; j < n+1 ; j++) J[j] = Jt[j];
for ( i = 0 ; i < nnz ; i++) {
I[i] = It[i];
C[i] = Ct[i];
}
}
/* Evaluate the sparse inverse */
C[nnz-1] = 1.0/C[J[m-1]]; /* set the last element of sparse inverse */
fil = mxCalloc((mwSize)1,sizeof(double));
zt = mxCalloc((mwSize)1,sizeof(double));
Zt = mxCalloc((mwSize)1,sizeof(double));
zz = mxCalloc((mwSize)1,sizeof(double));
for (j=m-2;j!=-1;j--){
lfi = J[j+1]-(J[j]+1);
/* if (lfi > 0) */
if ( J[j+1] > (J[j]+1) )
{
/* printf("lfi = %u \n ", lfi);
printf("lfi*double = %u \n", (mwSize)lfi*sizeof(double));
printf("lfi*lfi*double = %u \n", (mwSize)lfi*(mwSize)lfi*sizeof(double));
printf("\n \n");
*/
fil = mxRealloc(fil,(mwSize)lfi*sizeof(double));
for (i=0;i<lfi;i++) fil[i] = C[J[j]+i+1]; /* take the j'th lower triangular column of the Cholesky */
zt = mxRealloc(zt,(mwSize)lfi*sizeof(double)); /* memory for the sparse inverse elements to be evaluated */
Zt = mxRealloc(Zt,(mwSize)lfi*(mwSize)lfi*sizeof(double)); /* memory for the needed sparse inverse elements */
/* Set the lower triangular for Zt */
k2 = 0;
for (k=J[j]+1;k<J[j+1];k++){
ik = I[k];
h = k2;
for (l=J[ik];l<=J[ik+1];l++){
if (I[l] == I[ J[j]+h+1 ]){
Zt[h+lfi*k2] = C[l];
h++;
}
}
k2++;
}
/* evaluate zt = fil*Zt */
lfi_si = (mwSignedIndex) lfi;
dsymv_(uplo, &lfi_si, &done, Zt, &lfi_si, fil, &one, &dzero, zt, &one);
/* Set the evaluated sparse inverse elements, zt, into C */
k=lfi-1;
for (i = J[j+1]-1; i!=J[j] ; i--){
C[i] = -zt[k];
k--;
}
/* evaluate the j'th diagonal of sparse inverse */
dgemv_(trans, &one, &lfi_si, &done, fil, &one, zt, &one, &dzero, zz, &one);
C[J[j]] = 1.0/C[J[j]] + zz[0];
}
else
{
/* evaluate the j'th diagonal of sparse inverse */
C[J[j]] = 1.0/C[J[j]];
}
}
/* Free the temporary variables */
mxFree(fil);
mxFree(zt);
mxFree(Zt);
mxFree(zz);
/* ---------------------------------------------------------------------- */
/* Permute the elements according to r(q) = 1:n */
/* Done only if the Cholesky was evaluated here */
/* ---------------------------------------------------------------------- */
if (nargin == 1) {
Bm = mxCreateSparse(m, m, nnz, mxREAL) ;
It = mxGetIr(Bm);
Jt = mxGetJc(Bm);
Ct = mxGetPr(Bm); /* Ct = C(r,r) */
r = (mwIndex *) L->Perm; /* fill reducing ordering */
w = mxCalloc(m,sizeof(mwIndex)); /* column counts of Am */
/* count entries in each column of Bm */
for (j=0; j<m; j++){
k = r ? r[j] : j ; /* column j of Bm is column k of Am */
for (l=J[j] ; l<J[j+1] ; l++){
i = I[l];
ik = r ? r[i] : i ; /* row i of Bm is row ik of Am */
w[ max(ik,k) ]++;
}
}
cumsum2(Jt, w, m);
for (j=0; j<m; j++){
k = r ? r[j] : j ; /* column j of Bm is column k of Am */
for (l=J[j] ; l<J[j+1] ; l++){
i= I[l];
ik = r ? r[i] : i ; /* row i of Bm is row ik of Am */
It [k2 = w[max(ik,k)]++ ] = min(ik,k);
Ct[k2] = C[l];
}
}
mxFree(w);
/* ---------------------------------------------------------------------- */
/* Transpose the permuted (upper triangular) matrix Bm into Am */
/* (this way we get sorted columns) */
/* ---------------------------------------------------------------------- */
w = mxCalloc(m,sizeof(mwIndex));
for (i=0 ; i<Jt[m] ; i++) w[It[i]]++; /* row counts of Bm */
cumsum2(J, w, m); /* row pointers */
for (j=0 ; j<m ; j++){
for (i=Jt[j] ; i<Jt[j+1] ; i++){
I[ l=w[ It[i] ]++ ] = j;
C[l] = Ct[i];
}
}
mxFree(w);
mxDestroyArray(Bm);
}
/* ---------------------------------------------------------------------- */
/* Fill the upper triangle of the sparse inverse */
/* ---------------------------------------------------------------------- */
w = mxCalloc(m,sizeof(mwIndex)); /* workspace */
w2 = mxCalloc(m,sizeof(mwIndex)); /* workspace */
for (k=0;k<J[m];k++) w[I[k]]++; /* row counts of the lower triangular */
for (k=0;k<m;k++) w2[k] = w[k] + J[k+1] - J[k] - 1; /* column counts of the sparse inverse */
nnz = (mwSize)2*nnz - m; /* The number of nonzeros in Z */
pargout[0] = mxCreateSparse(m,m,nnz,mxREAL); /* The sparse matrix */
It = mxGetIr(pargout[0]);
Jt = mxGetJc(pargout[0]);
Ct = mxGetPr(pargout[0]);
cumsum2(Jt, w2, m); /* column starting points */
for (j = 0 ; j < m ; j++){ /* fill the upper triangular */
for (k = J[j] ; k < J[j+1] ; k++){
It[l = w2[ I[k]]++] = j ; /* place C(i,j) as entry Ct(j,i) */
if (Ct) Ct[l] = C[k] ;
}
}
for (j = 0 ; j < m ; j++){ /* fill the lower triangular */
for (k = J[j]+1 ; k < J[j+1] ; k++){
It[l = w2[j]++] = I[k] ; /* place C(j,i) as entry Ct(j,i) */
if (Ct) Ct[l] = C[k] ;
}
}
mxFree(w2);
mxFree(w);
/* ---------------------------------------------------------------------- */
/* return to MATLAB */
/* ---------------------------------------------------------------------- */
/* ---------------------------------------------------------------------- */
/* free workspace and the CHOLMOD L, except for what is copied to MATLAB */
/* ---------------------------------------------------------------------- */
if (nargin == 1) {
cholmod_l_free_factor (&L, cm) ;
cholmod_l_finish (cm) ;
cholmod_l_print_common (" ", cm) ;
}
mxDestroyArray(Am);
}
/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d,
doublereal *a, integer *lda, integer *iseed, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *), dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, j;
static doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dsymv_(char *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal wa, wb, wn;
extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
integer *, integer *, integer *, doublereal *);
static doublereal tau;
/* -- LAPACK auxiliary test routine (version 2.0)
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLAGSY generates a real symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random orthogonal matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
orthogonal transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[i + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
a[i + i * a_dim1] = d[i];
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
dsymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b12, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__1 = *n - i + 1;
alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], &
c__1);
i__1 = *n - i + 1;
daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1,
&a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = dnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
wa = d_sign(&wn, &a[*k + i + i * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[*k + i + i * a_dim1] + wa;
i__2 = *n - *k - i;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[*k + i + 1 + i * a_dim1], &c__1);
a[*k + i + i * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i + (i + 1) *
a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b12, &work[1]
, &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &a[*k + i + i * a_dim1], &c__1, &work[1], &
c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
dsymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b12, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__2 = *n - *k - i + 1;
alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i + i *
a_dim1], &c__1);
i__2 = *n - *k - i + 1;
daxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
dsyr2_("Lower", &i__2, &c_b19, &a[*k + i + i * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
a[*k + i + i * a_dim1] = -wa;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
a[j + i * a_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[j + i * a_dim1] = a[i + j * a_dim1];
/* L70: */
}
/* L80: */
}
return 0;
/* End of DLAGSY */
} /* dlagsy_ */
/* Subroutine */ int dla_syrfsx_extended__(integer *prec_type__, char *uplo,
integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *
af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c__,
doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *
berr_out__, integer *n_norms__, doublereal *err_bnds_norm__,
doublereal *err_bnds_comp__, doublereal *res, doublereal *ayb,
doublereal *dy, doublereal *y_tail__, doublereal *rcond, integer *
ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
ignore_cwise__, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Local variables */
doublereal dxratmax, dzratmax;
integer i__, j;
logical incr_prec__;
extern /* Subroutine */ int dla_syamv__(integer *, integer *, doublereal *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
doublereal prev_dz_z__, yk, final_dx_x__;
extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
doublereal *, doublereal *);
doublereal final_dz_z__, prevnormdx;
integer cnt;
doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
, doublereal *, doublereal *, doublereal *);
doublereal ymin;
integer y_prec_state__;
extern /* Subroutine */ int blas_dsymv_x__(integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer uplo2;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int blas_dsymv2_x__(integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *
);
doublereal dxrat, dzrat;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dsymv_(char *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal normx, normy;
extern doublereal dlamch_(char *);
doublereal normdx;
extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
doublereal hugeval;
extern integer ilauplo_(char *);
integer x_state__, z_state__;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLA_SYRFSX_EXTENDED improves the computed solution to a system of */
/* linear equations by performing extra-precise iterative refinement */
/* and provides error bounds and backward error estimates for the solution. */
/* This subroutine is called by DSYRFSX to perform iterative refinement. */
/* In addition to normwise error bound, the code provides maximum */
/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
/* subroutine is only resonsible for setting the second fields of */
/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
/* Arguments */
/* ========= */
/* PREC_TYPE (input) INTEGER */
/* Specifies the intermediate precision to be used in refinement. */
/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
/* P = 'S': Single */
/* = 'D': Double */
/* = 'I': Indigenous */
/* = 'X', 'E': Extra */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right-hand-sides, i.e., the number of columns of the */
/* matrix B. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by DSYTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* COLEQU (input) LOGICAL */
/* If .TRUE. then column equilibration was done to A before calling */
/* this routine. This is needed to compute the solution and error */
/* bounds correctly. */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If COLEQU = .FALSE., C */
/* is not accessed. If C is input, each element of C should be a power */
/* of the radix to ensure a reliable solution and error estimates. */
/* Scaling by powers of the radix does not cause rounding errors unless */
/* the result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right-hand-side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Y (input/output) DOUBLE PRECISION array, dimension */
/* (LDY,NRHS) */
/* On entry, the solution matrix X, as computed by DSYTRS. */
/* On exit, the improved solution matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
/* On exit, BERR_OUT(j) contains the componentwise relative backward */
/* error for right-hand-side j from the formula */
/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. This is computed by DLA_LIN_BERR. */
/* N_NORMS (input) INTEGER */
/* Determines which error bounds to return (see ERR_BNDS_NORM */
/* and ERR_BNDS_COMP). */
/* If N_NORMS >= 1 return normwise error bounds. */
/* If N_NORMS >= 2 return componentwise error bounds. */
/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* RES (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the intermediate residual. */
/* AYB (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace. This can be the same workspace passed for Y_TAIL. */
/* DY (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the intermediate solution. */
/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the trailing bits of the intermediate solution. */
/* RCOND (input) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* ITHRESH (input) INTEGER */
/* The maximum number of residual computations allowed for */
/* refinement. The default is 10. For 'aggressive' set to 100 to */
/* permit convergence using approximate factorizations or */
/* factorizations other than LU. If the factorization uses a */
/* technique other than Gaussian elimination, the guarantees in */
/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
/* RTHRESH (input) DOUBLE PRECISION */
/* Determines when to stop refinement if the error estimate stops */
/* decreasing. Refinement will stop when the next solution no longer */
/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
/* for more details. */
/* DZ_UB (input) DOUBLE PRECISION */
/* Determines when to start considering componentwise convergence. */
/* Componentwise convergence is only considered after each component */
/* of the solution Y is stable, which we definte as the relative */
/* change in each component being less than DZ_UB. The default value */
/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
/* more details. */
/* IGNORE_CWISE (input) LOGICAL */
/* If .TRUE. then ignore componentwise convergence. Default value */
/* is .FALSE.. */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* < 0: if INFO = -i, the ith argument to DSYTRS had an illegal */
/* value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
if (*info != 0) {
return 0;
}
eps = dlamch_("Epsilon");
hugeval = dlamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (doublereal) (*n) * eps;
if (lsame_(uplo, "L")) {
uplo2 = ilauplo_("L");
} else {
uplo2 = ilauplo_("U");
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
y_prec_state__ = 1;
if (y_prec_state__ == 2) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
y_tail__[i__] = 0.;
}
}
dxrat = 0.;
dxratmax = 0.;
dzrat = 0.;
dzratmax = 0.;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1; cnt <= i__2; ++cnt) {
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0) {
dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b11, &res[1], &c__1);
} else if (y_prec_state__ == 1) {
blas_dsymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1,
prec_type__);
} else {
blas_dsymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], &
c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.;
normy = 0.;
normdx = 0.;
dz_z__ = 0.;
ymin = hugeval;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
dyk = (d__1 = dy[i__], abs(d__1));
if (yk != 0.) {
/* Computing MAX */
d__1 = dz_z__, d__2 = dyk / yk;
dz_z__ = max(d__1,d__2);
} else if (dyk != 0.) {
dz_z__ = hugeval;
}
ymin = min(ymin,yk);
normy = max(normy,yk);
if (*colequ) {
/* Computing MAX */
d__1 = normx, d__2 = yk * c__[i__];
normx = max(d__1,d__2);
/* Computing MAX */
d__1 = normdx, d__2 = dyk * c__[i__];
normdx = max(d__1,d__2);
} else {
normx = normy;
normdx = max(normdx,dyk);
}
}
if (normx != 0.) {
dx_x__ = normdx / normx;
} else if (normdx == 0.) {
dx_x__ = 0.;
} else {
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria. */
if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh) {
x_state__ = 1;
}
if (x_state__ == 1) {
if (dx_x__ <= eps) {
x_state__ = 2;
} else if (dxrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
x_state__ = 3;
}
} else {
if (dxrat > dxratmax) {
dxratmax = dxrat;
}
}
if (x_state__ > 1) {
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh) {
z_state__ = 1;
}
if (z_state__ == 1) {
if (dz_z__ <= eps) {
z_state__ = 2;
} else if (dz_z__ > *dz_ub__) {
z_state__ = 0;
dzratmax = 0.;
final_dz_z__ = hugeval;
} else if (dzrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
z_state__ = 3;
}
} else {
if (dzrat > dzratmax) {
dzratmax = dzrat;
}
}
if (z_state__ > 1) {
final_dz_z__ = dz_z__;
}
}
if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
goto L666;
}
if (incr_prec__) {
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
y_tail__[i__] = 0.;
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2) {
daxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
} else {
dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
L666:
/* Set final_* when cnt hits ithresh. */
if (x_state__ == 1) {
final_dx_x__ = dx_x__;
}
if (z_state__ == 1) {
final_dz_z__ = dz_z__;
}
/* Compute error bounds. */
if (*n_norms__ >= 1) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
1 - dxratmax);
}
if (*n_norms__ >= 2) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &
c_b11, &res[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
}
/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
dla_syamv__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b11, &ayb[1], &c__1);
dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
} /* dla_syrfsx_extended__ */
/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, doublereal *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DSYTRI computes the inverse of a real symmetric indefinite matrix
A using the factorization A = U*D*U**T or A = L*D*L**T computed by
DSYTRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**T;
= 'L': Lower triangular, form is A = L*D*L**T.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by DSYTRF.
On exit, if INFO = 0, the (symmetric) inverse of the original
matrix. If UPLO = 'U', the upper triangular part of the
inverse is formed and the part of A below the diagonal is not
referenced; if UPLO = 'L' the lower triangular part of the
inverse is formed and the part of A above the diagonal is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSYTRF.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b11 = -1.;
static doublereal c_b13 = 0.;
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal temp, akkp1, d__;
static integer k;
static doublereal t;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static doublereal ak;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal akp1;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && a_ref(*info, *info) == 0.) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && a_ref(*info, *info) == 0.) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
a_ref(k, k) = 1. / a_ref(k, k);
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(1, k), &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (d__1 = a_ref(k, k + 1), abs(d__1));
ak = a_ref(k, k) / t;
akp1 = a_ref(k + 1, k + 1) / t;
akkp1 = a_ref(k, k + 1) / t;
d__ = t * (ak * akp1 - 1.);
a_ref(k, k) = akp1 / d__;
a_ref(k + 1, k + 1) = ak / d__;
a_ref(k, k + 1) = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k + 1) = a_ref(k, k + 1) - ddot_(&i__1, &a_ref(1, k),
&c__1, &a_ref(1, k + 1), &c__1);
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k + 1), &c__1);
i__1 = k - 1;
a_ref(k + 1, k + 1) = a_ref(k + 1, k + 1) - ddot_(&i__1, &
work[1], &c__1, &a_ref(1, k + 1), &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
dswap_(&i__1, &a_ref(1, k), &c__1, &a_ref(1, kp), &c__1);
i__1 = k - kp - 1;
dswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda);
temp = a_ref(k, k);
a_ref(k, k) = a_ref(kp, kp);
a_ref(kp, kp) = temp;
if (kstep == 2) {
temp = a_ref(k, k + 1);
a_ref(k, k + 1) = a_ref(kp, k + 1);
a_ref(kp, k + 1) = temp;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
a_ref(k, k) = 1. / a_ref(k, k);
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k), &c__1)
;
i__1 = *n - k;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(k + 1, k), &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (d__1 = a_ref(k, k - 1), abs(d__1));
ak = a_ref(k - 1, k - 1) / t;
akp1 = a_ref(k, k) / t;
akkp1 = a_ref(k, k - 1) / t;
d__ = t * (ak * akp1 - 1.);
a_ref(k - 1, k - 1) = akp1 / d__;
a_ref(k, k) = ak / d__;
a_ref(k, k - 1) = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k), &c__1)
;
i__1 = *n - k;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(k + 1, k), &c__1);
i__1 = *n - k;
a_ref(k, k - 1) = a_ref(k, k - 1) - ddot_(&i__1, &a_ref(k + 1,
k), &c__1, &a_ref(k + 1, k - 1), &c__1);
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k - 1), &c__1);
i__1 = *n - k;
a_ref(k - 1, k - 1) = a_ref(k - 1, k - 1) - ddot_(&i__1, &
work[1], &c__1, &a_ref(k + 1, k - 1), &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), &
c__1);
}
i__1 = kp - k - 1;
dswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda);
temp = a_ref(k, k);
a_ref(k, k) = a_ref(kp, kp);
a_ref(kp, kp) = temp;
if (kstep == 2) {
temp = a_ref(k, k - 1);
a_ref(k, k - 1) = a_ref(kp, k - 1);
a_ref(kp, k - 1) = temp;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of DSYTRI */
} /* dsytri_ */
/* Subroutine */
int dsytd2_fla(char *uplo, integer *n, doublereal *a, integer * lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal taui;
extern /* Subroutine */
int dsyr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer * );
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A */
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x**T * v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1], &c__1);
daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ 1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1, &a[a_offset], lda);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
}
d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
tau[i__] = taui;
/* L10: */
}
d__[1] = a[a_dim1 + 1];
}
else
{
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * a_dim1], &c__1, &taui);
e[i__] = a[i__ + 1 + i__ * a_dim1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ i__], &c__1);
/* Compute w := x - 1/2 * tau * (x**T * v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
a[i__ + 1 + i__ * a_dim1] = e[i__];
}
d__[i__] = a[i__ + i__ * a_dim1];
tau[i__] = taui;
/* L20: */
}
d__[*n] = a[*n + *n * a_dim1];
}
return 0;
/* End of DSYTD2 */
}
/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
integer count;
logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlacn2_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric indefinite, and */
/* provides error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The factored form of the matrix A. AF contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**T or */
/* A = L*D*L**T as computed by DSYTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by DSYTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1,
&c_b14, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x[k + j * x_dim1], abs(d__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
i__ + j * x_dim1], abs(d__2));
/* L40: */
}
work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) *
xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x[k + j * x_dim1], abs(d__1));
work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
i__ + j * x_dim1], abs(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
i__];
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
/ (work[i__] + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ 1], n, info);
daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
*n + 1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DSYRFS */
} /* dsyrfs_ */
void
dsymv(char uplo, int n, double alpha, double *a, int lda, double *x, int incx, double beta, double *y, int incy)
{
dsymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
}
/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
form T by an orthogonal similarity transformation: Q' * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the orthogonal
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, and the elements below the first subdiagonal, with
the array TAU, represent the orthogonal matrix Q as a product
of elementary reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
A(1:i-1,i+1), and tau in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
and tau in TAU(i).
The contents of A on exit are illustrated by the following examples
with n = 5:
if UPLO = 'U': if UPLO = 'L':
( d e v2 v3 v4 ) ( d )
( d e v3 v4 ) ( e d )
( d e v4 ) ( v1 e d )
( d e ) ( v1 v2 e d )
( d ) ( v1 v2 v3 e d )
where d and e denote diagonal and off-diagonal elements of T, and vi
denotes an element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 0.;
static doublereal c_b14 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal taui;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *
);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
taui);
e[i__] = a_ref(i__, i__ + 1);
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a_ref(i__, i__ + 1) = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ +
1), &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a_ref(1,
i__ + 1), &c__1);
daxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
&c__1, &a[a_offset], lda);
a_ref(i__, i__ + 1) = e[i__];
}
d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
tau[i__] = taui;
/* L10: */
}
d__[1] = a_ref(1, 1);
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__), &
c__1, &taui);
e[i__] = a_ref(i__ + 1, i__);
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a_ref(i__ + 1, i__) = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a_ref(
i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__],
&c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
;
a_ref(i__ + 1, i__) = e[i__];
}
d__[i__] = a_ref(i__, i__);
tau[i__] = taui;
/* L20: */
}
d__[*n] = a_ref(*n, *n);
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, iw;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATRD reduces NB rows and columns of a real symmetric matrix A to */
/* symmetric tridiagonal form by an orthogonal similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by DSYTRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit: */
/* if UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= (1,N). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) DOUBLE PRECISION array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= max(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a symmetric rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b6, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b6, &a[i__ * a_dim1 + 1], &c__1);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1;
dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
1], &c__1, &tau[i__ - 1]);
e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
a[i__ - 1 + i__ * a_dim1] = 1.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], &
c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1],
&c__1, &a[i__ * a_dim1 + 1], &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], &
c__1);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+
i__ * a_dim1], &c__1, &tau[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
dsymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1],
ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ *
w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLATRD */
} /* dlatrd_ */
/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
doublereal d__;
integer k;
doublereal t, ak;
integer kp;
doublereal akp1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp, akkp1;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYTRI computes the inverse of a real symmetric indefinite matrix */
/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
/* DSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by DSYTRF. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix. If UPLO = 'U', the upper triangular part of the */
/* inverse is formed and the part of A below the diagonal is not */
/* referenced; if UPLO = 'L' the lower triangular part of the */
/* inverse is formed and the part of A above the diagonal is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1));
ak = a[k + k * a_dim1] / t;
akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
akkp1 = a[k + (k + 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k + k * a_dim1] = akp1 / d__;
a[k + 1 + (k + 1) * a_dim1] = ak / d__;
a[k + (k + 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], &
c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[(k + 1) * a_dim1 + 1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
c__1);
i__1 = k - kp - 1;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k + 1) * a_dim1];
a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
a[kp + (k + 1) * a_dim1] = temp;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1));
ak = a[k - 1 + (k - 1) * a_dim1] / t;
akp1 = a[k + k * a_dim1] / t;
akkp1 = a[k + (k - 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
a[k + k * a_dim1] = ak / d__;
a[k + (k - 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
i__1 = *n - k;
a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1]
, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
, &c__1);
i__1 = *n - k;
a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[k + 1 + (k - 1) * a_dim1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
a_dim1], &c__1);
}
i__1 = kp - k - 1;
dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k - 1) * a_dim1];
a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
a[kp + (k - 1) * a_dim1] = temp;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of DSYTRI */
} /* dsytri_ */
void dcauchy(int n, double *x, double *xl, double *xu, double *A, double *g, double delta, double *alpha, double *s)
{
/*
c **********
c
c Subroutine dcauchy
c
c This subroutine computes a Cauchy step that satisfies a trust
c region constraint and a sufficient decrease condition.
c
c The Cauchy step is computed for the quadratic
c
c q(s) = 0.5*s'*A*s + g'*s,
c
c where A is a symmetric matrix , and g is a vector. Given a
c parameter alpha, the Cauchy step is
c
c s[alpha] = P[x - alpha*g] - x,
c
c with P the projection onto the n-dimensional interval [xl,xu].
c The Cauchy step satisfies the trust region constraint and the
c sufficient decrease condition
c
c || s || <= delta, q(s) <= mu_0*(g'*s),
c
c where mu_0 is a constant in (0,1).
c
c parameters:
c
c n is an integer variable.
c On entry n is the number of variables.
c On exit n is unchanged.
c
c x is a double precision array of dimension n.
c On entry x specifies the vector x.
c On exit x is unchanged.
c
c xl is a double precision array of dimension n.
c On entry xl is the vector of lower bounds.
c On exit xl is unchanged.
c
c xu is a double precision array of dimension n.
c On entry xu is the vector of upper bounds.
c On exit xu is unchanged.
c
c A is a double precision array of dimension n*n.
c On entry A specifies the matrix A.
c On exit A is unchanged.
c
c g is a double precision array of dimension n.
c On entry g specifies the gradient g.
c On exit g is unchanged.
c
c delta is a double precision variable.
c On entry delta is the trust region size.
c On exit delta is unchanged.
c
c alpha is a double precision variable.
c On entry alpha is the current estimate of the step.
c On exit alpha defines the Cauchy step s[alpha].
c
c s is a double precision array of dimension n.
c On entry s need not be specified.
c On exit s is the Cauchy step s[alpha].
c
c **********
*/
double one = 1, zero = 0;
/* Constant that defines sufficient decrease.
Interpolation and extrapolation factors. */
double mu0 = 0.01, interpf = 0.1, extrapf = 10;
int search, interp, nbrpt, nsteps = 1, i, inc = 1;
double alphas, brptmax, brptmin, gts, q;
double *wa = (double *) xmalloc(sizeof(double)*n);
/* Find the minimal and maximal break-point on x - alpha*g. */
for (i=0;i<n;i++)
wa[i] = -g[i];
dbreakpt(n, x, xl, xu, wa, &nbrpt, &brptmin, &brptmax);
/* Evaluate the initial alpha and decide if the algorithm
must interpolate or extrapolate. */
dgpstep(n, x, xl, xu, -(*alpha), g, s);
if (dnrm2_(&n, s, &inc) > delta)
interp = 1;
else
{
dsymv_("U", &n, &one, A, &n, s, &inc, &zero, wa, &inc);
gts = ddot_(&n, g, &inc, s, &inc);
q = 0.5*ddot_(&n, s, &inc, wa, &inc) + gts;
interp = q >= mu0*gts ? 1 : 0;
}
/* Either interpolate or extrapolate to find a successful step. */
if (interp)
{
/* Reduce alpha until a successful step is found. */
search = 1;
while (search)
{
/* This is a crude interpolation procedure that
will be replaced in future versions of the code. */
nsteps++;
(*alpha) *= interpf;
dgpstep(n, x, xl, xu, -(*alpha), g, s);
if (dnrm2_(&n, s, &inc) <= delta)
{
dsymv_("U", &n, &one, A, &n, s, &inc, &zero, wa, &inc);
gts = ddot_(&n, g, &inc, s, &inc);
q = 0.5*ddot_(&n, s, &inc, wa, &inc) + gts;
search = q > mu0*gts ? 1 : 0;
}
}
}
else
{
search = 1;
alphas = *alpha;
/* Increase alpha until a successful step is found. */
while (search && (*alpha) <= brptmax)
{
/* This is a crude extrapolation procedure that
will be replaced in future versions of the code. */
nsteps++;
alphas = *alpha;
(*alpha) *= extrapf;
dgpstep(n, x, xl, xu, -(*alpha), g, s);
if (dnrm2_(&n, s, &inc) <= delta)
{
dsymv_("U", &n, &one, A, &n, s, &inc, &zero, wa, &inc);
gts = ddot_(&n, g, &inc, s, &inc);
q = 0.5*ddot_(&n, s, &inc, wa, &inc) + gts;
search = q < mu0*gts ? 1 : 0;
}
else
search = 0;
}
*alpha = alphas;
dgpstep(n, x, xl, xu, -(*alpha), g, s);
}
free(wa);
}
/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DSYRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric indefinite, and
provides error bounds and backward error estimates for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The symmetric matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
The factored form of the matrix A. AF contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**T or
A = L*D*L**T as computed by DSYTRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSYTRF.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DSYTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b12 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal lstres;
extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static doublereal eps;
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
dcopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
dsymv_(uplo, n, &c_b12, &A(1,1), lda, &X(1,j), &c__1,
&c_b14, &WORK(*n + 1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L40: */
}
WORK(k) = WORK(k) + (d__1 = A(k,k), abs(d__1)) *
xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
WORK(k) += (d__1 = A(k,k), abs(d__1)) * xk;
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L60: */
}
WORK(k) += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = WORK(*n + i), abs(d__1)) / WORK(i);
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = WORK(*n + i), abs(d__1)) + safe1) /
(WORK(i) + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(*n
+ 1), n, info);
daxpy_(n, &c_b14, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
*n + 1), n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L120: */
}
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
*n + 1), n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = X(i,j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of DSYRFS */
} /* dsyrfs_ */
void dtrpcg(int n, double *A, double *g, double delta, double *L, double tol, double stol, double *w, int *iters, int *info)
{
/*
c *********
c
c Subroutine dtrpcg
c
c Given a dense symmetric positive semidefinite matrix A, this
c subroutine uses a preconditioned conjugate gradient method to find
c an approximate minimizer of the trust region subproblem
c
c min { q(s) : || L'*s || <= delta }.
c
c where q is the quadratic
c
c q(s) = 0.5*s'*A*s + g'*s,
c
c This subroutine generates the conjugate gradient iterates for
c the equivalent problem
c
c min { Q(w) : || w || <= delta }.
c
c where Q is the quadratic defined by
c
c Q(w) = q(s), w = L'*s.
c
c Termination occurs if the conjugate gradient iterates leave
c the trust region, a negative curvature direction is generated,
c or one of the following two convergence tests is satisfied.
c
c Convergence in the original variables:
c
c || grad q(s) || <= tol
c
c Convergence in the scaled variables:
c
c || grad Q(w) || <= stol
c
c Note that if w = L'*s, then L*grad Q(w) = grad q(s).
c
c parameters:
c
c n is an integer variable.
c On entry n is the number of variables.
c On exit n is unchanged.
c
c A is a double precision array of dimension n*n.
c On entry A specifies the matrix A.
c On exit A is unchanged.
c
c g is a double precision array of dimension n.
c On entry g must contain the vector g.
c On exit g is unchanged.
c
c delta is a double precision variable.
c On entry delta is the trust region size.
c On exit delta is unchanged.
c
c L is a double precision array of dimension n*n.
c On entry L need not to be specified.
c On exit the lower triangular part of L contains the matrix L.
c
c tol is a double precision variable.
c On entry tol specifies the convergence test
c in the un-scaled variables.
c On exit tol is unchanged
c
c stol is a double precision variable.
c On entry stol specifies the convergence test
c in the scaled variables.
c On exit stol is unchanged
c
c w is a double precision array of dimension n.
c On entry w need not be specified.
c On exit w contains the final conjugate gradient iterate.
c
c iters is an integer variable.
c On entry iters need not be specified.
c On exit iters is set to the number of conjugate
c gradient iterations.
c
c info is an integer variable.
c On entry info need not be specified.
c On exit info is set as follows:
c
c info = 1 Convergence in the original variables.
c || grad q(s) || <= tol
c
c info = 2 Convergence in the scaled variables.
c || grad Q(w) || <= stol
c
c info = 3 Negative curvature direction generated.
c In this case || w || = delta and a direction
c
c of negative curvature w can be recovered by
c solving L'*w = p.
c
c info = 4 Conjugate gradient iterates exit the
c trust region. In this case || w || = delta.
c
c info = 5 Failure to converge within itermax(n) iterations.
c
c **********
*/
int i, inc = 1;
double one = 1, zero = 0, alpha, malpha, beta, ptq, rho;
double *p, *q, *t, *r, *z, sigma, rtr, rnorm, rnorm0, tnorm;
p = (double *) xmalloc(sizeof(double)*n);
q = (double *) xmalloc(sizeof(double)*n);
t = (double *) xmalloc(sizeof(double)*n);
r = (double *) xmalloc(sizeof(double)*n);
z = (double *) xmalloc(sizeof(double)*n);
/* Initialize the iterate w and the residual r.
Initialize the residual t of grad q to -g.
Initialize the residual r of grad Q by solving L*r = -g.
Note that t = L*r. */
for (i=0;i<n;i++)
{
w[i] = 0;
r[i] = t[i] = -g[i];
}
dtrsv_("L", "N", "N", &n, L, &n, r, &inc);
/* Initialize the direction p. */
memcpy(p, r, sizeof(double)*n);
/* Initialize rho and the norms of r and t. */
rho = ddot_(&n, r, &inc, r, &inc);
rnorm0 = sqrt(rho);
/* Exit if g = 0. */
*iters = 0;
if (rnorm0 <= stol)
{
*info = 1;
goto return0;
}
for (*iters=1;*iters<=n;*iters++)
{
/* Compute z by solving L'*z = p. */
memcpy(z, p, sizeof(double)*n);
dtrsv_("L", "T", "N", &n, L, &n, z, &inc);
/* Compute q by solving L*q = A*z and save L*q for
use in updating the residual t. */
dsymv_("U", &n, &one, A, &n, z, &inc, &zero, q, &inc);
memcpy(z, q, sizeof(double)*n);
dtrsv_("L", "N", "N", &n, L, &n, q, &inc);
/* Compute alpha and determine sigma such that the trust region
constraint || w + sigma*p || = delta is satisfied. */
ptq = ddot_(&n, p, &inc, q, &inc);
if (ptq > 0)
alpha = rho/ptq;
else
alpha = 0;
dtrqsol(n, w, p, delta, &sigma);
/* Exit if there is negative curvature or if the
iterates exit the trust region. */
if (ptq <= 0 || alpha >= sigma)
{
daxpy_(&n, &sigma, p, &inc, w, &inc);
if (ptq <= 0)
*info = 3;
else
*info = 4;
goto return0;
}
/* Update w and the residuals r and t.
Note that t = L*r. */
malpha = -alpha;
daxpy_(&n, &alpha, p, &inc, w, &inc);
daxpy_(&n, &malpha, q, &inc, r, &inc);
daxpy_(&n, &malpha, z, &inc, t,&inc);
/* Exit if the residual convergence test is satisfied. */
rtr = ddot_(&n, r, &inc, r, &inc);
rnorm = sqrt(rtr);
tnorm = sqrt(ddot_(&n, t, &inc, t, &inc));
if (tnorm <= tol)
{
*info = 1;
goto return0;
}
if (rnorm <= stol)
{
*info = 2;
goto return0;
}
/* Compute p = r + beta*p and update rho. */
beta = rtr/rho;
dscal_(&n, &beta, p, &inc);
daxpy_(&n, &one, r, &inc, p, &inc);
rho = rtr;
}
/* iters > itermax = n */
*info = 5;
return0:
free(p);
free(q);
free(r);
free(t);
free(z);
}
/* Subroutine */ HYPRE_Int dlatrd_(const char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLATRD reduces NB rows and columns of a real symmetric matrix A to
symmetric tridiagonal form by an orthogonal similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by DSYTRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit:
if UPLO = 'U', the last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= (1,N).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) DOUBLE PRECISION array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(nb).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a symmetric rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublereal c_b5 = -1.;
static doublereal c_b6 = 1.;
static integer c__1 = 1;
static doublereal c_b16 = 0.;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern /* Subroutine */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *,const char *);
extern /* Subroutine */ HYPRE_Int dgemv_(const char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(const char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer iw;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define w_ref(a_1,a_2) w[(a_2)*w_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b6, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b6, &a_ref(1, i__),
&c__1);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = i__ - 1;
dlarfg_(&i__2, &a_ref(i__ - 1, i__), &a_ref(1, i__), &c__1, &
tau[i__ - 1]);
e[i__ - 1] = a_ref(i__ - 1, i__);
a_ref(i__ - 1, i__) = 1.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b16, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(1, iw + 1)
, ldw, &a_ref(1, i__), &c__1, &c_b16, &w_ref(i__
+ 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(1, i__ +
1), lda, &a_ref(1, i__), &c__1, &c_b16, &w_ref(
i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w_ref(1, iw), &
c__1, &a_ref(1, i__), &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b6, &a_ref(i__, i__), &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b6, &a_ref(i__, i__), &c__1);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__)
, &c__1, &tau[i__]);
e[i__] = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 1.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
dsymv_("Lower", &i__2, &c_b6, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(i__ + 1, 1),
ldw, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(i__ + 1, 1),
lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w_ref(i__ + 1, i__), &
c__1, &a_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLATRD */
} /* dlatrd_ */
/* Subroutine */
int dsyrfs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer * ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
integer count;
logical upper;
extern /* Subroutine */
int dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */
int dsytrs_(char *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldaf < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -10;
}
else if (*ldx < max(1,*n))
{
*info = -12;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
count = 1;
lstres = 3.;
L20: /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b14, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(A)*f2c_abs(X) + f2c_abs(B) )(i) ) */
/* where f2c_abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] = (d__1 = b[i__ + j * b_dim1], f2c_abs(d__1));
/* L30: */
}
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * xk;
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * (d__2 = x[ i__ + j * x_dim1], f2c_abs(d__2));
/* L40: */
}
work[k] = work[k] + (d__1 = a[k + k * a_dim1], f2c_abs(d__1)) * xk + s;
/* L50: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
work[k] += (d__1 = a[k + k * a_dim1], f2c_abs(d__1)) * xk;
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * xk;
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * (d__2 = x[ i__ + j * x_dim1], f2c_abs(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (work[i__] > safe2)
{
/* Computing MAX */
d__2 = s;
d__3 = (d__1 = work[*n + i__], f2c_abs(d__1)) / work[ i__]; // , expr subst
s = max(d__2,d__3);
}
else
{
/* Computing MAX */
d__2 = s;
d__3 = ((d__1 = work[*n + i__], f2c_abs(d__1)) + safe1) / (work[i__] + safe1); // , expr subst
s = max(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5)
{
/* Update solution and try again. */
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n + 1], n, info);
daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) ;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(A))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* f2c_abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of f2c_abs(R)+NZ*EPS*(f2c_abs(A)*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(A)*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (work[i__] > safe2)
{
work[i__] = (d__1 = work[*n + i__], f2c_abs(d__1)) + nz * eps * work[i__];
}
else
{
work[i__] = (d__1 = work[*n + i__], f2c_abs(d__1)) + nz * eps * work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(A**T). */
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ *n + 1], n, info);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
}
else if (kase == 2)
{
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ *n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
d__2 = lstres;
d__3 = (d__1 = x[i__ + j * x_dim1], f2c_abs(d__1)); // , expr subst
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.)
{
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DSYRFS */
}
