void THBlas_(ger)(long m, long n, real alpha, real *x, long incx, real *y, long incy, real *a, long lda)
{
if(n == 1)
lda = m;
#if defined(USE_BLAS) && (defined(TH_REAL_IS_DOUBLE) || defined(TH_REAL_IS_FLOAT))
if( (m <= INT_MAX) && (n <= INT_MAX) && (lda <= INT_MAX) && (incx <= INT_MAX) && (incy <= INT_MAX) )
{
int i_m = (int)m;
int i_n = (int)n;
int i_lda = (int)lda;
int i_incx = (int)incx;
int i_incy = (int)incy;
#if defined(TH_REAL_IS_DOUBLE)
dger_(&i_m, &i_n, &alpha, x, &i_incx, y, &i_incy, a, &i_lda);
#else
sger_(&i_m, &i_n, &alpha, x, &i_incx, y, &i_incy, a, &i_lda);
#endif
return;
}
#endif
{
long i, j;
for(j = 0; j < n; j++)
{
real *column_ = a+j*lda;
real z = alpha*y[j*incy];
for(i = 0; i < m; i++)
column_[i] += z*x[i*incx] ;
}
}
}
int
f2c_dger(integer* M, integer* N,
doublereal* alpha,
doublereal* X, integer* incX,
doublereal* Y, integer* incY,
doublereal* A, integer* lda)
{
dger_(M, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
void dger(const int M,
const int N,
const double alpha,
const double *X,
const int incX,
const double *Y,
const int incY,
double * A,
const int lda) {
dger_(&M, &N, &alpha, X, &incX, Y, &incY, A, &lda);
}
void L2Sphere::TranH(Variable *x, Vector *etax, Variable *y, LinearOPE *Hx, integer start, integer end, LinearOPE *result) const
{
if (!etax->TempDataExist("xdydn2"))
{
Vector *xdy = x->ConstructEmpty();
SharedSpace *Sharedxdy = new SharedSpace(xdy);
VectorAddVector(x, x, y, xdy);
ScaleTimesVector(x, 1.0 / Metric(x, xdy, xdy), xdy, xdy);
etax->AddToTempData("xdydn2", Sharedxdy);
}
integer ell = Hx->Getsize()[0];
integer length = etax->Getlength();
const double *M = Hx->ObtainReadData();
double *Hty = new double[ell];
Variable *yflat = y->ConstructEmpty();
y->CopyTo(yflat);
double *yflatptr = yflat->ObtainWritePartialData();
yflatptr[0] /= (2 * (n - 1));
yflatptr[n - 1] /= (2 * (n - 1));
for (integer i = 1; i < n - 1; i++)
{
yflatptr[i] /= (n - 1);
}
char *transt = const_cast<char *> ("t");
double one = 1, zero = 0;
integer inc = 1, N = ell;
dgemv_(transt, &length, &N, &one, const_cast<double *> (M + start), &N, yflatptr, &inc, &zero, Hty, &inc);
double scalar = -2.0;
Hx->CopyTo(result);
const SharedSpace *Sharedxdydn2 = etax->ObtainReadTempData("xdydn2");
Vector *xdydn2 = Sharedxdydn2->GetSharedElement();
const double *xdydn2TV = xdydn2->ObtainReadData();
double *resultL = result->ObtainWritePartialData();
dger_(&length, &N, &scalar, const_cast<double *> (xdydn2TV), &inc, Hty, &inc, resultL + start, &N);
delete[] Hty;
delete yflat;
};
// ============================================================================
void compute_case5( int m, int n, int k, int l,
FLA_Obj cb_A, FLA_Obj cb_B, FLA_Obj C, int print_data ) {
int datatype, i, j, kl;
double * buff_cb_A, * buff_cb_B, d_one = 1.0;
// Some initializations.
datatype = FLA_Obj_datatype( cb_A );
buff_cb_A = ( double * ) FLA_Obj_buffer_at_view( cb_A );
buff_cb_B = ( double * ) FLA_Obj_buffer_at_view( cb_B );
// Initialize matrix C for the result.
MyFLA_Obj_set_to_zero( C );
// Show data.
if( print_data == 1 ) {
FLA_Obj_show( " Ci = [ ", C, "%le", " ];" );
FLA_Obj_show( " cb_A = [ ", cb_A, "%le", " ];" );
FLA_Obj_show( " cb_B = [ ", cb_B, "%le", " ];" );
}
// Perform computation.
kl = k * l;
for( i = 0; i < k; i++ ) {
for( j = 0; j < l; j++ ) {
dger_( & m, & n,
& d_one, ( double * ) buff_cb_A + l * m * i + j,
& l,
( double * ) buff_cb_B + i + k * j,
& kl,
( double * ) FLA_Obj_buffer_at_view( C ),
& m );
}
}
// Show data.
if( print_data == 1 ) {
FLA_Obj_show( " Cf = [ ", C, "%le", " ];" );
}
}
void THBlas_(ger)(int64_t m, int64_t n, real alpha, real *x, int64_t incx, real *y, int64_t incy, real *a, int64_t lda)
{
if(n == 1)
lda = m;
#if defined(USE_BLAS) && (defined(TH_REAL_IS_DOUBLE) || defined(TH_REAL_IS_FLOAT))
if( (m <= INT_MAX) && (n <= INT_MAX) && (lda <= INT_MAX) &&
(incx > 0) && (incx <= INT_MAX) &&
(incy > 0) && (incy <= INT_MAX) )
{
THArgCheck(lda >= THMax(1, m), 9,
"lda should be at least max(1, m=%d), but have %d", m, lda);
int i_m = (int)m;
int i_n = (int)n;
int i_lda = (int)lda;
int i_incx = (int)incx;
int i_incy = (int)incy;
#if defined(TH_REAL_IS_DOUBLE)
dger_(&i_m, &i_n, &alpha, x, &i_incx, y, &i_incy, a, &i_lda);
#else
sger_(&i_m, &i_n, &alpha, x, &i_incx, y, &i_incy, a, &i_lda);
#endif
return;
}
#endif
{
int64_t i, j;
for(j = 0; j < n; j++)
{
real *column_ = a+j*lda;
real z = alpha*y[j*incy];
for(i = 0; i < m; i++)
column_[i] += z*x[i*incx] ;
}
}
}
/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed,
doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, ic, jc, ir, jr, jcr;
doublereal tau;
logical bads;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
integer isim;
doublereal temp;
logical badei;
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
doublereal tempa[1];
integer icols;
logical useei;
integer idist;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer irows;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
extern doublereal dlaran_(integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
integer irsign, iupper;
doublereal xnorms;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATME generates random non-symmetric square matrices with */
/* specified eigenvalues for testing LAPACK programs. */
/* DLATME operates by applying the following sequence of */
/* operations: */
/* 1. Set the diagonal to D, where D may be input or */
/* computed according to MODE, COND, DMAX, and RSIGN */
/* as described below. */
/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
/* or MODE=5), certain pairs of adjacent elements of D are */
/* interpreted as the real and complex parts of a complex */
/* conjugate pair; A thus becomes block diagonal, with 1x1 */
/* and 2x2 blocks. */
/* 3. If UPPER='T', the upper triangle of A is set to random values */
/* out of distribution DIST. */
/* 4. If SIM='T', A is multiplied on the left by a random matrix */
/* X, whose singular values are specified by DS, MODES, and */
/* CONDS, and on the right by X inverse. */
/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
/* Householder transformations. If KU < N-1, the upper */
/* bandwidth is reduced to KU. */
/* 6. If ANORM is not negative, the matrix is scaled to have */
/* maximum-element-norm ANORM. */
/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
/* no packing options are available.) */
/* Arguments */
/* ========= */
/* N - INTEGER */
/* The number of columns (or rows) of A. Not modified. */
/* DIST - CHARACTER*1 */
/* On entry, DIST specifies the type of distribution to be used */
/* to generate the random eigen-/singular values, and for the */
/* upper triangle (see UPPER). */
/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. They should lie between 0 and 4095 inclusive, */
/* and ISEED(4) should be odd. The random number generator */
/* uses a linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATME */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the eigenvalues of A. If */
/* MODE=0, then D is assumed to contain the eigenvalues (but */
/* see the description of EI), otherwise they will be */
/* computed according to MODE, COND, DMAX, and RSIGN and */
/* placed in D. */
/* Modified if MODE is nonzero. */
/* MODE - INTEGER */
/* On entry this describes how the eigenvalues are to */
/* be specified: */
/* MODE = 0 means use D (with EI) as input */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. Each odd-even pair */
/* of elements will be either used as two real */
/* eigenvalues or as the real and imaginary part */
/* of a complex conjugate pair of eigenvalues; */
/* the choice of which is done is random, with */
/* 50-50 probability, for each pair. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is between 1 and 4, D has entries ranging */
/* from 1 to 1/COND, if between -1 and -4, D has entries */
/* ranging from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, this is used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* DMAX - DOUBLE PRECISION */
/* If MODE is neither -6, 0 nor 6, the contents of D, as */
/* computed according to MODE and COND, will be scaled by */
/* DMAX / max(abs(D(i))). Note that DMAX need not be */
/* positive: if DMAX is negative (or zero), D will be */
/* scaled by a negative number (or zero). */
/* Not modified. */
/* EI - CHARACTER*1 array, dimension ( N ) */
/* If MODE is 0, and EI(1) is not ' ' (space character), */
/* this array specifies which elements of D (on input) are */
/* real eigenvalues and which are the real and imaginary parts */
/* of a complex conjugate pair of eigenvalues. The elements */
/* of EI may then only have the values 'R' and 'I'. If */
/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
/* nor may two adjacent elements of EI both have the value 'I'. */
/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
/* EI(1)=' ', then the eigenvalues will all be real. */
/* Not modified. */
/* RSIGN - CHARACTER*1 */
/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
/* elements of D, as computed according to MODE and COND, will */
/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
/* they will not be. RSIGN may only have the values 'T' or */
/* 'F'. */
/* Not modified. */
/* UPPER - CHARACTER*1 */
/* If UPPER='T', then the elements of A above the diagonal */
/* (and above the 2x2 diagonal blocks, if A has complex */
/* eigenvalues) will be set to random numbers out of DIST. */
/* If UPPER='F', they will not. UPPER may only have the */
/* values 'T' or 'F'. */
/* Not modified. */
/* SIM - CHARACTER*1 */
/* If SIM='T', then A will be operated on by a "similarity */
/* transform", i.e., multiplied on the left by a matrix X and */
/* on the right by X inverse. X = U S V, where U and V are */
/* random unitary matrices and S is a (diagonal) matrix of */
/* singular values specified by DS, MODES, and CONDS. If */
/* SIM='F', then A will not be transformed. */
/* Not modified. */
/* DS - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the singular values of X, */
/* in the same way that D specifies the eigenvalues of A. */
/* If MODE=0, the DS contains the singular values, which */
/* may not be zero. */
/* Modified if MODE is nonzero. */
/* MODES - INTEGER */
/* CONDS - DOUBLE PRECISION */
/* Same as MODE and COND, but for specifying the diagonal */
/* of S. MODES=-6 and +6 are not allowed (since they would */
/* result in randomly ill-conditioned eigenvalues.) */
/* KL - INTEGER */
/* This specifies the lower bandwidth of the matrix. KL=1 */
/* specifies upper Hessenberg form. If KL is at least N-1, */
/* then A will have full lower bandwidth. KL must be at */
/* least 1. */
/* Not modified. */
/* KU - INTEGER */
/* This specifies the upper bandwidth of the matrix. KU=1 */
/* specifies lower Hessenberg form. If KU is at least N-1, */
/* then A will have full upper bandwidth; if KU and KL */
/* are both at least N-1, then A will be dense. Only one of */
/* KU and KL may be less than N-1. KU must be at least 1. */
/* Not modified. */
/* ANORM - DOUBLE PRECISION */
/* If ANORM is not negative, then A will be scaled by a non- */
/* negative real number to make the maximum-element-norm of A */
/* to be ANORM. */
/* Not modified. */
/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
/* On exit A is the desired test matrix. */
/* Modified. */
/* LDA - INTEGER */
/* LDA specifies the first dimension of A as declared in the */
/* calling program. LDA must be at least N. */
/* Not modified. */
/* WORK - DOUBLE PRECISION array, dimension ( 3*N ) */
/* Workspace. */
/* Modified. */
/* INFO - INTEGER */
/* Error code. On exit, INFO will be set to one of the */
/* following values: */
/* 0 => normal return */
/* -1 => N negative */
/* -2 => DIST illegal string */
/* -5 => MODE not in range -6 to 6 */
/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
/* two adjacent elements of EI are 'I'. */
/* -9 => RSIGN is not 'T' or 'F' */
/* -10 => UPPER is not 'T' or 'F' */
/* -11 => SIM is not 'T' or 'F' */
/* -12 => MODES=0 and DS has a zero singular value. */
/* -13 => MODES is not in the range -5 to 5. */
/* -14 => MODES is nonzero and CONDS is less than 1. */
/* -15 => KL is less than 1. */
/* -16 => KU is less than 1, or KL and KU are both less than */
/* N-1. */
/* -19 => LDA is less than N. */
/* 1 => Error return from DLATM1 (computing D) */
/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
/* 3 => Error return from DLATM1 (computing DS) */
/* 4 => Error return from DLARGE */
/* 5 => Zero singular value from DLATM1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 1) Decode and Test the input parameters. */
/* Initialize flags & seed. */
/* Parameter adjustments */
--iseed;
--d__;
--ei;
--ds;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Check EI */
useei = TRUE_;
badei = FALSE_;
if (lsame_(ei + 1, " ") || *mode != 0) {
useei = FALSE_;
} else {
if (lsame_(ei + 1, "R")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
if (lsame_(ei + (j - 1), "I")) {
badei = TRUE_;
}
} else {
if (! lsame_(ei + j, "R")) {
badei = TRUE_;
}
}
/* L10: */
}
} else {
badei = TRUE_;
}
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (badei) {
*info = -8;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A */
/* Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp > 0.) {
alpha = *dmax__ / temp;
} else if (*dmax__ != 0.) {
*info = 2;
return 0;
} else {
alpha = 0.;
}
dscal_(n, &alpha, &d__[1], &c__1);
}
dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
i__1 = *lda + 1;
dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
/* Set up complex conjugate pairs */
if (*mode == 0) {
if (useei) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L50: */
}
}
} else if (abs(*mode) == 5) {
i__1 = *n;
for (j = 2; j <= i__1; j += 2) {
if (dlaran_(&iseed[1]) > .5) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L60: */
}
}
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
/* (but don't modify the corners of 2x2 blocks.) */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
if (a[jc - 1 + jc * a_dim1] != 0.) {
jr = jc - 2;
} else {
jr = jc - 1;
}
dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
/* L70: */
}
}
/* 4) If SIM='T', apply similarity transformation. */
/* -1 */
/* Transform is X A X , where X = U S V, thus */
/* it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix) */
/* according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L80: */
}
/* Multiply by U and U' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
, &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
a[jcr + ic * a_dim1] = xnorms;
i__2 = irows - 1;
dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
a_dim1], lda);
/* L90: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
a[ir + jcr * a_dim1] = xnorms;
i__2 = icols - 1;
dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
a_dim1], lda);
/* L100: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
alpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
/* L110: */
}
}
}
return 0;
/* End of DLATME */
} /* dlatme_ */
void
dger(int m, int n, double alpha, double *x, int incx, double *y, int incy, double *a, int lda)
{
dger_( &m, &n, &alpha, x, &incx, y, &incy, a, &lda);
}
static void pdgstrf2
/************************************************************************/
(
superlu_options_t *options,
int_t k, double thresh, Glu_persist_t *Glu_persist, gridinfo_t *grid,
LocalLU_t *Llu, SuperLUStat_t *stat, int* info
)
/*
* Purpose
* =======
* Factor diagonal and subdiagonal blocks and test for exact singularity.
* Only the process column that owns block column *k* participates
* in the work.
*
* Arguments
* =========
*
* k (input) int (global)
* The column number of the block column to be factorized.
*
* thresh (input) double (global)
* The threshold value = s_eps * anorm.
*
* Glu_persist (input) Glu_persist_t*
* Global data structures (xsup, supno) replicated on all processes.
*
* grid (input) gridinfo_t*
* The 2D process mesh.
*
* Llu (input/output) LocalLU_t*
* Local data structures to store distributed L and U matrices.
*
* stat (output) SuperLUStat_t*
* Record the statistics about the factorization.
* See SuperLUStat_t structure defined in util.h.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly singular,
* and division by zero will occur if it is used to solve a
* system of equations.
*
*/
{
int c, iam, l, pkk;
int incx = 1, incy = 1;
int nsupr; /* number of rows in the block (LDA) */
int luptr;
int_t i, krow, j, jfst, jlst;
int_t nsupc; /* number of columns in the block */
int_t *xsup = Glu_persist->xsup;
double *lusup, temp;
double *ujrow;
double alpha = -1;
*info = 0;
/* Quick return. */
/* Initialization. */
iam = grid->iam;
krow = PROW( k, grid );
pkk = PNUM( PROW(k, grid), PCOL(k, grid), grid );
j = LBj( k, grid ); /* Local block number */
jfst = FstBlockC( k );
jlst = FstBlockC( k+1 );
lusup = Llu->Lnzval_bc_ptr[j];
nsupc = SuperSize( k );
if ( Llu->Lrowind_bc_ptr[j] ) nsupr = Llu->Lrowind_bc_ptr[j][1];
ujrow = Llu->ujrow;
luptr = 0; /* Point to the diagonal entries. */
c = nsupc;
for (j = 0; j < jlst - jfst; ++j) {
/* Broadcast the j-th row (nsupc - j) elements to
the process column. */
if ( iam == pkk ) { /* Diagonal process. */
i = luptr;
if ( options->ReplaceTinyPivot == YES || lusup[i] == 0.0 ) {
if ( fabs(lusup[i]) < thresh ) { /* Diagonal */
#if ( PRNTlevel>=2 )
printf("(%d) .. col %d, tiny pivot %e ",
iam, jfst+j, lusup[i]);
#endif
/* Keep the replaced diagonal with the same sign. */
if ( lusup[i] < 0 ) lusup[i] = -thresh;
else lusup[i] = thresh;
#if ( PRNTlevel>=2 )
printf("replaced by %e\n", lusup[i]);
#endif
++(stat->TinyPivots);
}
}
for (l = 0; l < c; ++l, i += nsupr) ujrow[l] = lusup[i];
}
#if 0
dbcast_col(ujrow, c, pkk, UjROW, grid, &c);
#else
MPI_Bcast(ujrow, c, MPI_DOUBLE, krow, (grid->cscp).comm);
/*bcast_tree(ujrow, c, MPI_DOUBLE, krow, (24*k+j)%NTAGS,
grid, COMM_COLUMN, &c);*/
#endif
#if ( DEBUGlevel>=2 )
if ( k == 3329 && j == 2 ) {
if ( iam == pkk ) {
printf("..(%d) k %d, j %d: Send ujrow[0] %e\n",iam,k,j,ujrow[0]);
} else {
printf("..(%d) k %d, j %d: Recv ujrow[0] %e\n",iam,k,j,ujrow[0]);
}
}
#endif
if ( !lusup ) { /* Empty block column. */
--c;
if ( ujrow[0] == 0.0 ) *info = j+jfst+1;
continue;
}
/* Test for singularity. */
if ( ujrow[0] == 0.0 ) {
*info = j+jfst+1;
} else {
/* Scale the j-th column of the matrix. */
temp = 1.0 / ujrow[0];
if ( iam == pkk ) {
for (i = luptr+1; i < luptr-j+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr-j-1;
} else {
for (i = luptr; i < luptr+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr;
}
}
/* Rank-1 update of the trailing submatrix. */
if ( --c ) {
if ( iam == pkk ) {
l = nsupr - j - 1;
#ifdef _CRAY
SGER(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#elif defined (USE_VENDOR_BLAS)
dger_(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#else
hypre_F90_NAME_BLAS(dger,DGER)(&l, &c, &alpha,
&lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#endif
stat->ops[FACT] += 2 * l * c;
} else {
#ifdef _CRAY
SGER(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#elif defined (USE_VENDOR_BLAS)
dger_(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#else
hypre_F90_NAME_BLAS(dger,DGER)(&nsupr, &c, &alpha,
&lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#endif
stat->ops[FACT] += 2 * nsupr * c;
}
}
/* Move to the next column. */
if ( iam == pkk ) luptr += nsupr + 1;
else luptr += nsupr;
} /* for j ... */
} /* PDGSTRF2 */
int main( int argc, char** argv )
{
obj_t a, x, y;
obj_t a_save;
obj_t alpha;
dim_t m, n;
dim_t p;
dim_t p_begin, p_end, p_inc;
int m_input, n_input;
num_t dt_a, dt_x, dt_y;
num_t dt_alpha;
int r, n_repeats;
double dtime;
double dtime_save;
double gflops;
bli_init();
n_repeats = 3;
#ifndef PRINT
p_begin = 40;
p_end = 2000;
p_inc = 40;
m_input = -1;
n_input = -1;
#else
p_begin = 16;
p_end = 16;
p_inc = 1;
m_input = 15;
n_input = 15;
#endif
dt_alpha = dt_x = dt_y = dt_a = BLIS_DOUBLE;
for ( p = p_begin; p <= p_end; p += p_inc )
{
if ( m_input < 0 ) m = p * ( dim_t )abs(m_input);
else m = ( dim_t ) m_input;
if ( n_input < 0 ) n = p * ( dim_t )abs(n_input);
else n = ( dim_t ) n_input;
bli_obj_create( dt_alpha, 1, 1, 0, 0, &alpha );
bli_obj_create( dt_x, m, 1, 0, 0, &x );
bli_obj_create( dt_y, n, 1, 0, 0, &y );
bli_obj_create( dt_a, m, n, 0, 0, &a );
bli_obj_create( dt_a, m, n, 0, 0, &a_save );
bli_randm( &x );
bli_randm( &y );
bli_randm( &a );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_copym( &a, &a_save );
dtime_save = DBL_MAX;
for ( r = 0; r < n_repeats; ++r )
{
bli_copym( &a_save, &a );
dtime = bli_clock();
#ifdef PRINT
bli_printm( "x", &x, "%4.1f", "" );
bli_printm( "y", &y, "%4.1f", "" );
bli_printm( "a", &a, "%4.1f", "" );
#endif
#ifdef BLIS
bli_ger( &alpha,
&x,
&y,
&a );
#else
f77_int mm = bli_obj_length( a );
f77_int nn = bli_obj_width( a );
f77_int incx = bli_obj_vector_inc( x );
f77_int incy = bli_obj_vector_inc( y );
f77_int lda = bli_obj_col_stride( a );
double* alphap = bli_obj_buffer( alpha );
double* xp = bli_obj_buffer( x );
double* yp = bli_obj_buffer( y );
double* ap = bli_obj_buffer( a );
dger_( &mm,
&nn,
alphap,
xp, &incx,
yp, &incy,
ap, &lda );
#endif
#ifdef PRINT
bli_printm( "a after", &a, "%4.1f", "" );
exit(1);
#endif
dtime_save = bli_clock_min_diff( dtime_save, dtime );
}
gflops = ( 2.0 * m * n ) / ( dtime_save * 1.0e9 );
#ifdef BLIS
printf( "data_ger_blis" );
#else
printf( "data_ger_%s", BLAS );
#endif
printf( "( %2lu, 1:4 ) = [ %4lu %4lu %10.3e %6.3f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )m,
( unsigned long )n, dtime_save, gflops );
bli_obj_free( &alpha );
bli_obj_free( &x );
bli_obj_free( &y );
bli_obj_free( &a );
bli_obj_free( &a_save );
}
bli_finalize();
return 0;
}
/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
to upper triangular form by means of orthogonal transformations.
The upper trapezoidal matrix A is factored as
A = ( R 0 ) * Z,
where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
triangular matrix.
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 >= M.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the leading M-by-N upper trapezoidal part of the
array A must contain the matrix to be factorized.
On exit, the leading M-by-M upper triangular part of A
contains the upper triangular matrix R, and elements M+1 to
N of the first M rows of A, with the array TAU, represent the
orthogonal matrix Z as a product of M elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) DOUBLE PRECISION array, dimension (M)
The scalar factors of the elementary reflectors.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The factorization is obtained by Householder's method. The kth
transformation matrix, Z( k ), which is used to introduce zeros into
the ( m - k + 1 )th row of A, is given in the form
Z( k ) = ( I 0 ),
( 0 T( k ) )
where
T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
( 0 )
( z( k ) )
tau is a scalar and z( k ) is an ( n - m ) element vector.
tau and z( k ) are chosen to annihilate the elements of the kth row
of X.
The scalar tau is returned in the kth element of TAU and the vector
u( k ) in the kth row of A, such that the elements of z( k ) are
in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
the upper triangular part of A.
Z is given by
Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, k;
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 *)
;
static integer m1;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
TAU(i) = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A
.
First set up the reflection. */
i__1 = *n - *m + 1;
dlarfg_(&i__1, &A(k,k), &A(k,m1), lda, &TAU(
k));
if (TAU(k) != 0. && k > 1) {
/* We now perform the operation A := A*P( k ).
Use the first ( k - 1 ) elements of TAU to sto
re a( k ),
where a( k ) consists of the first ( k - 1 )
elements of
the kth column of A. Also let B denote
the first
( k - 1 ) rows of the last ( n - m ) columns o
f A. */
i__1 = k - 1;
dcopy_(&i__1, &A(1,k), &c__1, &TAU(1), &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &A(1,m1), lda, &A(k,m1), lda, &c_b8, &TAU(1), &
c__1);
/* Now form a( k ) := a( k ) - tau*w
and B := B - tau*w*z( k )'. */
i__1 = k - 1;
d__1 = -TAU(k);
daxpy_(&i__1, &d__1, &TAU(1), &c__1, &A(1,k), &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d__1 = -TAU(k);
dger_(&i__1, &i__2, &d__1, &TAU(1), &c__1, &A(k,m1)
, lda, &A(1,m1), lda);
}
/* L20: */
}
}
return 0;
/* End of DTZRQF */
} /* dtzrqf_ */
/* Subroutine */ int dlarge_(integer *n, doublereal *a, integer *lda, integer
*iseed, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__;
doublereal wa, wb, wn, tau;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *), dlarnv_(integer *, integer *, integer *, doublereal *);
/* -- LAPACK auxiliary test routine (version 3.1) */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARGE pre- and post-multiplies a real general n by n matrix A */
/* with a random orthogonal matrix: A = U*D*U'. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the original n by n matrix A. */
/* On exit, A is overwritten by U*A*U' for some random */
/* orthogonal matrix U. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLARGE", &i__1);
return 0;
}
/* pre- and post-multiply A by random orthogonal matrix */
for (i__ = *n; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i__;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* multiply A(i:n,1:n) by random reflection from the left */
i__1 = *n - i__ + 1;
dgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1],
&c__1, &c_b10, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
d__1 = -tau;
dger_(&i__1, n, &d__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__
+ a_dim1], lda);
/* multiply A(1:n,i:n) by random reflection from the right */
i__1 = *n - i__ + 1;
dgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, &
work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
d__1 = -tau;
dger_(n, &i__1, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ *
a_dim1 + 1], lda);
/* L10: */
}
return 0;
/* End of DLARGE */
} /* dlarge_ */
/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work)
{
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
integer i__;
logical applyleft;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer lastc, lastv;
extern integer iladlc_(integer *, integer *, doublereal *, integer *),
iladlr_(integer *, integer *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARF applies a real elementary reflector H to a real m by n matrix */
/* C, from either the left or the right. H is represented in the form */
/* H = I - tau * v * v' */
/* where tau is a real scalar and v is a real vector. */
/* If tau = 0, then H is taken to be the unit matrix. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) DOUBLE PRECISION array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. V is not used if */
/* TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
applyleft = lsame_(side, "L");
lastv = 0;
lastc = 0;
if (*tau != 0.) {
/* Set up variables for scanning V. LASTV begins pointing to the end */
/* of V. */
if (applyleft) {
lastv = *m;
} else {
lastv = *n;
}
if (*incv > 0) {
i__ = (lastv - 1) * *incv + 1;
} else {
i__ = 1;
}
/* Look for the last non-zero row in V. */
while(lastv > 0 && v[i__] == 0.) {
--lastv;
i__ -= *incv;
}
if (applyleft) {
/* Scan for the last non-zero column in C(1:lastv,:). */
lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
} else {
/* Scan for the last non-zero row in C(:,1:lastv). */
lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
}
}
/* Note that lastc.eq.0 renders the BLAS operations null; no special */
/* case is needed at this level. */
if (applyleft) {
/* Form H * C */
if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
v[1], incv, &c_b5, &work[1], &c__1);
/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
d__1 = -(*tau);
dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
c_offset], ldc);
}
} else {
/* Form C * H */
if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
&v[1], incv, &c_b5, &work[1], &c__1);
/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
d__1 = -(*tau);
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
c_offset], ldc);
}
}
return 0;
/* End of DLARF */
} /* dlarf_ */
/* Subroutine */ int dlarge_(integer *n, doublereal *a, integer *lda, integer
*iseed, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static doublereal wa, wb, wn;
extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
integer *, integer *, integer *, doublereal *);
static doublereal tau;
/* -- LAPACK auxiliary test routine (version 2.0)
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLARGE pre- and post-multiplies a real general n by n matrix A
with a random orthogonal matrix: A = U*D*U'.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the original n by n matrix A.
On exit, A is overwritten by U*A*U' for some random
orthogonal matrix U.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLARGE", &i__1);
return 0;
}
/* pre- and post-multiply A by random orthogonal matrix */
for (i = *n; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* multiply A(i:n,1:n) by random reflection from the left */
i__1 = *n - i + 1;
dgemv_("Transpose", &i__1, n, &c_b8, &a[i + a_dim1], lda, &work[1], &
c__1, &c_b10, &work[*n + 1], &c__1);
i__1 = *n - i + 1;
d__1 = -tau;
dger_(&i__1, n, &d__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i +
a_dim1], lda);
/* multiply A(1:n,i:n) by random reflection from the right */
i__1 = *n - i + 1;
dgemv_("No transpose", n, &i__1, &c_b8, &a[i * a_dim1 + 1], lda, &
work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
i__1 = *n - i + 1;
d__1 = -tau;
dger_(n, &i__1, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i *
a_dim1 + 1], lda);
/* L10: */
}
return 0;
/* End of DLARGE */
} /* dlarge_ */
/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Local variables */
integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
kv, nw;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(
integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *
);
doublereal work13[4160] /* was [65][64] */, work31[4160] /*
was [65][64] */;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dgbtf2_(
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
/* 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. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U because of fill-in resulting from the row interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku);
/* The block size must not exceed the limit set by the size of the */
/* local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
} else {
/* Use blocked code */
/* Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work13[i__ + j * 65 - 66] = 0.;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = nb;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work31[i__ + j * 65 - 66] = 0.;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab[i__ + j * ab_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current */
/* stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned */
/* A11 A12 A13 */
/* A21 A22 A23 */
/* A31 A32 A33 */
/* Here A11, A21 and A31 denote the current block of JB columns */
/* which is about to be factorized. The number of rows in the */
/* partitioning are JB, I2, I3 respectively, and the numbers */
/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
/* and the subdiagonal elements of A31 lie outside the band. */
/* Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated. */
/* Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
/* Set fill-in elements in column JJ+KV to zero */
if (jj + kv <= *n) {
i__4 = *kl;
for (i__ = 1; i__ <= i__4; ++i__) {
ab[i__ + (jj + kv) * ab_dim1] = 0.;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
ipiv[jj] = jp + jj - j;
if (ab[kv + jp + jj * ab_dim1] != 0.) {
/* Computing MAX */
/* Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J to J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__4, &ab[kv + jp + jj - j + j * ab_dim1],
&i__5);
} else {
/* The interchange affects columns J to JJ-1 of A31 */
/* which are stored in the work array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
ab[kv + jp + jj * ab_dim1], &i__6);
}
}
/* Compute multipliers */
d__1 = 1. / ab[kv + 1 + jj * ab_dim1];
dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
/* Update trailing submatrix within the band and within */
/* the current block. JM is the index of the last column */
/* which needs to be updated. */
/* Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
&c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array WORK31 */
/* Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks. */
/* Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use DLASWP to apply the row interchanges to A12, A22, and */
/* A32. */
i__3 = *ldab - 1;
dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
c__1, &jb, &ipiv[j], &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A33 */
/* columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i__ = 1; i__ <= i__3; ++i__) {
jj = k2 + i__;
i__4 = j + jb - 1;
for (ii = j + i__ - 1; ii <= i__4; ++ii) {
ip = ipiv[ii];
if (ip != ii) {
temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
ip - jj + jj * ab_dim1];
ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing submatrix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
if (i2 > 0) {
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
&ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
&c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
i__5);
}
if (i3 > 0) {
/* Update A32 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the work array */
/* WORK13 */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ j + kv - 1) * ab_dim1];
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
&c__65);
if (i2 > 0) {
/* Update A23 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
* ab_dim1], &i__4);
}
if (i3 > 0) {
/* Update A33 */
i__3 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&c_b18, work31, &c__65, work13, &c__65, &
c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
i__3);
}
/* Copy the lower triangle of A13 back into place */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
work13[ii + jj * 65 - 66];
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block to */
/* restore the upper triangular form of A31 and copy the upper */
/* triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= i__3; --jj) {
jp = ipiv[jj] - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1 */
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
i__6);
} else {
/* The interchange does affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place */
/* Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of DGBTRF */
} /* dgbtrf_ */
/* Subroutine */ int dlagge_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *d__, doublereal *a, integer *lda, integer *iseed,
doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal wa, wb, wn, tau;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *), dlarnv_(integer *, integer *, integer *, doublereal *);
/* -- LAPACK auxiliary test routine (version 3.1) */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAGGE generates a real general m by n matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with random orthogonal matrices: */
/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
/* kl and ku by additional orthogonal transformations. */
/* 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. */
/* KL (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* The number of nonzero superdiagonals within the band of A. */
/* 0 <= KU <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* The generated m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (M+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 arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + i__ * a_dim1] = d__[i__];
/* L30: */
}
/* pre- and post-multiply A by random orthogonal matrices */
for (i__ = min(*m,*n); i__ >= 1; --i__) {
if (i__ < *m) {
/* generate random reflection */
i__1 = *m - i__ + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i__ + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *m - i__;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* multiply A(i:m,i:n) by random reflection from the left */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
dgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1],
lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
d__1 = -tau;
dger_(&i__1, &i__2, &d__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
if (i__ < *n) {
/* generate random reflection */
i__1 = *n - i__ + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i__;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* multiply A(i:m,i:n) by random reflection from the right */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
dgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ *
a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], &
c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
d__1 = -tau;
dger_(&i__1, &i__2, &d__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals */
/* to KU */
/* Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if KL = 0) */
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[*kl + i__ + i__ * a_dim1] + wa;
i__2 = *m - *kl - i__;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
a[*kl + i__ + i__ * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
c__1, &c_b13, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
a[*kl + i__ + i__ * a_dim1] = -wa;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[i__ + (*ku + i__) * a_dim1] + wa;
i__2 = *n - *ku - i__;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
a[i__ + (*ku + i__) * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
a_dim1], lda, &c_b13, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
a[i__ + (*ku + i__) * a_dim1] = -wa;
}
} else {
/* annihilate superdiagonal elements first (necessary if */
/* KU = 0) */
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[i__ + (*ku + i__) * a_dim1] + wa;
i__2 = *n - *ku - i__;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
a[i__ + (*ku + i__) * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
a_dim1], lda, &c_b13, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
a[i__ + (*ku + i__) * a_dim1] = -wa;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[*kl + i__ + i__ * a_dim1] + wa;
i__2 = *m - *kl - i__;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
a[*kl + i__ + i__ * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
c__1, &c_b13, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
a[*kl + i__ + i__ * a_dim1] = -wa;
}
}
i__2 = *m;
for (j = *kl + i__ + 1; j <= i__2; ++j) {
a[j + i__ * a_dim1] = 0.;
/* L50: */
}
i__2 = *n;
for (j = *ku + i__ + 1; j <= i__2; ++j) {
a[i__ + j * a_dim1] = 0.;
/* L60: */
}
/* L70: */
}
return 0;
/* End of DLAGGE */
} /* dlagge_ */
/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
ldb, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DSYTRS solves a system of linear equations A*X = B with a real
symmetric matrix A using the factorization A = U*D*U**T or
A = L*D*L**T computed by DSYTRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**T;
= 'L': Lower triangular, form is A = L*D*L**T.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by DSYTRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSYTRF.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
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
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static doublereal c_b7 = -1.;
static integer c__1 = 1;
static doublereal c_b19 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal akm1k;
static integer j, k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal denom;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dswap_(integer *,
doublereal *, integer *, doublereal *, integer *);
static logical upper;
static doublereal ak, bk;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal akm1, bkm1;
#define IPIV(I) ipiv[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'.
First solve U*D*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformati
on
stored in column K of A. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b7, &A(1,k), &c__1, &B(k,1), ldb, &B(1,1), ldb);
/* Multiply by the inverse of the diagonal block. */
d__1 = 1. / A(k,k);
dscal_(nrhs, &d__1, &B(k,1), ldb);
--k;
} else {
/* 2 x 2 diagonal block
Interchange rows K-1 and -IPIV(K). */
kp = -IPIV(k);
if (kp != k - 1) {
dswap_(nrhs, &B(k-1,1), ldb, &B(kp,1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformati
on
stored in columns K-1 and K of A. */
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &A(1,k), &c__1, &B(k,1), ldb, &B(1,1), ldb);
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &A(1,k-1), &c__1, &B(k-1,1), ldb, &B(1,1), ldb);
/* Multiply by the inverse of the diagonal block. */
akm1k = A(k-1,k);
akm1 = A(k-1,k-1) / akm1k;
ak = A(k,k) / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
bkm1 = B(k-1,j) / akm1k;
bk = B(k,j) / akm1k;
B(k-1,j) = (ak * bkm1 - bk) / denom;
B(k,j) = (akm1 * bk - bkm1) / denom;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Multiply by inv(U'(K)), where U(K) is the transformat
ion
stored in column K of A. */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(1,1), ldb, &A(1,k), &c__1, &c_b19, &B(k,1), ldb);
/* Interchange rows K and IPIV(K). */
kp = IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
++k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(U'(K+1)), where U(K+1) is the transfo
rmation
stored in columns K and K+1 of A. */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(1,1), ldb, &A(1,k), &c__1, &c_b19, &B(k,1), ldb);
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(1,1), ldb, &A(1,k+1), &c__1, &c_b19, &B(k+1,1),
ldb);
/* Interchange rows K and -IPIV(K). */
kp = -IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'.
First solve L*D*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformati
on
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b7, &A(k+1,k), &c__1, &B(k,1), ldb, &B(k+1,1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
d__1 = 1. / A(k,k);
dscal_(nrhs, &d__1, &B(k,1), ldb);
++k;
} else {
/* 2 x 2 diagonal block
Interchange rows K+1 and -IPIV(K). */
kp = -IPIV(k);
if (kp != k + 1) {
dswap_(nrhs, &B(k+1,1), ldb, &B(kp,1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformati
on
stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &A(k+2,k), &c__1, &B(k,1), ldb, &B(k+2,1), ldb);
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &A(k+2,k+1), &c__1,
&B(k+1,1), ldb, &B(k+2,1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
akm1k = A(k+1,k);
akm1 = A(k,k) / akm1k;
ak = A(k+1,k+1) / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
bkm1 = B(k,j) / akm1k;
bk = B(k+1,j) / akm1k;
B(k,j) = (ak * bkm1 - bk) / denom;
B(k+1,j) = (akm1 * bk - bkm1) / denom;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Multiply by inv(L'(K)), where L(K) is the transformat
ion
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(k+1,1),
ldb, &A(k+1,k), &c__1, &c_b19, &B(k,1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
--k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(L'(K-1)), where L(K-1) is the transfo
rmation
stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(k+1,1),
ldb, &A(k+1,k), &c__1, &c_b19, &B(k,1), ldb);
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &B(k+1,1),
ldb, &A(k+1,k-1), &c__1, &c_b19, &B(k-1,1), ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -IPIV(k);
if (kp != k) {
dswap_(nrhs, &B(k,1), ldb, &B(kp,1), ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of DSYTRS */
} /* dsytrs_ */
/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
integer i__, j, km, jp, ju, kv;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGBTF2 computes an LU factorization of a real m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* 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. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U, because of fill-in resulting from the row */
/* interchanges. */
/* ===================================================================== */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab[i__ + j * ab_dim1] = 0.;
}
}
/* JU is the index of the last column affected by the current stage */
/* of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n) {
i__2 = *kl;
for (i__ = 1; i__ <= i__2; ++i__) {
ab[i__ + (j + kv) * ab_dim1] = 0.;
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__2 = *kl, i__3 = *m - j;
km = min(i__2,i__3);
i__2 = km + 1;
jp = idamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
ipiv[j] = jp + j - 1;
if (ab[kv + jp + j * ab_dim1] != 0.) {
/* Computing MAX */
/* Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju, i__3 = min(i__4,*n);
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1) {
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
j * ab_dim1], &i__4);
}
if (km > 0) {
/* Compute multipliers. */
d__1 = 1. / ab[kv + 1 + j * ab_dim1];
dscal_(&km, &d__1, &ab[kv + 2 + j * ab_dim1], &c__1);
/* Update trailing submatrix within the band. */
if (ju > j) {
i__2 = ju - j;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1,
&ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 +
(j + 1) * ab_dim1], &i__4);
}
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = j;
}
}
}
return 0;
/* End of DGBTF2 */
} /* dgbtf2_ */
/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, k, m1;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), 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 *), dlarfg_(
integer *, doublereal *, doublereal *, integer *, doublereal *),
xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DTZRZF. */
/* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
/* to upper triangular form by means of orthogonal transformations. */
/* The upper trapezoidal matrix A is factored as */
/* A = ( R 0 ) * Z, */
/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
/* triangular matrix. */
/* 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 >= M. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements M+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* orthogonal matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which is used to introduce zeros into */
/* the ( m - k + 1 )th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
/* tau and z( k ) are chosen to annihilate the elements of the kth row */
/* of X. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A, such that the elements of z( k ) are */
/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A. */
/* First set up the reflection. */
i__1 = *n - *m + 1;
dlarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
k]);
if (tau[k] != 0. && k > 1) {
/* We now perform the operation A := A*P( k ). */
/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
/* where a( k ) consists of the first ( k - 1 ) elements of */
/* the kth column of A. Also let B denote the first */
/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 +
1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
c__1);
/* Now form a( k ) := a( k ) - tau*w */
/* and B := B - tau*w*z( k )'. */
i__1 = k - 1;
d__1 = -tau[k];
daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d__1 = -tau[k];
dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
, lda, &a[m1 * a_dim1 + 1], lda);
}
/* L20: */
}
}
return 0;
/* End of DTZRQF */
} /* dtzrqf_ */
/*! \brief
*
* <pre>
* Purpose
* =======
* Factor diagonal and subdiagonal blocks and test for exact singularity.
* Only the process column that owns block column *k* participates
* in the work.
*
* Arguments
* =========
*
* k (input) int (global)
* The column number of the block column to be factorized.
*
* thresh (input) double (global)
* The threshold value = s_eps * anorm.
*
* Glu_persist (input) Glu_persist_t*
* Global data structures (xsup, supno) replicated on all processes.
*
* grid (input) gridinfo_t*
* The 2D process mesh.
*
* Llu (input/output) LocalLU_t*
* Local data structures to store distributed L and U matrices.
*
* stat (output) SuperLUStat_t*
* Record the statistics about the factorization.
* See SuperLUStat_t structure defined in util.h.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly singular,
* and division by zero will occur if it is used to solve a
* system of equations.
* </pre>
*/
static void pdgstrf2
/************************************************************************/
(
superlu_options_t *options,
int_t k, double thresh, Glu_persist_t *Glu_persist, gridinfo_t *grid,
LocalLU_t *Llu, SuperLUStat_t *stat, int* info
)
{
int c, iam, l, pkk;
int incx = 1, incy = 1;
int nsupr; /* number of rows in the block (LDA) */
int luptr;
int_t i, krow, j, jfst, jlst;
int_t nsupc; /* number of columns in the block */
int_t *xsup = Glu_persist->xsup;
double *lusup, temp;
double *ujrow;
double alpha = -1;
*info = 0;
/* Quick return. */
/* Initialization. */
iam = grid->iam;
krow = PROW( k, grid );
pkk = PNUM( PROW(k, grid), PCOL(k, grid), grid );
j = LBj( k, grid ); /* Local block number */
jfst = FstBlockC( k );
jlst = FstBlockC( k+1 );
lusup = Llu->Lnzval_bc_ptr[j];
nsupc = SuperSize( k );
if ( Llu->Lrowind_bc_ptr[j] ) nsupr = Llu->Lrowind_bc_ptr[j][1];
ujrow = Llu->ujrow;
luptr = 0; /* Point to the diagonal entries. */
c = nsupc;
for (j = 0; j < jlst - jfst; ++j) {
/* Broadcast the j-th row (nsupc - j) elements to
the process column. */
if ( iam == pkk ) { /* Diagonal process. */
i = luptr;
if ( options->ReplaceTinyPivot == YES || lusup[i] == 0.0 ) {
if ( fabs(lusup[i]) < thresh ) { /* Diagonal */
#if ( PRNTlevel>=2 )
printf("(%d) .. col %d, tiny pivot %e ",
iam, jfst+j, lusup[i]);
#endif
/* Keep the replaced diagonal with the same sign. */
if ( lusup[i] < 0 ) lusup[i] = -thresh;
else lusup[i] = thresh;
#if ( PRNTlevel>=2 )
printf("replaced by %e\n", lusup[i]);
#endif
++(stat->TinyPivots);
}
}
for (l = 0; l < c; ++l, i += nsupr) ujrow[l] = lusup[i];
}
#if 0
dbcast_col(ujrow, c, pkk, UjROW, grid, &c);
#else
MPI_Bcast(ujrow, c, MPI_DOUBLE, krow, (grid->cscp).comm);
/*bcast_tree(ujrow, c, MPI_DOUBLE, krow, (24*k+j)%NTAGS,
grid, COMM_COLUMN, &c);*/
#endif
#if ( DEBUGlevel>=2 )
if ( k == 3329 && j == 2 ) {
if ( iam == pkk ) {
printf("..(%d) k %d, j %d: Send ujrow[0] %e\n",iam,k,j,ujrow[0]);
} else {
printf("..(%d) k %d, j %d: Recv ujrow[0] %e\n",iam,k,j,ujrow[0]);
}
}
#endif
if ( !lusup ) { /* Empty block column. */
--c;
if ( ujrow[0] == 0.0 ) *info = j+jfst+1;
continue;
}
/* Test for singularity. */
if ( ujrow[0] == 0.0 ) {
*info = j+jfst+1;
} else {
/* Scale the j-th column of the matrix. */
temp = 1.0 / ujrow[0];
if ( iam == pkk ) {
for (i = luptr+1; i < luptr-j+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr-j-1;
} else {
for (i = luptr; i < luptr+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr;
}
}
/* Rank-1 update of the trailing submatrix. */
if ( --c ) {
if ( iam == pkk ) {
l = nsupr - j - 1;
#ifdef _CRAY
SGER(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#else
dger_(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#endif
stat->ops[FACT] += 2 * l * c;
} else {
#ifdef _CRAY
SGER(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#else
dger_(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#endif
stat->ops[FACT] += 2 * nsupr * c;
}
}
/* Move to the next column. */
if ( iam == pkk ) luptr += nsupr + 1;
else luptr += nsupr;
} /* for j ... */
} /* PDGSTRF2 */
/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work)
{
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARF applies a real elementary reflector H to a real m by n matrix */
/* C, from either the left or the right. H is represented in the form */
/* H = I - tau * v * v' */
/* where tau is a real scalar and v is a real vector. */
/* If tau = 0, then H is taken to be the unit matrix. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) DOUBLE PRECISION array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. V is not used if */
/* TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (*tau != 0.) {
/* w := C' * v */
dgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
&c_b5, &work[1], &c__1);
/* C := C - v * w' */
d__1 = -(*tau);
dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (*tau != 0.) {
/* w := C * v */
dgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
incv, &c_b5, &work[1], &c__1);
/* C := C - w * v' */
d__1 = -(*tau);
dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of DLARF */
} /* dlarf_ */
/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
DGETF2 computes an LU factorization of a general m-by-n matrix A
using partial pivoting with row interchanges.
The factorization has the form
A = P * L * U
where P is a permutation matrix, L is lower triangular with unit
diagonal elements (lower trapezoidal if m > n), and U is upper
triangular (upper trapezoidal if m < n).
This is the right-looking Level 2 BLAS version of the algorithm.
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/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the m by n matrix to be factored.
On exit, the factors L and U from the factorization
A = P*L*U; the unit diagonal elements of L are not stored.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, U(k,k) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, and division by zero will occur if it is used
to solve a system of equations.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b6 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dswap_(integer *, doublereal *, integer *, doublereal
*, integer *);
static integer jp;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a_ref(j, j), &c__1);
ipiv[j] = jp;
if (a_ref(jp, j) != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
dswap_(n, &a_ref(j, 1), lda, &a_ref(jp, 1), lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
i__2 = *m - j;
d__1 = 1. / a_ref(j, j);
dscal_(&i__2, &d__1, &a_ref(j + 1, j), &c__1);
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
dger_(&i__2, &i__3, &c_b6, &a_ref(j + 1, j), &c__1, &a_ref(j, j +
1), lda, &a_ref(j + 1, j + 1), lda);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* dgetf2_ */
/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer
*ipiv, integer *jpiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer i__, j, ip, jp;
static doublereal eps;
static integer ipv, jpv;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal smin, xmax;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
static doublereal bignum, smlnum;
/* -- 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 */
/* ======= */
/* DGETC2 computes an LU factorization with complete pivoting of the */
/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
/* where P and Q are permutation matrices, L is lower triangular with */
/* unit diagonal elements and U is upper triangular. */
/* This is the Level 2 BLAS algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the n-by-n matrix A to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
/* value of SMIN, i.e., giving a nonsingular perturbed system. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension(N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (output) INTEGER array, dimension(N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */
/* we try to solve for x in Ax = b. So U is perturbed to */
/* avoid the overflow. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constants to control overflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--jpiv;
/* Function Body */
*info = 0;
eps = dlamch_("P", (ftnlen)1);
smlnum = dlamch_("S", (ftnlen)1) / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Factorize A using complete pivoting. */
/* Set pivots less than SMIN to SMIN. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Find max element in matrix A */
xmax = 0.;
i__2 = *n;
for (ip = i__; ip <= i__2; ++ip) {
i__3 = *n;
for (jp = i__; jp <= i__3; ++jp) {
if ((d__1 = a[ip + jp * a_dim1], abs(d__1)) >= xmax) {
xmax = (d__1 = a[ip + jp * a_dim1], abs(d__1));
ipv = ip;
jpv = jp;
}
/* L10: */
}
/* L20: */
}
if (i__ == 1) {
/* Computing MAX */
d__1 = eps * xmax;
smin = max(d__1,smlnum);
}
/* Swap rows */
if (ipv != i__) {
dswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
}
ipiv[i__] = ipv;
/* Swap columns */
if (jpv != i__) {
dswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
}
jpiv[i__] = jpv;
/* Check for singularity */
if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) < smin) {
*info = i__;
a[i__ + i__ * a_dim1] = smin;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1];
/* L30: */
}
i__2 = *n - i__;
i__3 = *n - i__;
dger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__
+ (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda);
/* L40: */
}
if ((d__1 = a[*n + *n * a_dim1], abs(d__1)) < smin) {
*info = *n;
a[*n + *n * a_dim1] = smin;
}
return 0;
/* End of DGETC2 */
} /* dgetc2_ */
/* Subroutine */ int dlavsp_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *ipiv, doublereal *b, integer *
ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
integer j, k;
doublereal t1, t2, d11, d12, d21, d22;
integer kc, kp;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *, integer
*);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dswap_(integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
integer *);
integer kcnext;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAVSP performs one of the matrix-vector operations */
/* x := A*x or x := A'*x, */
/* where x is an N element vector and A is one of the factors */
/* from the block U*D*U' or L*D*L' factorization computed by DSPTRF. */
/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' ) */
/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' ) */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the factor stored in A is upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation to be performed: */
/* = 'N': x := A*x */
/* = 'T': x := A'*x */
/* = 'C': x := A'*x */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the diagonal blocks are unit */
/* matrices. If the diagonal blocks are assumed to be unit, */
/* then A = U or A = L, otherwise A = U*D or A = L*D. */
/* = 'U': Diagonal blocks are assumed to be unit matrices. */
/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of vectors */
/* x to be multiplied by A. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L, stored as a packed triangular */
/* matrix as computed by DSPTRF. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DSPTRF. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, B contains NRHS vectors of length N. */
/* On exit, B is overwritten with the product A * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= 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;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
*info = -2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAVSP ", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N");
/* ------------------------------------------ */
/* Compute B := A * B (No transpose) */
/* ------------------------------------------ */
if (lsame_(trans, "N")) {
/* Compute B := U*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
if (lsame_(uplo, "U")) {
/* Loop forward applying the transformations. */
k = 1;
kc = 1;
L10:
if (k > *n) {
goto L30;
}
/* 1 x 1 pivot block */
if (ipiv[k] > 0) {
/* Multiply by the diagonal element if forming U * D. */
if (nounit) {
dscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformation. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
ldb, &b[b_dim1 + 1], ldb);
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc += k;
++k;
} else {
/* 2 x 2 pivot block */
kcnext = kc + k;
/* Multiply by the diagonal block if forming U * D. */
if (nounit) {
d11 = a[kcnext - 1];
d22 = a[kcnext + k];
d12 = a[kcnext + k - 1];
d21 = d12;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k + j * b_dim1];
t2 = b[k + 1 + j * b_dim1];
b[k + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
/* L20: */
}
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformations. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[kcnext], &c__1, &b[k + 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc = kcnext + k + 1;
k += 2;
}
goto L10;
L30:
/* Compute B := L*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
;
} else {
/* Loop backward applying the transformations to B. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L40:
if (k < 1) {
goto L60;
}
kc -= *n - k + 1;
/* Test the pivot index. If greater than zero, a 1 x 1 */
/* pivot was used, otherwise a 2 x 2 pivot was used. */
if (ipiv[k] > 0) {
/* 1 x 1 pivot block: */
/* Multiply by the diagonal element if forming L * D. */
if (nounit) {
dscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
kp = ipiv[k];
/* Apply the transformation. */
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
--k;
} else {
/* 2 x 2 pivot block: */
kcnext = kc - (*n - k + 2);
/* Multiply by the diagonal block if forming L * D. */
if (nounit) {
d11 = a[kcnext];
d22 = a[kc];
d21 = a[kcnext + 1];
d12 = d21;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k - 1 + j * b_dim1];
t2 = b[k + j * b_dim1];
b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + j * b_dim1] = d21 * t1 + d22 * t2;
/* L50: */
}
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
/* Apply the transformation. */
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[kcnext + 2], &c__1, &b[k -
1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc = kcnext;
k += -2;
}
goto L40;
L60:
;
}
/* ---------------------------------------- */
/* Compute B := A' * B (transpose) */
/* ---------------------------------------- */
} else {
/* Form B := U'*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
if (lsame_(uplo, "U")) {
/* Loop backward applying the transformations. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L70:
if (k < 1) {
goto L90;
}
kc -= k;
/* 1 x 1 pivot block. */
if (ipiv[k] > 0) {
if (k > 1) {
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
}
if (nounit) {
dscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
}
--k;
/* 2 x 2 pivot block. */
} else {
kcnext = kc - (k - 1);
if (k > 2) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k - 1) {
dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformations */
i__1 = k - 2;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
i__1 = k - 2;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[kcnext], &c__1, &c_b15, &b[k - 1 + b_dim1]
, ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
d11 = a[kc - 1];
d22 = a[kc + k - 1];
d12 = a[kc + k - 2];
d21 = d12;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k - 1 + j * b_dim1];
t2 = b[k + j * b_dim1];
b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + j * b_dim1] = d21 * t1 + d22 * t2;
/* L80: */
}
}
kc = kcnext;
k += -2;
}
goto L70;
L90:
/* Form B := L'*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
/* and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
;
} else {
/* Loop forward applying the L-transformations. */
k = 1;
kc = 1;
L100:
if (k > *n) {
goto L120;
}
/* 1 x 1 pivot block */
if (ipiv[k] > 0) {
if (k < *n) {
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
b_dim1], ldb, &a[kc + 1], &c__1, &c_b15, &b[k +
b_dim1], ldb);
}
if (nounit) {
dscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
}
kc = kc + *n - k + 1;
++k;
/* 2 x 2 pivot block. */
} else {
kcnext = kc + *n - k + 1;
if (k < *n - 1) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k + 1) {
dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
b_dim1], ldb, &a[kcnext + 1], &c__1, &c_b15, &b[k
+ 1 + b_dim1], ldb);
i__1 = *n - k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
b_dim1], ldb, &a[kc + 2], &c__1, &c_b15, &b[k +
b_dim1], ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
d11 = a[kc];
d22 = a[kcnext];
d21 = a[kc + 1];
d12 = d21;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k + j * b_dim1];
t2 = b[k + 1 + j * b_dim1];
b[k + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
/* L110: */
}
}
kc = kcnext + (*n - k);
k += 2;
}
goto L100;
L120:
;
}
}
return 0;
/* End of DLAVSP */
} /* dlavsp_ */
/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv,
doublereal *b, integer *ldb, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, l, kd, lm;
logical lnoti;
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGBTRS solves a system of linear equations */
/* A * X = B or A' * X = B */
/* with a general band matrix A using the LU factorization computed */
/* by DGBTRF. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A'* X = B (Transpose) */
/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by DGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
kd = *ku + *kl + 1;
lnoti = *kl > 0;
if (notran) {
/* Solve A*X = B. */
/* Solve L*X = B, overwriting B with X. */
/* L is represented as a product of permutations and unit lower */
/* where each transformation L(i) is a rank-one modification of */
/* the identity matrix. */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
l = ipiv[j];
if (l != j) {
dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
dger_(&lm, nrhs, &c_b7, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
}
}
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
}
} else {
/* Solve A'*X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U'*X = B, overwriting B with X. */
i__2 = *kl + *ku;
dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
ldab, &b[i__ * b_dim1 + 1], &c__1);
}
/* Solve L'*X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
dgemv_("Transpose", &lm, nrhs, &c_b7, &b[j + 1 + b_dim1], ldb,
&ab[kd + 1 + j * ab_dim1], &c__1, &c_b23, &b[j +
b_dim1], ldb);
l = ipiv[j];
if (l != j) {
dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
}
}
}
return 0;
/* End of DGBTRS */
} /* dgbtrs_ */
/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l,
doublereal *v, integer *incv, doublereal *tau, doublereal *c__,
integer *ldc, doublereal *work)
{
/* -- LAPACK 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
=======
DLARZ applies a real elementary reflector H to a real M-by-N
matrix C, from either the left or the right. H is represented in the
form
H = I - tau * v * v'
where tau is a real scalar and v is a real vector.
If tau = 0, then H is taken to be the unit matrix.
H is a product of k elementary reflectors as returned by DTZRZF.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': form H * C
= 'R': form C * H
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
L (input) INTEGER
The number of entries of the vector V containing
the meaningful part of the Householder vectors.
If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
The vector v in the representation of H as returned by
DTZRZF. V is not used if TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0.
TAU (input) DOUBLE PRECISION
The value tau in the representation of H.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by the matrix H * C if SIDE = 'L',
or C * H if SIDE = 'R'.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) DOUBLE PRECISION array, dimension
(N) if SIDE = 'L'
or (M) if SIDE = 'R'
Further Details
===============
Based on contributions by
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b5 = 1.;
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
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 *)
;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (*tau != 0.) {
/* w( 1:n ) = C( 1, 1:n ) */
dcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */
dgemv_("Transpose", l, n, &c_b5, &c___ref(*m - *l + 1, 1), ldc, &
v[1], incv, &c_b5, &work[1], &c__1);
/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
d__1 = -(*tau);
daxpy_(n, &d__1, &work[1], &c__1, &c__[c_offset], ldc);
/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
tau * v( 1:l ) * w( 1:n )' */
d__1 = -(*tau);
dger_(l, n, &d__1, &v[1], incv, &work[1], &c__1, &c___ref(*m - *l
+ 1, 1), ldc);
}
} else {
/* Form C * H */
if (*tau != 0.) {
/* w( 1:m ) = C( 1:m, 1 ) */
dcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
dgemv_("No transpose", m, l, &c_b5, &c___ref(1, *n - *l + 1), ldc,
&v[1], incv, &c_b5, &work[1], &c__1);
/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
d__1 = -(*tau);
daxpy_(m, &d__1, &work[1], &c__1, &c__[c_offset], &c__1);
/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
tau * w( 1:m ) * v( 1:l )' */
d__1 = -(*tau);
dger_(m, l, &d__1, &work[1], &c__1, &v[1], incv, &c___ref(1, *n -
*l + 1), ldc);
}
}
return 0;
/* End of DLARZ */
} /* dlarz_ */
static void pdgstrf2
/************************************************************************/
(
superlu_options_t *options,
int_t k, double thresh, Glu_persist_t *Glu_persist, gridinfo_t *grid,
LocalLU_t *Llu, MPI_Request *U_diag_blk_send_req,
SuperLUStat_t *stat, int* info
)
/*
* Purpose
* =======
*
* Panel factorization -- block column k
* Factor diagonal and subdiagonal blocks and test for exact singularity.
* Only the column processes that owns block column *k* participate
* in the work.
*
* Arguments
* =========
*
* k (input) int (global)
* The column number of the block column to be factorized.
*
* thresh (input) double (global)
* The threshold value = s_eps * anorm.
*
* Glu_persist (input) Glu_persist_t*
* Global data structures (xsup, supno) replicated on all processes.
*
* grid (input) gridinfo_t*
* The 2D process mesh.
*
* Llu (input/output) LocalLU_t*
* Local data structures to store distributed L and U matrices.
*
* U_diag_blk_send_req (input/output) MPI_Request*
* List of send requests to send down the diagonal block of U.
*
* stat (output) SuperLUStat_t*
* Record the statistics about the factorization.
* See SuperLUStat_t structure defined in util.h.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly singular,
* and division by zero will occur if it is used to solve a
* system of equations.
*
*/
{
int cols_left, iam, l, pkk, pr;
int incx = 1, incy = 1;
int nsupr; /* number of rows in the block (LDA) */
int luptr;
int_t i, krow, j, jfst, jlst, u_diag_cnt;
int_t nsupc; /* number of columns in the block */
int_t *xsup = Glu_persist->xsup;
int_t Pr;
MPI_Status status;
MPI_Comm comm = (grid->cscp).comm;
double *lusup, temp;
double *ujrow, *ublk_ptr; /* pointer to the U block */
double alpha = -1;
*info = 0;
/* Quick return. */
/* Initialization. */
iam = grid->iam;
Pr = grid->nprow;
krow = PROW( k, grid );
pkk = PNUM( PROW(k, grid), PCOL(k, grid), grid );
j = LBj( k, grid ); /* Local block number */
jfst = FstBlockC( k );
jlst = FstBlockC( k+1 );
lusup = Llu->Lnzval_bc_ptr[j];
nsupc = SuperSize( k );
if ( Llu->Lrowind_bc_ptr[j] ) nsupr = Llu->Lrowind_bc_ptr[j][1];
ublk_ptr = ujrow = Llu->ujrow;
luptr = 0; /* point to the diagonal entries. */
cols_left = nsupc; /* supernode size */
u_diag_cnt = 0;
if ( iam == pkk ) { /* diagonal process */
if ( U_diag_blk_send_req && U_diag_blk_send_req[krow] ) {
/* There are pending sends - wait for all Isend to complete */
for (pr = 0; pr < Pr; ++pr)
if (pr != krow)
MPI_Wait(U_diag_blk_send_req + pr, &status);
}
for (j = 0; j < jlst - jfst; ++j) { /* for each column in panel */
/* Diagonal pivot */
i = luptr;
if ( options->ReplaceTinyPivot == YES || lusup[i] == 0.0 ) {
if ( fabs(lusup[i]) < thresh ) {
#if ( PRNTlevel>=2 )
printf("(%d) .. col %d, tiny pivot %e ",
iam, jfst+j, lusup[i]);
#endif
/* Keep the new diagonal entry with the same sign. */
if ( lusup[i] < 0 ) lusup[i] = -thresh;
else lusup[i] = thresh;
#if ( PRNTlevel>=2 )
printf("replaced by %e\n", lusup[i]);
#endif
++(stat->TinyPivots);
}
}
for (l = 0; l < cols_left; ++l, i += nsupr, ++u_diag_cnt)
ublk_ptr[u_diag_cnt] = lusup[i]; /* copy one row of U */
if ( ujrow[0] == 0.0 ) { /* Test for singularity. */
*info = j+jfst+1;
} else { /* Scale the j-th column. */
temp = 1.0 / ujrow[0];
for (i = luptr+1; i < luptr-j+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr-j-1;
}
/* Rank-1 update of the trailing submatrix. */
if ( --cols_left ) {
l = nsupr - j - 1;
#ifdef _CRAY
SGER(&l, &cols_left, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#else
dger_(&l, &cols_left, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#endif
stat->ops[FACT] += 2 * l * cols_left;
}
ujrow = ublk_ptr + u_diag_cnt; /* move to next row of U */
luptr += nsupr + 1; /* move to next column */
} /* for column j ... */
if ( U_diag_blk_send_req && iam == pkk ) { /* Send the U block */
/** ALWAYS SEND TO ALL OTHERS - TO FIX **/
for (pr = 0; pr < Pr; ++pr)
if (pr != krow)
MPI_Isend(ublk_ptr, u_diag_cnt, MPI_DOUBLE, pr,
((k<<2)+2)%NTAGS, comm, U_diag_blk_send_req + pr);
U_diag_blk_send_req[krow] = 1; /* flag outstanding Isend */
}
} else { /* non-diagonal process */
/* Receive the diagonal block of U */
MPI_Recv(ublk_ptr, (nsupc*(nsupc+1))>>1, MPI_DOUBLE,
krow, ((k<<2)+2)%NTAGS, comm, &status);
for (j = 0; j < jlst - jfst; ++j) { /* for each column in panel */
u_diag_cnt += cols_left;
if ( !lusup ) { /* empty block column */
--cols_left;
if ( ujrow[0] == 0.0 ) *info = j+jfst+1;
continue;
}
/* Test for singularity. */
if ( ujrow[0] == 0.0 ) {
*info = j+jfst+1;
} else {
/* Scale the j-th column. */
temp = 1.0 / ujrow[0];
for (i = luptr; i < luptr+nsupr; ++i) lusup[i] *= temp;
stat->ops[FACT] += nsupr;
}
/* Rank-1 update of the trailing submatrix. */
if ( --cols_left ) {
#ifdef _CRAY
SGER(&nsupr, &cols_left, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#else
dger_(&nsupr, &cols_left, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#endif
stat->ops[FACT] += 2 * nsupr * cols_left;
}
ujrow = ublk_ptr + u_diag_cnt; /* move to next row of U */
luptr += nsupr; /* move to next column */
} /* for column j ... */
} /* end if pkk ... */
} /* PDGSTRF2 */
/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work)
{
/* -- 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
=======
DLARF applies a real elementary reflector H to a real m by n matrix
C, from either the left or the right. H is represented in the form
H = I - tau * v * v'
where tau is a real scalar and v is a real vector.
If tau = 0, then H is taken to be the unit matrix.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': form H * C
= 'R': form C * H
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
V (input) DOUBLE PRECISION array, dimension
(1 + (M-1)*abs(INCV)) if SIDE = 'L'
or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
The vector v in the representation of H. V is not used if
TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0.
TAU (input) DOUBLE PRECISION
The value tau in the representation of H.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the m by n matrix C.
On exit, C is overwritten by the matrix H * C if SIDE = 'L',
or C * H if SIDE = 'R'.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) DOUBLE PRECISION array, dimension
(N) if SIDE = 'L'
or (M) if SIDE = 'R'
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublereal c_b4 = 1.;
static doublereal c_b5 = 0.;
static integer c__1 = 1;
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (*tau != 0.) {
/* w := C' * v */
dgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
&c_b5, &work[1], &c__1);
/* C := C - v * w' */
d__1 = -(*tau);
dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (*tau != 0.) {
/* w := C * v */
dgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
incv, &c_b5, &work[1], &c__1);
/* C := C - w * v' */
d__1 = -(*tau);
dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of DLARF */
} /* dlarf_ */
/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n,
doublereal *a, integer *lda, integer *iseed, doublereal *x, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
static integer kbeg;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jcol, irow;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static integer ixfrm, itype, nxfrm;
static doublereal xnorm;
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal factor, xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DLAROR pre- or post-multiplies an M by N matrix A by a random
orthogonal matrix U, overwriting A. A may optionally be initialized
to the identity matrix before multiplying by U. U is generated using
the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
Arguments
=========
SIDE (input) CHARACTER*1
Specifies whether A is multiplied on the left or right by U.
= 'L': Multiply A on the left (premultiply) by U
= 'R': Multiply A on the right (postmultiply) by U'
= 'C' or 'T': Multiply A on the left by U and the right
by U' (Here, U' means U-transpose.)
INIT (input) CHARACTER*1
Specifies whether or not A should be initialized to the
identity matrix.
= 'I': Initialize A to (a section of) the identity matrix
before applying U.
= 'N': No initialization. Apply U to the input matrix A.
INIT = 'I' may be used to generate square or rectangular
orthogonal matrices:
For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
to each other, as will the columns.
If M < N, SIDE = 'R' produces a dense matrix whose rows are
orthogonal and whose columns are not, while SIDE = 'L'
produces a matrix whose rows are orthogonal, and whose first
M columns are orthogonal, and whose remaining columns are
zero.
If M > N, SIDE = 'L' produces a dense matrix whose columns
are orthogonal and whose rows are not, while SIDE = 'R'
produces a matrix whose columns are orthogonal, and whose
first M rows are orthogonal, and whose remaining rows are
zero.
M (input) INTEGER
The number of rows of A.
N (input) INTEGER
The number of columns of A.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the array A.
On exit, overwritten by U A ( if SIDE = 'L' ),
or by A U ( if SIDE = 'R' ),
or by U A U' ( if SIDE = 'C' or 'T').
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DLAROR to continue the same random number
sequence.
X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N ))
Workspace of length
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
INFO (output) INTEGER
An error flag. It is set to:
= 0: normal return
< 0: if INFO = -k, the k-th argument had an illegal value
= 1: if the random numbers generated by DLARND are bad.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (lsame_(side, "L")) {
itype = 1;
} else if (lsame_(side, "R")) {
itype = 2;
} else if (lsame_(side, "C") || lsame_(side, "T")) {
itype = 3;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (lsame_(init, "I")) {
dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
}
/* If no rotation possible, multiply by random +/-1
Compute rotation by computing Householder transformations
H(2), H(3), ..., H(nhouse) */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
x[j] = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
x[j] = dlarnd_(&c__3, &iseed[1]);
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1);
xnorms = d_sign(&xnorm, &x[kbeg]);
d__1 = -x[kbeg];
x[kbeg + nxfrm] = d_sign(&c_b10, &d__1);
factor = xnorms * (xnorms + x[kbeg]);
if (abs(factor) < 1e-20) {
*info = 1;
xerbla_("DLAROR", info);
return 0;
} else {
factor = 1. / factor;
}
x[kbeg] += xnorms;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3) {
/* Apply H(k) from the left. */
dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype == 2 || itype == 3) {
/* Apply H(k) from the right. */
dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
d__1 = dlarnd_(&c__3, &iseed[1]);
x[nxfrm * 2] = d_sign(&c_b10, &d__1);
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
return 0;
/* End of DLAROR */
} /* dlaror_ */
/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *, integer
*);
doublereal sfmin;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int 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 */
/* ======= */
/* DGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* 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/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = dlamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
i__2 = *m - j;
d__1 = 1. / a[j + j * a_dim1];
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* dgetf2_ */
