void Mjoin(Mjoin(PATL,trinvertU),UnitNM)(const int N, TYPE *A, const int lda)
{
int j;
register int i;
const int ione=1;
#ifdef UnitDiag_
#define DIAG "U"
#define Ajj -1.0
#else
#define DIAG "N"
TYPE Ajj;
const int ldap1 = lda + 1;
TYPE one=1.0;
#endif
TYPE *Ac=A;
if (N > 0)
{
for (j=0; j != N; j++)
{
#ifndef UnitDiag_
Ajj = one / Ac[j];
Ac[j] = Ajj;
Ajj = -Ajj;
#endif
#ifdef OldDtrmv
dtrmv_("U", "N", DIAG, &j, A, &lda, Ac, &ione);
for (i=0; i != j; i++) Ac[i] *= Ajj;
#else
ATL_trmv_scal(j, Ajj, A, lda, Ac);
#endif
Ac += lda;
}
}
}
int
f2c_dtrmv(char* uplo, char *trans, char* diag, integer *N,
doublereal *A, integer *lda,
doublereal *X, integer *incX)
{
dtrmv_(uplo, trans, diag,
N, A, lda, X, incX);
return 0;
}
void dtrmv(const UPLO Uplo,
const TRANSPOSE TransA,
const DIAG Diag,
const int N,
const double *A,
const int lda,
double *X,
const int incX) {
dtrmv_(UploChar[Uplo], TransposeChar[TransA], DiagChar[Diag],
&N, A, &lda, X, &incX);
}
void Mjoin(Mjoin(PATL,trinvertL),UnitNM)(const int N, TYPE *A, const int lda)
{
int j;
register int i;
const int ione=1;
const int ldap1=lda+1;
#ifdef UnitDiag_
#define DIAG "U"
#define Ajj -1.0
#else
#define DIAG "N"
register TYPE Ajj;
TYPE one=1.0;
#endif
TYPE *Ad = A + (N-1)*ldap1;
for (j=0; j != N; j++)
{
#ifndef UnitDiag_
Ajj = one / *Ad;
*Ad = Ajj;
Ajj = -Ajj;
#endif
#ifndef OldDtrmv
ATL_trmv_scal(j, Ajj, Ad+ldap1, lda, Ad+1);
#else
dtrmv_("L", "N", DIAG, &j, Ad+ldap1, &lda, Ad+1, &ione);
#ifdef UnitDiag_
for (i=1; i <= j; i++) Ad[i] = -Ad[i];
#else
for (i=1; i <= j; i++) Ad[i] *= Ajj;
#endif
#endif
Ad -= ldap1;
}
}
int dlarft_(char *direct, char *storev, int *n, int *
k, double *v, int *ldv, double *tau, double *t,
int *ldt)
{
/* System generated locals */
int t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
double d__1;
/* Local variables */
int i__, j, prevlastv;
double vii;
extern int lsame_(char *, char *);
extern int dgemv_(char *, int *, int *,
double *, double *, int *, double *, int *,
double *, double *, int *);
int lastv;
extern int dtrmv_(char *, char *, char *, int *,
double *, int *, double *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARFT forms the triangular factor T of a float block reflector H */
/* of order n, which is defined as a product of k elementary reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) DOUBLE PRECISION array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= MAX(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* ( v1 1 ) ( 1 v2 v2 v2 ) */
/* ( v1 v2 1 ) ( 1 v3 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* ( 1 v3 ) */
/* ( 1 ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
prevlastv = *n;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
prevlastv = MAX(i__,prevlastv);
if (tau[i__] == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.;
/* L10: */
}
} else {
/* general case */
vii = v[i__ + i__ * v_dim1];
v[i__ + i__ * v_dim1] = 1.;
if (lsame_(storev, "C")) {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[lastv + i__ * v_dim1] != 0.) {
break;
}
}
j = MIN(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
i__2 = j - i__ + 1;
i__3 = i__ - 1;
d__1 = -tau[i__];
dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1],
ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
i__ * t_dim1 + 1], &c__1);
} else {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[i__ + lastv * v_dim1] != 0.) {
break;
}
}
j = MIN(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
i__2 = i__ - 1;
i__3 = j - i__ + 1;
d__1 = -tau[i__];
dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b8, &t[i__ * t_dim1 + 1], &c__1);
}
v[i__ + i__ * v_dim1] = vii;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1) {
prevlastv = MAX(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
/* L20: */
}
} else {
prevlastv = 1;
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C")) {
vii = v[*n - *k + i__ + i__ * v_dim1];
v[*n - *k + i__ + i__ * v_dim1] = 1.;
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[lastv + i__ * v_dim1] != 0.) {
break;
}
}
j = MAX(lastv,prevlastv);
/* T(i+1:k,i) := */
/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
i__1 = *n - *k + i__ - j + 1;
i__2 = *k - i__;
d__1 = -tau[i__];
dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
c__1);
v[*n - *k + i__ + i__ * v_dim1] = vii;
} else {
vii = v[i__ + (*n - *k + i__) * v_dim1];
v[i__ + (*n - *k + i__) * v_dim1] = 1.;
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[i__ + lastv * v_dim1] != 0.) {
break;
}
}
j = MAX(lastv,prevlastv);
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
i__1 = *k - i__;
i__2 = *n - *k + i__ - j + 1;
d__1 = -tau[i__];
dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
v[i__ + (*n - *k + i__) * v_dim1] = vii;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1)
;
if (i__ > 1) {
prevlastv = MIN(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
t[i__ + i__ * t_dim1] = tau[i__];
}
/* L40: */
}
}
return 0;
/* End of DLARFT */
} /* dlarft_ */
/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *
a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
doublereal *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublereal d__1;
/* Local variables */
static integer i__;
static doublereal ei;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen), dcopy_(integer *, doublereal *,
integer *, doublereal *, integer *), daxpy_(integer *, doublereal
*, doublereal *, integer *, doublereal *, integer *), dtrmv_(char
*, char *, char *, integer *, doublereal *, integer *, doublereal
*, integer *, ftnlen, ftnlen, ftnlen), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
c__1, (ftnlen)12);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)9, (
ftnlen)4);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1, (ftnlen)9);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)9, (
ftnlen)8);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1, (ftnlen)12);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12,
(ftnlen)4);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(i) to annihilate */
/* A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3,*n) + i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ *
y_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1, (ftnlen)9);
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1, (
ftnlen)12);
dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
return 0;
/* End of DLAHRD */
} /* dlahrd_ */
int dlahr2_(int *n, int *k, int *nb, double *
a, int *lda, double *tau, double *t, int *ldt,
double *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
double d__1;
/* Local variables */
int i__;
double ei;
extern int dscal_(int *, double *, double *,
int *), dgemm_(char *, char *, int *, int *, int *
, double *, double *, int *, double *, int *,
double *, double *, int *), dgemv_(
char *, int *, int *, double *, double *, int
*, double *, int *, double *, double *, int *), dcopy_(int *, double *, int *, double *,
int *), dtrmm_(char *, char *, char *, char *, int *,
int *, double *, double *, int *, double *,
int *), daxpy_(int *,
double *, double *, int *, double *, int *),
dtrmv_(char *, char *, char *, int *, double *, int *,
double *, int *), dlarfg_(
int *, double *, double *, int *, double *),
dlacpy_(char *, int *, int *, double *, int *,
double *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHR2 reduces the first NB columns of A float general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb 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 float scalar, and v is a float vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's DLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
i__ * a_dim1], &c__1);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[MIN(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
/* Compute Y(1:K,1:NB) */
dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
&y[y_offset], ldy);
}
dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of DLAHR2 */
} /* dlahr2_ */
/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, integer *info, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer j;
static doublereal ajj;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
static logical nounit;
/* -- LAPACK ROUTINE (VERSION 1.0B) -- */
/* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., */
/* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY */
/* FEBRUARY 29, 1992 */
/* .. SCALAR ARGUMENTS .. */
/* .. */
/* .. ARRAY ARGUMENTS .. */
/* .. */
/* PURPOSE */
/* ======= */
/* DTRTI2 COMPUTES THE INVERSE OF A REAL UPPER OR LOWER TRIANGULAR */
/* MATRIX. */
/* THIS IS THE LEVEL 2 BLAS VERSION OF THE ALGORITHM. */
/* ARGUMENTS */
/* ========= */
/* UPLO (INPUT) CHARACTER*1 */
/* SPECIFIES WHETHER THE MATRIX A IS UPPER OR LOWER TRIANGULAR. */
/* = 'U': UPPER TRIANGULAR */
/* = 'L': LOWER TRIANGULAR */
/* DIAG (INPUT) CHARACTER*1 */
/* SPECIFIES WHETHER OR NOT THE MATRIX A IS UNIT TRIANGULAR. */
/* = 'N': NON-UNIT TRIANGULAR */
/* = 'U': UNIT TRIANGULAR */
/* N (INPUT) INTEGER */
/* THE ORDER OF THE MATRIX A. N >= 0. */
/* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) */
/* ON ENTRY, THE TRIANGULAR MATRIX A. IF UPLO = 'U', THE */
/* LEADING N BY N UPPER TRIANGULAR PART OF THE ARRAY A CONTAINS */
/* THE UPPER TRIANGULAR MATRIX, AND THE STRICTLY LOWER */
/* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE */
/* LEADING N BY N LOWER TRIANGULAR PART OF THE ARRAY A CONTAINS */
/* THE LOWER TRIANGULAR MATRIX, AND THE STRICTLY UPPER */
/* TRIANGULAR PART OF A IS NOT REFERENCED. IF DIAG = 'U', THE */
/* DIAGONAL ELEMENTS OF A ARE ALSO NOT REFERENCED AND ARE */
/* ASSUMED TO BE 1. */
/* ON EXIT, THE (TRIANGULAR) INVERSE OF THE ORIGINAL MATRIX, IN */
/* THE SAME STORAGE FORMAT. */
/* LDA (INPUT) INTEGER */
/* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). */
/* INFO (OUTPUT) INTEGER */
/* = 0: SUCCESSFUL EXIT */
/* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE */
/* ===================================================================== */
/* .. 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 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRTI2", &i__1, (ftnlen)6);
return 0;
}
if (upper) {
/* COMPUTE INVERSE OF UPPER TRIANGULAR MATRIX. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
/* COMPUTE ELEMENTS 1:J-1 OF J-TH COLUMN. */
i__2 = j - 1;
dtrmv_("UPPER", "NO TRANSPOSE", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)
1);
i__2 = j - 1;
dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* COMPUTE INVERSE OF LOWER TRIANGULAR MATRIX. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
if (j < *n) {
/* COMPUTE ELEMENTS J+1:N OF J-TH COLUMN. */
i__1 = *n - j;
dtrmv_("LOWER", "NO TRANSPOSE", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1, (
ftnlen)5, (ftnlen)12, (ftnlen)1);
i__1 = *n - j;
dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* END OF DTRTI2 */
} /* dtrti2_ */
/* Subroutine */ int dtrt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *lda, doublereal *x, integer *
ldx, doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j;
doublereal eps;
doublereal anorm, bnorm;
doublereal xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRT02 computes the residual for the computed solution to a */
/* triangular system of linear equations A*x = b or A'*x = b. */
/* Here A is a triangular matrix, A' is the transpose of A, and x and b */
/* are N by NRHS matrices. The test ratio is the maximum over the */
/* number of right hand sides of */
/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A or A' and EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': A *x = b (No transpose) */
/* = 'T': A'*x = b (Transpose) */
/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* 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 X and B. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = dlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
} else {
anorm = dlantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
bnorm = dasum_(n, &work[1], &c__1);
xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of DTRT02 */
} /* dtrt02_ */
/* Subroutine */ int dlarzt_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1;
doublereal d__1;
/* Local variables */
integer i__, j, info;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtrmv_(char *,
char *, char *, integer *, doublereal *, integer *, 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 */
/* ======= */
/* DLARZT forms the triangular factor T of a real block reflector */
/* H of order > n, which is defined as a product of k elementary */
/* reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise (not supported yet) */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) DOUBLE PRECISION array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* ______V_____ */
/* ( v1 v2 v3 ) / \ */
/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
/* ( v1 v2 v3 ) */
/* . . . */
/* . . . */
/* 1 . . */
/* 1 . */
/* 1 */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* ______V_____ */
/* 1 / \ */
/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
/* . . . */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* V = ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for currently supported options */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
info = 0;
if (! lsame_(direct, "B")) {
info = -1;
} else if (! lsame_(storev, "R")) {
info = -2;
}
if (info != 0) {
i__1 = -info;
xerbla_("DLARZT", &i__1);
return 0;
}
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.;
/* L10: */
}
} else {
/* general case */
if (i__ < *k) {
/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
i__1 = *k - i__;
d__1 = -tau[i__];
dgemv_("No transpose", &i__1, n, &d__1, &v[i__ + 1 + v_dim1],
ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ *
t_dim1], &c__1);
/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
, &c__1);
}
t[i__ + i__ * t_dim1] = tau[i__];
}
/* L20: */
}
return 0;
/* End of DLARZT */
} /* dlarzt_ */
/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DGGLSE solves the linear equality-constrained least squares (LSE)
problem:
minimize || c - A*x ||_2 subject to B*x = d
where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
M-vector, and d is a given P-vector. It is assumed that
P <= N <= M+P, and
rank(B) = P and rank( ( A ) ) = N.
( ( B ) )
These conditions ensure that the LSE problem has a unique solution,
which is obtained using a GRQ factorization of the matrices B and A.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
P (input) INTEGER
The number of rows of the matrix B. 0 <= P <= N <= M+P.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B is destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
C (input/output) DOUBLE PRECISION array, dimension (M)
On entry, C contains the right hand side vector for the
least squares part of the LSE problem.
On exit, the residual sum of squares for the solution
is given by the sum of squares of elements N-P+1 to M of
vector C.
D (input/output) DOUBLE PRECISION array, dimension (P)
On entry, D contains the right hand side vector for the
constrained equation.
On exit, D is destroyed.
X (output) DOUBLE PRECISION array, dimension (N)
On exit, X is the solution of the LSE problem.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,M+N+P).
For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
where NB is an upper bound for the optimal blocksizes for
DGEQRF, SGERQF, DORMQR and SORMRQ.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b29 = -1.;
static doublereal c_b31 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
, dtrmv_(char *, char *, char *, integer *, doublereal *, integer
*, doublereal *, integer *), dtrsv_(char *
, char *, char *, integer *, doublereal *, integer *, doublereal *
, integer *);
static integer nb, mn, nr;
extern /* Subroutine */ int dggrqf_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormrq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
static integer lwkopt;
static logical lquery;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkopt = *p + mn + max(*m,*n) * nb;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*p < 0 || *p > *n || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *m + *n + *p;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGLSE", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GRQ factorization of matrices B and A:
B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
N-P P ( 0 R22 ) M+P-N
N-P P
where T12 and R11 are upper triangular, and Q and Z are
orthogonal. */
i__1 = *lwork - *p - mn;
dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = (integer) work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P
( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
dtrsv_("Upper", "No transpose", "Non unit", p, &b_ref(1, *n - *p + 1),
ldb, &d__[1], &c__1);
/* Update c1 */
i__1 = *n - *p;
dgemv_("No transpose", &i__1, p, &c_b29, &a_ref(1, *n - *p + 1), lda, &
d__[1], &c__1, &c_b31, &c__[1], &c__1);
/* Sovle R11*x1 = c1 for x1 */
i__1 = *n - *p;
dtrsv_("Upper", "No transpose", "Non unit", &i__1, &a[a_offset], lda, &
c__[1], &c__1);
/* Put the solutions in X */
i__1 = *n - *p;
dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
i__1 = *n - *m;
dgemv_("No transpose", &nr, &i__1, &c_b29, &a_ref(*n - *p + 1, *m + 1)
, lda, &d__[nr + 1], &c__1, &c_b31, &c__[*n - *p + 1], &c__1);
} else {
nr = *p;
}
dtrmv_("Upper", "No transpose", "Non unit", &nr, &a_ref(*n - *p + 1, *n -
*p + 1), lda, &d__[1], &c__1);
daxpy_(&nr, &c_b29, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (doublereal) (*p + mn + max(i__1,i__2));
return 0;
/* End of DGGLSE */
} /* dgglse_ */
/* Subroutine */ int dget01_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *afac, integer *ldafac, integer *ipiv, doublereal *
rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
/* Local variables */
integer i__, j, k;
doublereal t, eps;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET01 reconstructs a matrix A from its L*U factorization and */
/* computes the residual */
/* norm(L*U - A) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original M x N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factors */
/* L and U from the L*U factorization as computed by DGETRF. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*U - A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESID (output) DOUBLE PRECISION */
/* norm(L*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if M = 0 or N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--ipiv;
--rwork;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
/* Compute the product L*U and overwrite AFAC with the result. */
/* A column at a time of the product is obtained, starting with */
/* column N. */
for (k = *n; k >= 1; --k) {
if (k > *m) {
dtrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
} else {
/* Compute elements (K+1:M,K) */
t = afac[k + k * afac_dim1];
if (k + 1 <= *m) {
i__1 = *m - k;
dscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
i__1 = *m - k;
i__2 = k - 1;
dgemv_("No transpose", &i__1, &i__2, &c_b11, &afac[k + 1 +
afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
c_b11, &afac[k + 1 + k * afac_dim1], &c__1);
}
/* Compute the (K,K) element */
i__1 = k - 1;
afac[k + k * afac_dim1] = t + ddot_(&i__1, &afac[k + afac_dim1],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* Compute elements (1:K-1,K) */
i__1 = k - 1;
dtrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
}
/* L10: */
}
i__1 = min(*m,*n);
dlaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
/* Compute the difference L*U - A and store in AFAC. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L20: */
}
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = dlange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of DGET01 */
} /* dget01_ */
/*< SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) >*/
/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt, ftnlen direct_len, ftnlen storev_len)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j;
doublereal vii;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dtrmv_(char *,
char *, char *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
(void)direct_len;
(void)storev_len;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/*< CHARACTER DIRECT, STOREV >*/
/*< INTEGER K, LDT, LDV, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DLARFT forms the triangular factor T of a real block reflector H */
/* of order n, which is defined as a product of k elementary reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) DOUBLE PRECISION array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* ( v1 1 ) ( 1 v2 v2 v2 ) */
/* ( v1 v2 1 ) ( 1 v3 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* ( 1 v3 ) */
/* ( 1 ) */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, J >*/
/*< DOUBLE PRECISION VII >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DGEMV, DTRMV >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/*< >*/
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
/*< IF( LSAME( DIRECT, 'F' ) ) THEN >*/
if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
/*< DO 20 I = 1, K >*/
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IF( TAU( I ).EQ.ZERO ) THEN >*/
if (tau[i__] == 0.) {
/* H(i) = I */
/*< DO 10 J = 1, I >*/
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
/*< T( J, I ) = ZERO >*/
t[j + i__ * t_dim1] = 0.;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< ELSE >*/
} else {
/* general case */
/*< VII = V( I, I ) >*/
vii = v[i__ + i__ * v_dim1];
/*< V( I, I ) = ONE >*/
v[i__ + i__ * v_dim1] = 1.;
/*< IF( LSAME( STOREV, 'C' ) ) THEN >*/
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
/*< >*/
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
d__1 = -tau[i__];
dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1],
ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
i__ * t_dim1 + 1], &c__1, (ftnlen)9);
/*< ELSE >*/
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
/*< >*/
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
d__1 = -tau[i__];
dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b8, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)12);
/*< END IF >*/
}
/*< V( I, I ) = VII >*/
v[i__ + i__ * v_dim1] = vii;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
/*< >*/
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
5, (ftnlen)12, (ftnlen)8);
/*< T( I, I ) = TAU( I ) >*/
t[i__ + i__ * t_dim1] = tau[i__];
/*< END IF >*/
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE >*/
} else {
/*< DO 40 I = K, 1, -1 >*/
for (i__ = *k; i__ >= 1; --i__) {
/*< IF( TAU( I ).EQ.ZERO ) THEN >*/
if (tau[i__] == 0.) {
/* H(i) = I */
/*< DO 30 J = I, K >*/
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
/*< T( J, I ) = ZERO >*/
t[j + i__ * t_dim1] = 0.;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< ELSE >*/
} else {
/* general case */
/*< IF( I.LT.K ) THEN >*/
if (i__ < *k) {
/*< IF( LSAME( STOREV, 'C' ) ) THEN >*/
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
/*< VII = V( N-K+I, I ) >*/
vii = v[*n - *k + i__ + i__ * v_dim1];
/*< V( N-K+I, I ) = ONE >*/
v[*n - *k + i__ + i__ * v_dim1] = 1.;
/* T(i+1:k,i) := */
/* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
/*< >*/
i__1 = *n - *k + i__;
i__2 = *k - i__;
d__1 = -tau[i__];
dgemv_("Transpose", &i__1, &i__2, &d__1, &v[(i__ + 1)
* v_dim1 + 1], ldv, &v[i__ * v_dim1 + 1], &
c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
c__1, (ftnlen)9);
/*< V( N-K+I, I ) = VII >*/
v[*n - *k + i__ + i__ * v_dim1] = vii;
/*< ELSE >*/
} else {
/*< VII = V( I, N-K+I ) >*/
vii = v[i__ + (*n - *k + i__) * v_dim1];
/*< V( I, N-K+I ) = ONE >*/
v[i__ + (*n - *k + i__) * v_dim1] = 1.;
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
/*< >*/
i__1 = *k - i__;
i__2 = *n - *k + i__;
d__1 = -tau[i__];
dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1, (
ftnlen)12);
/*< V( I, N-K+I ) = VII >*/
v[i__ + (*n - *k + i__) * v_dim1] = vii;
/*< END IF >*/
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
/*< >*/
i__1 = *k - i__;
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
/*< END IF >*/
}
/*< T( I, I ) = TAU( I ) >*/
t[i__ + i__ * t_dim1] = tau[i__];
/*< END IF >*/
}
/*< 40 CONTINUE >*/
/* L40: */
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of DLARFT */
/*< END >*/
} /* dlarft_ */
/* Subroutine */
int dtrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *a, integer *lda, 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, 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 *);
logical upper;
extern /* Subroutine */
int dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, integer *), dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical notran;
char transt[1];
logical nounit;
doublereal lstres;
/* -- 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;
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");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*nrhs < 0)
{
*info = -5;
}
else if (*lda < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DTRRFS", &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;
}
if (notran)
{
*(unsigned char *)transt = 'T';
}
else
{
*(unsigned char *)transt = 'N';
}
/* 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)
{
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A or A**T, depending on TRANS. */
dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(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));
/* L20: */
}
if (notran)
{
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = a[i__ + k * a_dim1], f2c_abs( d__1)) * xk;
/* L30: */
}
/* L40: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
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;
/* L50: */
}
work[k] += xk;
/* L60: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = a[i__ + k * a_dim1], f2c_abs( d__1)) * xk;
/* L70: */
}
/* L80: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
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;
/* L90: */
}
work[k] += xk;
/* L100: */
}
}
}
}
else
{
/* Compute f2c_abs(A**T)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * ( d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
/* L110: */
}
work[k] += s;
/* L120: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * ( d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
/* L130: */
}
work[k] += s;
/* L140: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * ( d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
/* L150: */
}
work[k] += s;
/* L160: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
s += (d__1 = a[i__ + k * a_dim1], f2c_abs(d__1)) * ( d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
/* L170: */
}
work[k] += s;
/* L180: */
}
}
}
}
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);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(op(A)))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(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(op(A))*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(op(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;
}
/* L200: */
}
kase = 0;
L210:
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(op(A)**T). */
dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] , &c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
}
else
{
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
}
goto L210;
}
/* 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);
/* L240: */
}
if (lstres != 0.)
{
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of DTRRFS */
}
/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DSYGS2 reduces a real symmetric-definite generalized eigenproblem
to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by DPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. 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 INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by DPOTRF.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b6 = -1.;
static integer c__1 = 1;
static doublereal c_b27 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal ct;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal akk, bkk;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a_ref(k, k) = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a_ref(k, k + 1), lda);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b_ref(k + 1,
k + 1), ldb, &a_ref(k, k + 1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a_ref(k, k) = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a_ref(k + 1, k), &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a_ref(k + 1, k), &c__1, &
b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k
+ 1, k + 1), ldb, &a_ref(k + 1, k), &c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
i__2 = k - 1;
dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
/* Computing 2nd power */
d__1 = bkk;
a_ref(k, k) = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
i__2 = k - 1;
dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(k, 1), lda);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a_ref(k, 1), lda);
/* Computing 2nd power */
d__1 = bkk;
a_ref(k, k) = akk * (d__1 * d__1);
/* L40: */
}
}
}
return 0;
/* End of DSYGS2 */
} /* dsygs2_ */
void
dtrmv(char uplo, char transa, char diag, int n, double *a, int lda, double *x, int incx)
{
dtrmv_( &uplo, &transa, &diag, &n, a, &lda, x, &incx);
}
/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublereal *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTRRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular
coefficient matrix.
The solution matrix X must be computed by DTRTRS or some other
means before entering this routine. DTRRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
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 triangular matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of the array A contains the upper
triangular matrix, and the strictly lower triangular part of
A is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of the array A contains the lower triangular
matrix, and the strictly upper triangular part of A is not
referenced. If DIAG = 'U', the diagonal elements of A are
also not referenced and are assumed to be 1.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
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) DOUBLE PRECISION array, dimension (LDX,NRHS)
The 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
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b19 = -1.;
/* System generated locals */
integer a_dim1, a_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 logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
integer *, 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 logical notran;
static char transt[1];
static logical nounit;
static doublereal lstres, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRRFS", &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;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* 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) {
/* Compute residual R = B - op(A) * X,
where op(A) = A or A', depending on TRANS. */
dcopy_(n, &x_ref(1, j), &c__1, &work[*n + 1], &c__1);
dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
daxpy_(n, &c_b19, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(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_ref(i__, j), abs(d__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) *
xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) *
xk;
/* L50: */
}
work[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) *
xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) *
xk;
/* L90: */
}
work[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 =
x_ref(i__, j), abs(d__2));
/* L110: */
}
work[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (d__1 = x_ref(k, j), abs(d__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 =
x_ref(i__, j), abs(d__2));
/* L130: */
}
work[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 =
x_ref(i__, j), abs(d__2));
/* L150: */
}
work[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (d__1 = x_ref(k, j), abs(d__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 =
x_ref(i__, j), abs(d__2));
/* L170: */
}
work[k] += s;
/* L180: */
}
}
}
}
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);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(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(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(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;
}
/* L200: */
}
kase = 0;
L210:
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(op(A)'). */
dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
, &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
&c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
lstres = max(d__2,d__3);
/* L240: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of DTRRFS */
} /* dtrrfs_ */
/* Subroutine */ int dtrt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *lda, doublereal *scale,
doublereal *cnorm, doublereal *tscal, doublereal *x, integer *ldx,
doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal xscal;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dtrmv_(char *,
char *, char *, integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal tnorm, xnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
static integer ix;
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal bignum, smlnum, eps, err;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DTRT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b or A'*x = s*b.
Here A is a triangular matrix, A' is the transpose of A, s is a
scalar, and x and b are N by NRHS matrices. The test ratio is the
maximum over the number of right hand sides of
norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': A *x = s*b (No transpose)
= 'T': A'*x = s*b (Transpose)
= 'C': A'*x = s*b (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
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 X and B. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The triangular matrix A. If UPLO = 'U', the leading n by n
upper triangular part of the array A contains the upper
triangular matrix, and the strictly lower triangular part of
A is not referenced. If UPLO = 'L', the leading n by n lower
triangular part of the array A contains the lower triangular
matrix, and the strictly upper triangular part of A is not
referenced. If DIAG = 'U', the diagonal elements of A are
also not referenced and are assumed to be 1.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
SCALE (input) DOUBLE PRECISION
The scaling factor s used in solving the triangular system.
CNORM (input) DOUBLE PRECISION array, dimension (N)
The 1-norms of the columns of A, not counting the diagonal.
TSCAL (input) DOUBLE PRECISION
The scaling factor used in computing the 1-norms in CNORM.
CNORM actually contains the column norms of TSCAL*A.
X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
The maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
eps = dlamch_("Epsilon");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column
norms already computed by DLATRS. */
tnorm = 0.;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = tnorm, d__3 = *tscal * (d__1 = a_ref(j, j), abs(d__1)) +
cnorm[j];
tnorm = max(d__2,d__3);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = tnorm, d__2 = *tscal + cnorm[j];
tnorm = max(d__1,d__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ix = idamax_(n, &work[1], &c__1);
/* Computing MAX */
d__2 = 1., d__3 = (d__1 = x_ref(ix, j), abs(d__1));
xnorm = max(d__2,d__3);
xscal = 1. / xnorm / (doublereal) (*n);
dscal_(n, &xscal, &work[1], &c__1);
dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
d__1 = -(*scale) * xscal;
daxpy_(n, &d__1, &b_ref(1, j), &c__1, &work[1], &c__1);
ix = idamax_(n, &work[1], &c__1);
err = *tscal * (d__1 = work[ix], abs(d__1));
ix = idamax_(n, &x_ref(1, j), &c__1);
xnorm = (d__1 = x_ref(ix, j), abs(d__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.) {
err /= xnorm;
}
} else {
if (err > 0.) {
err = 1. / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.) {
err /= tnorm;
}
} else {
if (err > 0.) {
err = 1. / eps;
}
}
*resid = max(*resid,err);
/* L30: */
}
return 0;
/* End of DTRT03 */
} /* dtrt03_ */
/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DTRTI2 computes the inverse of a real upper or lower triangular
matrix.
This is the Level 2 BLAS version of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the triangular matrix A. If UPLO = 'U', the
leading n by n upper triangular part of the array A contains
the upper triangular matrix, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of the array A contains
the lower triangular matrix, and the strictly upper
triangular part of A is not referenced. If DIAG = 'U', the
diagonal elements of A are also not referenced and are
assumed to be 1.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
static logical nounit;
static doublereal ajj;
#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;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a_ref(j, j) = 1. / a_ref(j, j);
ajj = -a_ref(j, j);
} else {
ajj = -1.;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a_ref(1, j), &c__1);
i__2 = j - 1;
dscal_(&i__2, &ajj, &a_ref(1, j), &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a_ref(j, j) = 1. / a_ref(j, j);
ajj = -a_ref(j, j);
} else {
ajj = -1.;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
dtrmv_("Lower", "No transpose", diag, &i__1, &a_ref(j + 1, j
+ 1), lda, &a_ref(j + 1, j), &c__1);
i__1 = *n - j;
dscal_(&i__1, &ajj, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
return 0;
/* End of DTRTI2 */
} /* dtrti2_ */
/* Subroutine */ int dget01_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *afac, integer *ldafac, integer *ipiv, doublereal *
rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__, j, k;
static doublereal t;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static doublereal anorm;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define afac_ref(a_1,a_2) afac[(a_2)*afac_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGET01 reconstructs a matrix A from its L*U factorization and
computes the residual
norm(L*U - A) / ( N * norm(A) * EPS ),
where EPS is the machine epsilon.
Arguments
==========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The original M x N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N)
The factored form of the matrix A. AFAC contains the factors
L and U from the L*U factorization as computed by DGETRF.
Overwritten with the reconstructed matrix, and then with the
difference L*U - A.
LDAFAC (input) INTEGER
The leading dimension of the array AFAC. LDAFAC >= max(1,M).
IPIV (input) INTEGER array, dimension (N)
The pivot indices from DGETRF.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESID (output) DOUBLE PRECISION
norm(L*U - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if M = 0 or N = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1 * 1;
afac -= afac_offset;
--ipiv;
--rwork;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
/* Compute the product L*U and overwrite AFAC with the result.
A column at a time of the product is obtained, starting with
column N. */
for (k = *n; k >= 1; --k) {
if (k > *m) {
dtrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
ldafac, &afac_ref(1, k), &c__1);
} else {
/* Compute elements (K+1:M,K) */
t = afac_ref(k, k);
if (k + 1 <= *m) {
i__1 = *m - k;
dscal_(&i__1, &t, &afac_ref(k + 1, k), &c__1);
i__1 = *m - k;
i__2 = k - 1;
dgemv_("No transpose", &i__1, &i__2, &c_b11, &afac_ref(k + 1,
1), ldafac, &afac_ref(1, k), &c__1, &c_b11, &afac_ref(
k + 1, k), &c__1);
}
/* Compute the (K,K) element */
i__1 = k - 1;
afac_ref(k, k) = t + ddot_(&i__1, &afac_ref(k, 1), ldafac, &
afac_ref(1, k), &c__1);
/* Compute elements (1:K-1,K) */
i__1 = k - 1;
dtrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
ldafac, &afac_ref(1, k), &c__1);
}
/* L10: */
}
i__1 = min(*m,*n);
dlaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
/* Compute the difference L*U - A and store in AFAC. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
afac_ref(i__, j) = afac_ref(i__, j) - a_ref(i__, j);
/* L20: */
}
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = dlange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of DGET01 */
} /* dget01_ */
/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer k;
doublereal ct, akk, bkk;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
integer *, 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 */
/* ======= */
/* DSYGS2 reduces a real symmetric-definite generalized eigenproblem */
/* to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by DPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. 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 INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by DPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
/* Computing 2nd power */
d__1 = bkk;
a[k + k * a_dim1] = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k + a_dim1], lda);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k +
b_dim1], ldb, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a[k + a_dim1], lda);
/* Computing 2nd power */
d__1 = bkk;
a[k + k * a_dim1] = akk * (d__1 * d__1);
/* L40: */
}
}
}
return 0;
/* End of DSYGS2 */
} /* dsygs2_ */
/* Subroutine */ int dtrt01_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, doublereal *ainv, integer *ldainv, doublereal *rcond,
doublereal *work, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2;
/* Local variables */
integer j;
doublereal eps;
doublereal anorm;
doublereal ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRT01 computes the residual for a triangular matrix A times its */
/* inverse: */
/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N) */
/* On entry, the (triangular) inverse of the matrix A, in the */
/* same storage format as A. */
/* On exit, the contents of AINV are destroyed. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal condition number of A, computed as */
/* 1/(norm(A) * norm(AINV)). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
ainv_dim1 = *ldainv;
ainv_offset = 1 + ainv_dim1;
ainv -= ainv_offset;
--work;
/* Function Body */
if (*n <= 0) {
*rcond = 1.;
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = dlamch_("Epsilon");
anorm = dlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
ainvnm = dlantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &work[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
*rcond = 0.;
*resid = 1. / eps;
return 0;
}
*rcond = 1. / anorm / ainvnm;
/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
if (lsame_(diag, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ainv[j + j * ainv_dim1] = 1.;
/* L10: */
}
}
/* Compute A * AINV, overwriting AINV. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dtrmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
ainv[j * ainv_dim1 + 1], &c__1);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
dtrmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
lda, &ainv[j + j * ainv_dim1], &c__1);
/* L30: */
}
}
/* Subtract 1 from each diagonal element to form A*AINV - I. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ainv[j + j * ainv_dim1] += -1.;
/* L40: */
}
/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
*resid = dlantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
&work[1]);
*resid = *resid * *rcond / (doublereal) (*n) / eps;
return 0;
/* End of DTRT01 */
} /* dtrt01_ */
/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLARFT forms the triangular factor T of a real block reflector H
of order n, which is defined as a product of k elementary reflectors.
If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
If STOREV = 'C', the vector which defines the elementary reflector
H(i) is stored in the i-th column of the array V, and
H = I - V * T * V'
If STOREV = 'R', the vector which defines the elementary reflector
H(i) is stored in the i-th row of the array V, and
H = I - V' * T * V
Arguments
=========
DIRECT (input) CHARACTER*1
Specifies the order in which the elementary reflectors are
multiplied to form the block reflector:
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Specifies how the vectors which define the elementary
reflectors are stored (see also Further Details):
= 'C': columnwise
= 'R': rowwise
N (input) INTEGER
The order of the block reflector H. N >= 0.
K (input) INTEGER
The order of the triangular factor T (= the number of
elementary reflectors). K >= 1.
V (input/output) DOUBLE PRECISION array, dimension
(LDV,K) if STOREV = 'C'
(LDV,N) if STOREV = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
TAU (input) DOUBLE PRECISION array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i).
T (output) DOUBLE PRECISION array, dimension (LDT,K)
The k by k triangular factor T of the block reflector.
If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
lower triangular. The rest of the array is not used.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
Further Details
===============
The shape of the matrix V and the storage of the vectors which define
the H(i) is best illustrated by the following example with n = 5 and
k = 3. The elements equal to 1 are not stored; the corresponding
array elements are modified but restored on exit. The rest of the
array is not used.
DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
( v1 1 ) ( 1 v2 v2 v2 )
( v1 v2 1 ) ( 1 v3 v3 )
( v1 v2 v3 )
( v1 v2 v3 )
DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
V = ( v1 v2 v3 ) V = ( v1 v1 1 )
( v1 v2 v3 ) ( v2 v2 v2 1 )
( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
( 1 v3 )
( 1 )
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 0.;
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtrmv_(char *,
char *, char *, integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal vii;
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t_ref(j, i__) = 0.;
/* L10: */
}
} else {
/* general case */
vii = v_ref(i__, i__);
v_ref(i__, i__) = 1.;
if (lsame_(storev, "C")) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
d__1 = -tau[i__];
dgemv_("Transpose", &i__2, &i__3, &d__1, &v_ref(i__, 1),
ldv, &v_ref(i__, i__), &c__1, &c_b8, &t_ref(1,
i__), &c__1);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
d__1 = -tau[i__];
dgemv_("No transpose", &i__2, &i__3, &d__1, &v_ref(1, i__)
, ldv, &v_ref(i__, i__), ldv, &c_b8, &t_ref(1,
i__), &c__1);
}
v_ref(i__, i__) = vii;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t_ref(1, i__), &c__1);
t_ref(i__, i__) = tau[i__];
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t_ref(j, i__) = 0.;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C")) {
vii = v_ref(*n - *k + i__, i__);
v_ref(*n - *k + i__, i__) = 1.;
/* T(i+1:k,i) :=
- tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
d__1 = -tau[i__];
dgemv_("Transpose", &i__1, &i__2, &d__1, &v_ref(1,
i__ + 1), ldv, &v_ref(1, i__), &c__1, &c_b8, &
t_ref(i__ + 1, i__), &c__1);
v_ref(*n - *k + i__, i__) = vii;
} else {
vii = v_ref(i__, *n - *k + i__);
v_ref(i__, *n - *k + i__) = 1.;
/* T(i+1:k,i) :=
- tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
i__1 = *k - i__;
i__2 = *n - *k + i__;
d__1 = -tau[i__];
dgemv_("No transpose", &i__1, &i__2, &d__1, &v_ref(
i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b8,
&t_ref(i__ + 1, i__), &c__1);
v_ref(i__, *n - *k + i__) = vii;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref(
i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), &
c__1);
}
t_ref(i__, i__) = tau[i__];
}
/* L40: */
}
}
return 0;
/* End of DLARFT */
} /* dlarft_ */
/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer j;
doublereal ajj;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
logical nounit;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRTI2 computes the inverse of a real upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the triangular matrix A. If UPLO = 'U', the */
/* leading n by n upper triangular part of the array A contains */
/* the upper triangular matrix, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of the array A contains */
/* the lower triangular matrix, and the strictly upper */
/* triangular part of A is not referenced. If DIAG = 'U', the */
/* diagonal elements of A are also not referenced and are */
/* assumed to be 1. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. 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;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DTRTI2 */
} /* dtrti2_ */
/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGGLSE solves the linear equality-constrained least squares (LSE) */
/* problem: */
/* minimize || c - A*x ||_2 subject to B*x = d */
/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
/* M-vector, and d is a given P-vector. It is assumed that */
/* P <= N <= M+P, and */
/* rank(B) = P and rank( (A) ) = N. */
/* ( (B) ) */
/* These conditions ensure that the LSE problem has a unique solution, */
/* which is obtained using a generalized RQ factorization of the */
/* matrices (B, A) given by */
/* B = (0 R)*Q, A = Z*T*Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
/* contains the P-by-P upper triangular matrix R. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* C (input/output) DOUBLE PRECISION array, dimension (M) */
/* On entry, C contains the right hand side vector for the */
/* least squares part of the LSE problem. */
/* On exit, the residual sum of squares for the solution */
/* is given by the sum of squares of elements N-P+1 to M of */
/* vector C. */
/* D (input/output) DOUBLE PRECISION array, dimension (P) */
/* On entry, D contains the right hand side vector for the */
/* constrained equation. */
/* On exit, D is destroyed. */
/* X (output) DOUBLE PRECISION array, dimension (N) */
/* On exit, X is the solution of the LSE problem. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */
/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
/* where NB is an upper bound for the optimal blocksizes for */
/* DGEQRF, SGERQF, DORMQR and SORMRQ. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the upper triangular factor R associated with B in the */
/* generalized RQ factorization of the pair (B, A) is */
/* singular, so that rank(B) < P; the least squares */
/* solution could not be computed. */
/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
/* T associated with A in the generalized RQ factorization */
/* of the pair (B, A) is singular, so that */
/* rank( (A) ) < N; the least squares solution could not */
/* ( (B) ) */
/* be computed. */
/* ===================================================================== */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*p < 0 || *p > *n || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -7;
}
/* Calculate workspace */
if (*info == 0) {
if (*n == 0) {
lwkmin = 1;
lwkopt = 1;
} else {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkmin = *m + *n + *p;
lwkopt = *p + mn + max(*m,*n) * nb;
}
work[1] = (doublereal) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGLSE", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GRQ factorization of matrices B and A: */
/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
/* N-P P ( 0 R22 ) M+P-N */
/* N-P P */
/* where T12 and R11 are upper triangular, and Q and Z are */
/* orthogonal. */
i__1 = *lwork - *p - mn;
dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = (integer) work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P */
/* ( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
if (*p > 0) {
dtrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
1) * b_dim1 + 1], ldb, &d__[1], p, info);
if (*info > 0) {
*info = 1;
return 0;
}
/* Put the solution in X */
dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Update c1 */
i__1 = *n - *p;
dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 +
1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1);
}
/* Solve R11*x1 = c1 for x1 */
if (*n > *p) {
i__1 = *n - *p;
i__2 = *n - *p;
dtrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
a_offset], lda, &c__[1], &i__2, info);
if (*info > 0) {
*info = 2;
return 0;
}
/* Put the solutions in X */
i__1 = *n - *p;
dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
}
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
if (nr > 0) {
i__1 = *n - *m;
dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m +
1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n -
*p + 1], &c__1);
}
} else {
nr = *p;
}
if (nr > 0) {
dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
- *p + 1) * a_dim1], lda, &d__[1], &c__1);
daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
}
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (doublereal) (*p + mn + max(i__1,i__2));
return 0;
/* End of DGGLSE */
} /* dgglse_ */