void dgetrs( char trans, long n, long nrhs, double a[], long lda,
long ipiv[], double b[], long ldb, long *info )
{
/**
* -- LAPACK routine (version 1.1) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..*/
/** ..
* .. Array Arguments ..*/
#undef ipiv_1
#define ipiv_1(a1) ipiv[a1-1]
#undef b_2
#define b_2(a1,a2) b[a1-1+ldb*(a2-1)]
#undef a_2
#define a_2(a1,a2) a[a1-1+lda*(a2-1)]
/** ..
*
* Purpose
* =======
*
* DGETRS solves a system of linear equations
* A * X = B or A' * X = B
* with a general N-by-N matrix A using the LU factorization computed
* by DGETRF.
*
* 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.
*
* 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 factors L and U from the factorization A = P*L*U
* as computed by DGETRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DGETRF; 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
*
* =====================================================================
*
* .. Parameters ..*/
#undef one
#define one 1.0e+0
/** ..
* .. Local Scalars ..*/
int notran;
/** ..
* .. Intrinsic Functions ..*/
/* intrinsic max;*/
/** ..
* .. Executable Statements ..
*
* Test the input parameters.
**/
/*-----implicit-declarations-----*/
/*-----end-of-declarations-----*/
*info = 0;
notran = lsame( trans, 'n' );
if( !notran && !lsame( trans, 't' ) && !
lsame( trans, 'c' ) ) {
*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 ) {
xerbla( "dgetrs", -*info );
return;
}
/**
* Quick return if possible
**/
if( n==0 || nrhs==0 )
return;
if( notran ) {
/**
* Solve A * X = B.
*
* Apply row interchanges to the right hand sides.
**/
dlaswp( nrhs, b, ldb, 1, n, ipiv, 1 );
/**
* Solve L*X = B, overwriting B with X.
**/
cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans,
CblasUnit, n, nrhs, one, a, lda, b, ldb );
/**
* Solve U*X = B, overwriting B with X.
**/
cblas_dtrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans,
CblasNonUnit, n, nrhs, one, a, lda, b, ldb );
} else {
/**
* Solve A' * X = B.
*
* Solve U'*X = B, overwriting B with X.
**/
cblas_dtrsm(CblasColMajor, CblasLeft, CblasUpper, CblasTrans,
CblasNonUnit, n, nrhs, one, a, lda, b, ldb );
/**
* Solve L'*X = B, overwriting B with X.
**/
cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasTrans,
CblasUnit, n, nrhs, one, a, lda, b, ldb );
/**
* Apply row interchanges to the solution vectors.
**/
dlaswp( nrhs, b, ldb, 1, n, ipiv, -1 );
}
return;
/**
* End of DGETRS
**/
}
void chseqr(char *job, char *compz, int n__, int ilo,
int ihi, fcomplex *h, int ldh, fcomplex *w, fcomplex *z,
int ldz, fcomplex *work, int lwork, int *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
=======
CHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace) COMPLEX array, dimension (N)
LWORK (input) INTEGER
This argument is currently redundant.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static fcomplex c_b1 = {0.f,0.f};
static fcomplex c_b2 = {1.f,0.f};
static int c__1 = 1;
static int c__4 = 4;
static int c_n1 = -1;
static int c__2 = 2;
static int c__8 = 8;
static int c__15 = 15;
static int c_false = FALSE;
/* System generated locals */
char* a__1[2];
int h_dim1, i__1, i__2, i__3, i__4[2],
i__5, i__6;
float r__1, r__2, r__3, r__4;
double d__1;
fcomplex q__1;
char ch__1[2];
/* Builtin functions */
/* Local variables */
static int maxb, ierr;
static float unfl;
static fcomplex temp;
static float ovfl;
static int i, j, k, l;
static fcomplex s[225] /* was [15][15] */;
static fcomplex v[16];
static int itemp;
static float rtemp;
static int i1, i2;
static int initz, wantt, wantz;
static float rwork[1];
static int ii, nh;
static int nr, ns;
static int nv;
static fcomplex vv[16];
static float smlnum;
static int itn;
static fcomplex tau;
static int its;
static float ulp, tst1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define H(I,J) h[(I)-1 + ((J)-1)* ( ldh)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( ldz)]
h_dim1 = ldh;
wantt = lsame(job, "S");
initz = lsame(compz, "I");
wantz = initz || lsame(compz, "V");
*info = 0;
if (! lsame(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame(compz, "N") && ! wantz) {
*info = -2;
} else if (n__ < 0) {
*info = -3;
} else if (ilo < 1 || ilo > max(1,n__)) {
*info = -4;
} else if (ihi < min(ilo,n__) || ihi > n__) {
*info = -5;
} else if (ldh < max(1,n__)) {
*info = -7;
} else if (ldz < 1 || (wantz && ldz < max(1,n__))) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
return ;
}
/* Initialize Z, if necessary */
if (initz) {
claset("Full", n__, n__, c_b1, c_b2, &Z(1,1), ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = ilo - 1;
for (i = 1; i <= ilo-1; ++i) {
i__2 = i;
i__3 = i + i * h_dim1;
W(i).r = H(i,i).r, W(i).i = H(i,i).i;
}
i__1 = n__;
for (i = ihi + 1; i <= n__; ++i) {
i__2 = i;
i__3 = i + i * h_dim1;
W(i).r = H(i,i).r, W(i).i = H(i,i).i;
}
/* Quick return if possible. */
if (n__ == 0) {
return ;
}
if (ilo == ihi) {
i__1 = ilo;
i__2 = ilo + ilo * h_dim1;
W(ilo).r = H(ilo,ilo).r, W(ilo).i = H(ilo,ilo).i;
return ;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = ihi - 2;
for (j = ilo; j <= ihi-2; ++j) {
i__2 = n__;
for (i = j + 2; i <= n__; ++i) {
i__3 = i + j * h_dim1;
H(i,j).r = 0.f, H(i,j).i = 0.f;
}
}
nh = ihi - ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = n__;
} else {
i1 = ilo;
i2 = ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = ihi;
for (i = ilo + 1; i <= ihi; ++i) {
i__2 = i + (i - 1) * h_dim1;
temp.r = H(i,i-1).r, temp.i = H(i,i-1).i;
if (temp.i != 0.f) {
r__1 = temp.r;
r__2 = temp.i;
rtemp = slapy2(r__1, r__2);
i__2 = i + (i - 1) * h_dim1;
H(i,i-1).r = rtemp, H(i,i-1).i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i) {
i__2 = i2 - i;
r_cnjg(&q__1, &temp);
cscal(i__2, q__1, &H(i,i+1), ldh);
}
i__2 = i - i1;
cscal(i__2, temp, &H(i1,i), c__1);
if (i < ihi) {
i__2 = i + 1 + i * h_dim1;
i__3 = i + 1 + i * h_dim1;
q__1.r = temp.r * H(i+1,i).r - temp.i * H(i+1,i).i, q__1.i =
temp.r * H(i+1,i).i + temp.i * H(i+1,i).r;
H(i+1,i).r = q__1.r, H(i+1,i).i = q__1.i;
}
if (wantz) {
cscal(nh, temp, &Z(ilo,i), c__1);
}
}
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
ns = ilaenv(c__4, "CHSEQR", ch__1, n__, ilo, ihi, c_n1, 6L, 2L);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
maxb = ilaenv(c__8, "CHSEQR", ch__1, n__, ilo, ihi, c_n1, 6L, 2L);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr(wantt, wantz, n__, ilo, ihi, &H(1,1), ldh, &W(1), ilo,
ihi, &Z(1,1), ldz, info);
return ;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch("Safe minimum");
ovfl = 1.f / unfl;
slabad(&unfl, &ovfl);
ulp = slamch("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i = ihi;
L60:
if (i < ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = ilo;
i__1 = itn;
for (its = 0; its <= itn; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i; k >= l+1; --k) {
i__3 = k - 1 + (k - 1) * h_dim1;
i__5 = k + k * h_dim1;
tst1 = (r__1 = H(k-1,k-1).r, fabs(r__1)) + (r__2 = H(k-1,k-1).i, fabs(r__2)) + ((r__3 = H(k,k).r,
fabs(r__3)) + (r__4 = H(k,k).i, fabs(
r__4)));
if (tst1 == 0.f) {
i__3 = i - l + 1;
tst1 = clanhs("1", i__3, &H(l,l), ldh, rwork);
}
i__3 = k + (k - 1) * h_dim1;
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = H(k,k-1).r, fabs(r__1)) <= max(r__2,smlnum)) {
goto L80;
}
}
L80:
l = k;
if (l > ilo) {
/* H(L,L-1) is negligible. */
i__2 = l + (l - 1) * h_dim1;
H(l,l-1).r = 0.f, H(l,l-1).i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i;
for (ii = i - ns + 1; ii <= i; ++ii) {
i__3 = ii;
i__5 = ii + (ii - 1) * h_dim1;
i__6 = ii + ii * h_dim1;
d__1 = ((r__1 = H(ii,ii-1).r, fabs(r__1)) + (r__2 = H(ii,ii).r,
fabs(r__2))) * 1.5f;
W(ii).r = d__1, W(ii).i = 0.f;
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy("Full", ns, ns, &H(i-ns+1,i-ns+1),
ldh, s, c__15);
clahqr(c_false, c_false, ns, c__1, ns, s, c__15, &W(i - ns
+ 1), c__1, ns, &Z(1,1), ldz, &ierr);
if (ierr > 0) {
/* If CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= ierr; ++ii) {
i__3 = i - ns + ii;
i__5 = ii + ii * 15 - 16;
W(i-ns+ii).r = s[ii+ii*15-16].r, W(i-ns+ii).i = s[ii+ii*15-16].i;
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= ns+1; ++ii) {
i__3 = ii - 1;
v[ii-1].r = 0.f, v[ii-1].i = 0.f;
}
nv = 1;
i__2 = i;
for (j = i - ns + 1; j <= i; ++j) {
i__3 = nv + 1;
ccopy(i__3, v,c__1, vv, c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -(double)W(j).r, q__1.i = -(double)W(j).i;
cgemv("No transpose", i__3, nv, c_b2, &H(l,l), ldh,
vv, c__1, q__1, v, c__1);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax(nv, v, c__1);
i__3 = itemp - 1;
rtemp = (r__1 = v[itemp-1].r, fabs(r__1)) + (r__2 = v[itemp
- 1].i, fabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= nv; ++ii) {
i__5 = ii - 1;
v[ii-1].r = 0.f, v[ii-1].i = 0.f;
}
} else {
rtemp = max(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal(nv, r__1, v, c__1);
}
}
/* Multiple-shift QR step */
i__2 = i - 1;
for (k = l; k <= i-1; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy(nr, &H(k,k-1), c__1, v, c__1);
}
clarfg(nr, v, &v[1], c__1, &tau);
if (k > l) {
i__3 = k + (k - 1) * h_dim1;
H(k,k-1).r = v[0].r, H(k,k-1).i = v[0].i;
i__3 = i;
for (ii = k + 1; ii <= i; ++ii) {
i__5 = ii + (k - 1) * h_dim1;
H(ii,k-1).r = 0.f, H(ii,k-1).i = 0.f;
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx("Left", nr, i__3, v, q__1, &H(k,k), ldh, &
WORK(1));
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i) - i1 + 1;
clarfx("Right", i__3, nr, v, tau, &H(i1,k), ldh, &
WORK(1));
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx("Right", nh, nr, v, tau, &Z(ilo,k),
ldz, &WORK(1));
}
}
/* Ensure that H(I,I-1) is real. */
i__2 = i + (i - 1) * h_dim1;
temp.r = H(i,i-1).r, temp.i = H(i,i-1).i;
if (temp.i != 0.f) {
r__1 = temp.r;
r__2 = temp.i;
rtemp = slapy2(r__1, r__2);
i__2 = i + (i - 1) * h_dim1;
H(i,i-1).r = rtemp, H(i,i-1).i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i) {
i__2 = i2 - i;
r_cnjg(&q__1, &temp);
cscal(i__2, q__1, &H(i,i+1), ldh);
}
i__2 = i - i1;
cscal(i__2, temp, &H(i1,i), c__1);
if (wantz) {
cscal(nh, temp, &Z(ilo,i), c__1);
}
}
}
/* Failure to converge in remaining number of iterations */
*info = i;
return ;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
clahqr(wantt, wantz, n__, l, i, &H(1,1), ldh, &W(1), ilo, ihi,
&Z(1,1), ldz, info);
if (*info > 0) {
return ;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i = l - 1;
goto L60;
L180:
return ;
}
void clascl(char *type, int kl_, int ku_, float cfrom, float cto,
int m__, int n__, fcomplex *a, int lda, int *info)
{
/* -- LAPACK auxiliary 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
=======
CLASCL multiplies the M by N complex matrix A by the real scalar
CTO/CFROM. This is done without over/underflow as long as the final
result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
A may be full, upper triangular, lower triangular, upper Hessenberg,
or banded.
Arguments
=========
TYPE (input) CHARACTER*1
TYPE indices the storage type of the input matrix.
= 'G': A is a full matrix.
= 'L': A is a lower triangular matrix.
= 'U': A is an upper triangular matrix.
= 'H': A is an upper Hessenberg matrix.
= 'B': A is a symmetric band matrix with lower bandwidth KL
and upper bandwidth KU and with the only the lower
half stored.
= 'Q': A is a symmetric band matrix with lower bandwidth KL
and upper bandwidth KU and with the only the upper
half stored.
= 'Z': A is a band matrix with lower bandwidth KL and upper
bandwidth KU.
KL (input) INTEGER
The lower bandwidth of A. Referenced only if TYPE = 'B',
'Q' or 'Z'.
KU (input) INTEGER
The upper bandwidth of A. Referenced only if TYPE = 'B',
'Q' or 'Z'.
CFROM (input) REAL
CTO (input) REAL
The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
without over/underflow if the final result CTO*A(I,J)/CFROM
can be represented without over/underflow. CFROM must be
nonzero.
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) COMPLEX array, dimension (LDA,M)
The matrix to be multiplied by CTO/CFROM. See TYPE for the
storage type.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
INFO (output) INTEGER
0 - successful exit
<0 - if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
int a_dim1, i__1, i__2, i__3, i__4, i__5;
fcomplex q__1;
/* Local variables */
static int done;
static float ctoc;
static int i, j;
static int itype, k1, k2, k3, k4;
static float cfrom1;
static float cfromc;
static float bignum, smlnum, mul, cto1;
#define A(I,J) a[(I)-1 + ((J)-1)* ( lda)]
*info = 0;
if (lsame(type, "G")) {
itype = 0;
} else if (lsame(type, "L")) {
itype = 1;
} else if (lsame(type, "U")) {
itype = 2;
} else if (lsame(type, "H")) {
itype = 3;
} else if (lsame(type, "B")) {
itype = 4;
} else if (lsame(type, "Q")) {
itype = 5;
} else if (lsame(type, "Z")) {
itype = 6;
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (cfrom == 0.f) {
*info = -4;
} else if (m__ < 0) {
*info = -6;
} else if (n__ < 0 || (itype == 4 && n__ != m__) ||
(itype == 5 && n__ != m__)) {
*info = -7;
} else if (itype <= 3 && lda < max(1,m__)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = m__ - 1;
if (kl_ < 0 || kl_ > max(i__1,0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = n__ - 1;
if (ku_ < 0 || ku_ > max(i__1,0) || ((itype == 4 || itype == 5) &&
kl_ != ku_)) {
*info = -3;
} else if ((itype == 4 && lda < kl_ + 1) || (itype == 5 && lda <
ku_ + 1) || (itype == 6 && lda < (kl_ << 1) + ku_ + 1)) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
return ;
}
/*
* Quick return if possible
*/
if (n__ == 0 || m__ == 0) {
return ;
}
/*
* Get machine parameters
*/
smlnum = slamch("S");
bignum = 1.f / smlnum;
cfromc = cfrom;
ctoc = cto;
L10:
cfrom1 = cfromc * smlnum;
cto1 = ctoc / bignum;
if (fabs(cfrom1) > fabs(ctoc) && ctoc != 0.f) {
mul = smlnum;
done = FALSE;
cfromc = cfrom1;
} else if (fabs(cto1) > fabs(cfromc)) {
mul = bignum;
done = FALSE;
ctoc = cto1;
} else {
mul = ctoc / cfromc;
done = TRUE;
}
if (itype == 0) {
/*
* Full matrix
*/
i__1 = n__;
for (j = 1; j <= n__; ++j) {
i__2 = m__;
for (i = 1; i <= m__; ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 1) {
/*
* Lower triangular matrix
*/
i__1 = n__;
for (j = 1; j <= n__; ++j) {
i__2 = m__;
for (i = j; i <= m__; ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 2) {
/*
* Upper triangular matrix
*/
i__1 = n__;
for (j = 1; j <= n__; ++j) {
i__2 = min(j,m__);
for (i = 1; i <= min(j,m__); ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 3) {
/*
* Upper Hessenberg matrix
*/
i__1 = n__;
for (j = 1; j <= n__; ++j) {
/*
* Computing MIN
*/
i__3 = j + 1;
i__2 = min(i__3,m__);
for (i = 1; i <= min(j+1,m__); ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 4) {
/*
* Lower half of a symmetric band matrix
*/
k3 = kl_ + 1;
k4 = n__ + 1;
i__1 = n__;
for (j = 1; j <= n__; ++j) {
/*
* Computing MIN
*/
i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(k3,k4-j); ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 5) {
/*
* Upper half of a symmetric band matrix
*/
k1 = ku_ + 2;
k3 = ku_ + 1;
i__1 = n__;
for (j = 1; j <= n__; ++j) {
/*
* Computing MAX
*/
i__2 = k1 - j;
i__3 = k3;
for (i = max(k1-j,1); i <= k3; ++i) {
i__2 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
} else if (itype == 6) {
/*
* Band matrix
*/
k1 = kl_ + ku_ + 2;
k2 = kl_ + 1;
k3 = (kl_ << 1) + ku_ + 1;
k4 = kl_ + ku_ + 1 + m__;
i__1 = n__;
for (j = 1; j <= n__; ++j) {
/*
* Computing MAX
*/
i__3 = k1 - j;
/*
* Computing MIN
*/
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i = max(k1-j,k2); i <= min(k3,k4-j); ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
q__1.r = mul * A(i,j).r, q__1.i = mul * A(i,j).i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
}
}
}
if (! done) {
goto L10;
}
}
void clarft(char *direct, char *storev, int n__, int k__,
fcomplex *v, int ldv, fcomplex *tau, fcomplex *t, int ldt)
{
/* -- LAPACK auxiliary 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
=======
CLARFT forms the triangular factor T of a complex block reflector H
of order n, which is defined as a product of k elementary reflectors.
If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
If STOREV = 'C', the vector which defines the elementary reflector
H(i) is stored in the i-th column of the array V, and
H = I - V * T * V'
If STOREV = 'R', the vector which defines the elementary reflector
H(i) is stored in the i-th row of the array V, and
H = I - V' * T * V
Arguments
=========
DIRECT (input) CHARACTER*1
Specifies the order in which the elementary reflectors are
multiplied to form the block reflector:
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Specifies how the vectors which define the elementary
reflectors are stored (see also Further Details):
= 'C': columnwise
= 'R': rowwise
N (input) INTEGER
The order of the block reflector H. N >= 0.
K (input) INTEGER
The order of the triangular factor T (= the number of
elementary reflectors). K >= 1.
V (input/output) COMPLEX array, dimension
(LDV,K) if STOREV = 'C'
(LDV,N) if STOREV = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
TAU (input) COMPLEX array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i).
T (output) COMPLEX array, dimension (LDT,K)
The k by k triangular factor T of the block reflector.
If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
lower triangular. The rest of the array is not used.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
Further Details
===============
The shape of the matrix V and the storage of the vectors which define
the H(i) is best illustrated by the following example with n = 5 and
k = 3. The elements equal to 1 are not stored; the corresponding
array elements are modified but restored on exit. The rest of the
array is not used.
DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
( v1 1 ) ( 1 v2 v2 v2 )
( v1 v2 1 ) ( 1 v3 v3 )
( v1 v2 v3 )
( v1 v2 v3 )
DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
V = ( v1 v2 v3 ) V = ( v1 v1 1 )
( v1 v2 v3 ) ( v2 v2 v2 1 )
( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
( 1 v3 )
( 1 )
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* Table of constant values */
static fcomplex c_b2 = {0.f,0.f};
static int c__1 = 1;
/* System generated locals */
int t_dim1, v_dim1, i__1, i__2, i__3, i__4;
fcomplex q__1;
/* Local variables */
static int i, j;
static fcomplex vii;
#define TAU(I) tau[(I)-1]
#define V(I,J) v[(I)-1 + ((J)-1)* ( ldv)]
#define T(I,J) t[(I)-1 + ((J)-1)* ( ldt)]
if (n__ == 0) {
return;
}
if (lsame(direct, "F")) {
i__1 = k__;
for (i = 1; i <= k__; ++i) {
i__2 = i;
if (TAU(i).r == 0.f && TAU(i).i == 0.f) {
/* H(i) = I */
i__2 = i;
for (j = 1; j <= i; ++j) {
i__3 = j + i * t_dim1;
T(j,i).r = 0.f, T(j,i).i = 0.f;
}
} else {
/* general case */
i__2 = i + i * v_dim1;
vii.r = V(i,i).r, vii.i = V(i,i).i;
i__2 = i + i * v_dim1;
V(i,i).r = 1.f, V(i,i).i = 0.f;
if (lsame(storev, "C")) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
i__2 = n__ - i + 1;
i__3 = i - 1;
i__4 = i;
q__1.r = -(double)TAU(i).r, q__1.i = -(double)
TAU(i).i;
cgemv("Conjugate transpose", i__2, i__3, q__1,
&V(i,1), ldv, &V(i,i), c__1, c_b2, &
T(1,i), c__1);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
if (i < n__) {
i__2 = n__ - i;
clacgv(i__2, &V(i,i+1), ldv);
}
i__2 = i - 1;
i__3 = n__ - i + 1;
i__4 = i;
q__1.r = -(double)TAU(i).r, q__1.i = -(double)
TAU(i).i;
cgemv("No transpose", i__2, i__3, q__1, &V(1,i),
ldv, &V(i,i), ldv, c_b2, &T(1,i), c__1);
if (i < n__) {
i__2 = n__ - i;
clacgv(i__2, &V(i,i+1), ldv);
}
}
i__2 = i + i * v_dim1;
V(i,i).r = vii.r, V(i,i).i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i - 1;
ctrmv("Upper", "No transpose", "Non-unit", i__2, &T(1,1),
ldt, &T(1,i), c__1);
i__2 = i + i * t_dim1;
i__3 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
}
}
} else {
for (i = k__; i >= 1; --i) {
i__1 = i;
if (TAU(i).r == 0.f && TAU(i).i == 0.f) {
/* H(i) = I */
i__1 = k__;
for (j = i; j <= k__; ++j) {
i__2 = j + i * t_dim1;
T(j,i).r = 0.f, T(j,i).i = 0.f;
}
} else {
/* general case */
if (i < k__) {
if (lsame(storev, "C")) {
i__1 = n__ - k__ + i + i * v_dim1;
vii.r = V(n__-k__+i,i).r, vii.i = V(n__-k__+i,i).i;
i__1 = n__ - k__ + i + i * v_dim1;
V(n__-k__+i,i).r = 1.f, V(n__-k__+i,i).i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
i__1 = n__ - k__ + i;
i__2 = k__ - i;
i__3 = i;
q__1.r = -(double)TAU(i).r, q__1.i = -(
double)TAU(i).i;
cgemv("Conjugate transpose", i__1, i__2, q__1,
&V(1,i+1), ldv, &V(1,i)
, c__1, c_b2, &T(i+1,i), c__1);
i__1 = n__ - k__ + i + i * v_dim1;
V(n__-k__+i,i).r = vii.r, V(n__-k__+i,i).i = vii.i;
} else {
i__1 = i + (n__ - k__ + i) * v_dim1;
vii.r = V(i,n__-k__+i).r, vii.i = V(i,n__-k__+i).i;
i__1 = i + (n__ - k__ + i) * v_dim1;
V(i,n__-k__+i).r = 1.f, V(i,n__-k__+i).i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
i__1 = n__ - k__ + i - 1;
clacgv(i__1, &V(i,1), ldv);
i__1 = k__ - i;
i__2 = n__ - k__ + i;
i__3 = i;
q__1.r = -(double)TAU(i).r, q__1.i = -(
double)TAU(i).i;
cgemv("No transpose", i__1, i__2, q__1, &V(i+1,1),
ldv, &V(i,1), ldv, c_b2, &
T(i+1,i), c__1);
i__1 = n__ - k__ + i - 1;
clacgv(i__1, &V(i,1), ldv);
i__1 = i + (n__ - k__ + i) * v_dim1;
V(i,n__-k__+i).r = vii.r, V(i,n__-k__+i).i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = k__ - i;
ctrmv("Lower", "No transpose", "Non-unit", i__1, &T(i+1,i+1),
ldt, &T(i+1,i), c__1);
}
i__1 = i + i * t_dim1;
i__2 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
}
}
}
}
