/// <summary>
/// Purpose
/// =======
///
/// DORMRZ overwrites the general real M-by-N matrix C with
///
/// SIDE = 'L' SIDE = 'R'
/// TRANS = 'N': Q * C C * Q
/// TRANS = 'T': Q**T * C C * Q**T
///
/// where Q is a real orthogonal matrix defined as the product of k
/// elementary reflectors
///
/// Q = H(1) H(2) . . . H(k)
///
/// as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
/// if SIDE = 'R'.
///
///</summary>
/// <param name="SIDE">
/// = 'L' SIDE = 'R'
///</param>
/// <param name="TRANS">
/// (input) CHARACTER*1
/// = 'N': No transpose, apply Q;
/// = 'T': Transpose, apply Q**T.
///</param>
/// <param name="M">
/// (input) INTEGER
/// The number of rows of the matrix C. M .GE. 0.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of columns of the matrix C. N .GE. 0.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The number of elementary reflectors whose product defines
/// the matrix Q.
/// If SIDE = 'L', M .GE. K .GE. 0;
/// if SIDE = 'R', N .GE. K .GE. 0.
///</param>
/// <param name="L">
/// (input) INTEGER
/// The number of columns of the matrix A containing
/// the meaningful part of the Householder reflectors.
/// If SIDE = 'L', M .GE. L .GE. 0, if SIDE = 'R', N .GE. L .GE. 0.
///</param>
/// <param name="A">
/// (input) DOUBLE PRECISION array, dimension
/// (LDA,M) if SIDE = 'L',
/// (LDA,N) if SIDE = 'R'
/// The i-th row must contain the vector which defines the
/// elementary reflector H(i), for i = 1,2,...,k, as returned by
/// DTZRZF in the last k rows of its array argument A.
/// A is modified by the routine but restored on exit.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,K).
///</param>
/// <param name="TAU">
/// (input) DOUBLE PRECISION array, dimension (K)
/// TAU(i) must contain the scalar factor of the elementary
/// reflector H(i), as returned by DTZRZF.
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC,N)
/// On entry, the M-by-N matrix C.
/// On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C. LDC .GE. max(1,M).
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK.
/// If SIDE = 'L', LWORK .GE. max(1,N);
/// if SIDE = 'R', LWORK .GE. max(1,M).
/// For optimum performance LWORK .GE. N*NB if SIDE = 'L', and
/// LWORK .GE. M*NB if SIDE = 'R', where NB is the optimal
/// blocksize.
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
///</param>
public void Run(string SIDE, string TRANS, int M, int N, int K, int L
, double[] A, int offset_a, int LDA, double[] TAU, int offset_tau, ref double[] C, int offset_c, int LDC, ref double[] WORK, int offset_work
, int LWORK, ref int INFO)
{
#region Variables
bool LEFT = false; bool LQUERY = false; bool NOTRAN = false; string TRANST = new string(' ', 1); int I = 0;
int I1 = 0; int I2 = 0; int I3 = 0; int IB = 0; int IC = 0; int IINFO = 0; int IWS = 0; int JA = 0; int JC = 0;
int LDWORK = 0; int LWKOPT = 0; int MI = 0; int NB = 0; int NBMIN = 0; int NI = 0; int NQ = 0; int NW = 0;
int offset_t = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_tau = -1 + offset_tau; int o_c = -1 - LDC + offset_c;
int o_work = -1 + offset_work;
#endregion
#region Strings
SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.1.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * January 2007
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DORMRZ overwrites the general real M-by-N matrix C with
// *
// * SIDE = 'L' SIDE = 'R'
// * TRANS = 'N': Q * C C * Q
// * TRANS = 'T': Q**T * C C * Q**T
// *
// * where Q is a real orthogonal matrix defined as the product of k
// * elementary reflectors
// *
// * Q = H(1) H(2) . . . H(k)
// *
// * as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
// * if SIDE = 'R'.
// *
// * Arguments
// * =========
// *
// * SIDE (input) CHARACTER*1
// * = 'L': apply Q or Q**T from the Left;
// * = 'R': apply Q or Q**T from the Right.
// *
// * TRANS (input) CHARACTER*1
// * = 'N': No transpose, apply Q;
// * = 'T': Transpose, apply Q**T.
// *
// * M (input) INTEGER
// * The number of rows of the matrix C. M >= 0.
// *
// * N (input) INTEGER
// * The number of columns of the matrix C. N >= 0.
// *
// * K (input) INTEGER
// * The number of elementary reflectors whose product defines
// * the matrix Q.
// * If SIDE = 'L', M >= K >= 0;
// * if SIDE = 'R', N >= K >= 0.
// *
// * L (input) INTEGER
// * The number of columns of the matrix A containing
// * the meaningful part of the Householder reflectors.
// * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
// *
// * A (input) DOUBLE PRECISION array, dimension
// * (LDA,M) if SIDE = 'L',
// * (LDA,N) if SIDE = 'R'
// * The i-th row must contain the vector which defines the
// * elementary reflector H(i), for i = 1,2,...,k, as returned by
// * DTZRZF in the last k rows of its array argument A.
// * A is modified by the routine but restored on exit.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,K).
// *
// * TAU (input) DOUBLE PRECISION array, dimension (K)
// * TAU(i) must contain the scalar factor of the elementary
// * reflector H(i), as returned by DTZRZF.
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
// * On entry, the M-by-N matrix C.
// * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C. LDC >= max(1,M).
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK.
// * If SIDE = 'L', LWORK >= max(1,N);
// * if SIDE = 'R', LWORK >= max(1,M).
// * For optimum performance LWORK >= N*NB if SIDE = 'L', and
// * LWORK >= M*NB if SIDE = 'R', where NB is the optimal
// * blocksize.
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, MIN;
// * ..
// * .. Executable Statements ..
// *
// * Test the input arguments
// *
#endregion
#region Body
INFO = 0;
LEFT = this._lsame.Run(SIDE, "L");
NOTRAN = this._lsame.Run(TRANS, "N");
LQUERY = (LWORK == -1);
// *
// * NQ is the order of Q and NW is the minimum dimension of WORK
// *
if (LEFT)
{
NQ = M;
NW = Math.Max(1, N);
}
else
{
NQ = N;
NW = Math.Max(1, M);
}
if (!LEFT && !this._lsame.Run(SIDE, "R"))
{
INFO = -1;
}
else
{
if (!NOTRAN && !this._lsame.Run(TRANS, "T"))
{
INFO = -2;
}
else
{
if (M < 0)
{
INFO = -3;
}
else
{
if (N < 0)
{
INFO = -4;
}
else
{
if (K < 0 || K > NQ)
{
INFO = -5;
}
else
{
if (L < 0 || (LEFT && (L > M)) || (!LEFT && (L > N)))
{
INFO = -6;
}
else
{
if (LDA < Math.Max(1, K))
{
INFO = -8;
}
else
{
if (LDC < Math.Max(1, M))
{
INFO = -11;
}
}
}
}
}
}
}
}
// *
if (INFO == 0)
{
if (M == 0 || N == 0)
{
LWKOPT = 1;
}
else
{
// *
// * Determine the block size. NB may be at most NBMAX, where
// * NBMAX is used to define the local array T.
// *
NB = Math.Min(NBMAX, this._ilaenv.Run(1, "DORMRQ", SIDE + TRANS, M, N, K, -1));
LWKOPT = NW * NB;
}
WORK[1 + o_work] = LWKOPT;
// *
if (LWORK < Math.Max(1, NW) && !LQUERY)
{
INFO = -13;
}
}
// *
if (INFO != 0)
{
this._xerbla.Run("DORMRZ", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
if (M == 0 || N == 0)
{
WORK[1 + o_work] = 1;
return;
}
// *
NBMIN = 2;
LDWORK = NW;
if (NB > 1 && NB < K)
{
IWS = NW * NB;
if (LWORK < IWS)
{
NB = LWORK / LDWORK;
NBMIN = Math.Max(2, this._ilaenv.Run(2, "DORMRQ", SIDE + TRANS, M, N, K, -1));
}
}
else
{
IWS = NW;
}
// *
if (NB < NBMIN || NB >= K)
{
// *
// * Use unblocked code
// *
this._dormr3.Run(SIDE, TRANS, M, N, K, L
, A, offset_a, LDA, TAU, offset_tau, ref C, offset_c, LDC, ref WORK, offset_work
, ref IINFO);
}
else
{
// *
// * Use blocked code
// *
if ((LEFT && !NOTRAN) || (!LEFT && NOTRAN))
{
I1 = 1;
I2 = K;
I3 = NB;
}
else
{
I1 = ((K - 1) / NB) * NB + 1;
I2 = 1;
I3 = -NB;
}
// *
if (LEFT)
{
NI = N;
JC = 1;
JA = M - L + 1;
}
else
{
MI = M;
IC = 1;
JA = N - L + 1;
}
// *
if (NOTRAN)
{
FortranLib.Copy(ref TRANST, "T");
}
else
{
FortranLib.Copy(ref TRANST, "N");
}
// *
for (I = I1; (I3 >= 0) ? (I <= I2) : (I >= I2); I += I3)
{
IB = Math.Min(NB, K - I + 1);
// *
// * Form the triangular factor of the block reflector
// * H = H(i+ib-1) . . . H(i+1) H(i)
// *
this._dlarzt.Run("Backward", "Rowwise", L, IB, A, I + JA * LDA + o_a, LDA
, TAU, I + o_tau, ref T, offset_t, LDT);
// *
if (LEFT)
{
// *
// * H or H' is applied to C(i:m,1:n)
// *
MI = M - I + 1;
IC = I;
}
else
{
// *
// * H or H' is applied to C(1:m,i:n)
// *
NI = N - I + 1;
JC = I;
}
// *
// * Apply H or H'
// *
this._dlarzb.Run(SIDE, TRANST, "Backward", "Rowwise", MI, NI
, IB, L, A, I + JA * LDA + o_a, LDA, T, offset_t, LDT
, ref C, IC + JC * LDC + o_c, LDC, ref WORK, offset_work, LDWORK);
}
// *
}
// *
WORK[1 + o_work] = LWKOPT;
// *
return;
// *
// * End of DORMRZ
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLAQR0 computes the eigenvalues of a Hessenberg matrix H
/// and, optionally, the matrices T and Z from the Schur decomposition
/// H = Z T Z**T, where T is an upper quasi-triangular matrix (the
/// Schur form), and Z is the orthogonal matrix of Schur vectors.
///
/// Optionally Z may be postmultiplied into an input orthogonal
/// 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 orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
///
///</summary>
/// <param name="WANTT">
/// (input) LOGICAL
/// = .TRUE. : the full Schur form T is required;
/// = .FALSE.: only eigenvalues are required.
///</param>
/// <param name="WANTZ">
/// (input) LOGICAL
/// = .TRUE. : the matrix of Schur vectors Z is required;
/// = .FALSE.: Schur vectors are not required.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix H. N .GE. 0.
///</param>
/// <param name="ILO">
/// (input) INTEGER
///</param>
/// <param name="IHI">
/// (input) INTEGER
/// It is assumed that H is already upper triangular in rows
/// and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
/// H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
/// previous call to DGEBAL, and then passed to DGEHRD when the
/// matrix output by DGEBAL is reduced to Hessenberg form.
/// Otherwise, ILO and IHI should be set to 1 and N,
/// respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
/// If N = 0, then ILO = 1 and IHI = 0.
///</param>
/// <param name="H">
/// (input/output) DOUBLE PRECISION array, dimension (LDH,N)
/// On entry, the upper Hessenberg matrix H.
/// On exit, if INFO = 0 and WANTT is .TRUE., then H contains
/// the upper quasi-triangular matrix T from the Schur
/// decomposition (the Schur form); 2-by-2 diagonal blocks
/// (corresponding to complex conjugate pairs of eigenvalues)
/// are returned in standard form, with H(i,i) = H(i+1,i+1)
/// and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
/// .FALSE., then the contents of H are unspecified on exit.
/// (The output value of H when INFO.GT.0 is given under the
/// description of INFO below.)
///
/// This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
/// j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
///</param>
/// <param name="LDH">
/// (input) INTEGER
/// The leading dimension of the array H. LDH .GE. max(1,N).
///</param>
/// <param name="WR">
/// (output) DOUBLE PRECISION array, dimension (IHI)
///</param>
/// <param name="WI">
/// (output) DOUBLE PRECISION array, dimension (IHI)
/// The real and imaginary parts, respectively, of the computed
/// eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
/// and WI(ILO:IHI). If two eigenvalues are computed as a
/// complex conjugate pair, they are stored in consecutive
/// elements of WR and WI, say the i-th and (i+1)th, with
/// WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
/// the eigenvalues are stored in the same order as on the
/// diagonal of the Schur form returned in H, with
/// WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
/// block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
/// WI(i+1) = -WI(i).
///</param>
/// <param name="ILOZ">
/// (input) INTEGER
///</param>
/// <param name="IHIZ">
/// (input) INTEGER
/// Specify the rows of Z to which transformations must be
/// applied if WANTZ is .TRUE..
/// 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
///</param>
/// <param name="Z">
/// (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
/// If WANTZ is .FALSE., then Z is not referenced.
/// If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
/// replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
/// orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
/// (The output value of Z when INFO.GT.0 is given under
/// the description of INFO below.)
///</param>
/// <param name="LDZ">
/// (input) INTEGER
/// The leading dimension of the array Z. if WANTZ is .TRUE.
/// then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension LWORK
/// On exit, if LWORK = -1, WORK(1) returns an estimate of
/// the optimal value for LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK. LWORK .GE. max(1,N)
/// is sufficient, but LWORK typically as large as 6*N may
/// be required for optimal performance. A workspace query
/// to determine the optimal workspace size is recommended.
///
/// If LWORK = -1, then DLAQR0 does a workspace query.
/// In this case, DLAQR0 checks the input parameters and
/// estimates the optimal workspace size for the given
/// values of N, ILO and IHI. The estimate is returned
/// in WORK(1). No error message related to LWORK is
/// issued by XERBLA. Neither H nor Z are accessed.
///
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .GT. 0: if INFO = i, DLAQR0 failed to compute all of
/// the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
/// and WI contain those eigenvalues which have been
/// successfully computed. (Failures are rare.)
///
/// If INFO .GT. 0 and WANT is .FALSE., then on exit,
/// the remaining unconverged eigenvalues are the eigen-
/// values of the upper Hessenberg matrix rows and
/// columns ILO through INFO of the final, output
/// value of H.
///
/// If INFO .GT. 0 and WANTT is .TRUE., then on exit
///
/// (*) (initial value of H)*U = U*(final value of H)
///
/// where U is an orthogonal matrix. The final
/// value of H is upper Hessenberg and quasi-triangular
/// in rows and columns INFO+1 through IHI.
///
/// If INFO .GT. 0 and WANTZ is .TRUE., then on exit
///
/// (final value of Z(ILO:IHI,ILOZ:IHIZ)
/// = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
///
/// where U is the orthogonal matrix in (*) (regard-
/// less of the value of WANTT.)
///
/// If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
/// accessed.
///
///</param>
public void Run(bool WANTT, bool WANTZ, int N, int ILO, int IHI, ref double[] H, int offset_h
, int LDH, ref double[] WR, int offset_wr, ref double[] WI, int offset_wi, int ILOZ, int IHIZ, ref double[] Z, int offset_z
, int LDZ, ref double[] WORK, int offset_work, int LWORK, ref int INFO)
{
#region Variables
double AA = 0; double BB = 0; double CC = 0; double CS = 0; double DD = 0; double SN = 0; double SS = 0;
double SWAP = 0; int I = 0; int INF = 0; int IT = 0; int ITMAX = 0; int K = 0; int KACC22 = 0; int KBOT = 0;
int KDU = 0; int KS = 0; int KT = 0; int KTOP = 0; int KU = 0; int KV = 0; int KWH = 0; int KWTOP = 0; int KWV = 0;
int LD = 0; int LS = 0; int LWKOPT = 0; int NDFL = 0; int NH = 0; int NHO = 0; int NIBBLE = 0; int NMIN = 0;
int NS = 0; int NSMAX = 0; int NSR = 0; int NVE = 0; int NW = 0; int NWMAX = 0; int NWR = 0; bool NWINC = false;
bool SORTED = false; string JBCMPZ = new string(' ', 2); int offset_zdum = 0;
#endregion
#region Array Index Correction
int o_h = -1 - LDH + offset_h; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi;
int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work;
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLAQR0 computes the eigenvalues of a Hessenberg matrix H
// * and, optionally, the matrices T and Z from the Schur decomposition
// * H = Z T Z**T, where T is an upper quasi-triangular matrix (the
// * Schur form), and Z is the orthogonal matrix of Schur vectors.
// *
// * Optionally Z may be postmultiplied into an input orthogonal
// * 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 orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
// *
// * Arguments
// * =========
// *
// * WANTT (input) LOGICAL
// * = .TRUE. : the full Schur form T is required;
// * = .FALSE.: only eigenvalues are required.
// *
// * WANTZ (input) LOGICAL
// * = .TRUE. : the matrix of Schur vectors Z is required;
// * = .FALSE.: Schur vectors are not required.
// *
// * N (input) INTEGER
// * The order of the matrix H. N .GE. 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 and, if ILO.GT.1,
// * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
// * previous call to DGEBAL, and then passed to DGEHRD when the
// * matrix output by DGEBAL is reduced to Hessenberg form.
// * Otherwise, ILO and IHI should be set to 1 and N,
// * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
// * If N = 0, then ILO = 1 and IHI = 0.
// *
// * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
// * On entry, the upper Hessenberg matrix H.
// * On exit, if INFO = 0 and WANTT is .TRUE., then H contains
// * the upper quasi-triangular matrix T from the Schur
// * decomposition (the Schur form); 2-by-2 diagonal blocks
// * (corresponding to complex conjugate pairs of eigenvalues)
// * are returned in standard form, with H(i,i) = H(i+1,i+1)
// * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
// * .FALSE., then the contents of H are unspecified on exit.
// * (The output value of H when INFO.GT.0 is given under the
// * description of INFO below.)
// *
// * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
// * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
// *
// * LDH (input) INTEGER
// * The leading dimension of the array H. LDH .GE. max(1,N).
// *
// * WR (output) DOUBLE PRECISION array, dimension (IHI)
// * WI (output) DOUBLE PRECISION array, dimension (IHI)
// * The real and imaginary parts, respectively, of the computed
// * eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
// * and WI(ILO:IHI). If two eigenvalues are computed as a
// * complex conjugate pair, they are stored in consecutive
// * elements of WR and WI, say the i-th and (i+1)th, with
// * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
// * the eigenvalues are stored in the same order as on the
// * diagonal of the Schur form returned in H, with
// * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
// * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
// * WI(i+1) = -WI(i).
// *
// * ILOZ (input) INTEGER
// * IHIZ (input) INTEGER
// * Specify the rows of Z to which transformations must be
// * applied if WANTZ is .TRUE..
// * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
// *
// * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
// * If WANTZ is .FALSE., then Z is not referenced.
// * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
// * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
// * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
// * (The output value of Z when INFO.GT.0 is given under
// * the description of INFO below.)
// *
// * LDZ (input) INTEGER
// * The leading dimension of the array Z. if WANTZ is .TRUE.
// * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
// * On exit, if LWORK = -1, WORK(1) returns an estimate of
// * the optimal value for LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK. LWORK .GE. max(1,N)
// * is sufficient, but LWORK typically as large as 6*N may
// * be required for optimal performance. A workspace query
// * to determine the optimal workspace size is recommended.
// *
// * If LWORK = -1, then DLAQR0 does a workspace query.
// * In this case, DLAQR0 checks the input parameters and
// * estimates the optimal workspace size for the given
// * values of N, ILO and IHI. The estimate is returned
// * in WORK(1). No error message related to LWORK is
// * issued by XERBLA. Neither H nor Z are accessed.
// *
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * .GT. 0: if INFO = i, DLAQR0 failed to compute all of
// * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
// * and WI contain those eigenvalues which have been
// * successfully computed. (Failures are rare.)
// *
// * If INFO .GT. 0 and WANT is .FALSE., then on exit,
// * the remaining unconverged eigenvalues are the eigen-
// * values of the upper Hessenberg matrix rows and
// * columns ILO through INFO of the final, output
// * value of H.
// *
// * If INFO .GT. 0 and WANTT is .TRUE., then on exit
// *
// * (*) (initial value of H)*U = U*(final value of H)
// *
// * where U is an orthogonal matrix. The final
// * value of H is upper Hessenberg and quasi-triangular
// * in rows and columns INFO+1 through IHI.
// *
// * If INFO .GT. 0 and WANTZ is .TRUE., then on exit
// *
// * (final value of Z(ILO:IHI,ILOZ:IHIZ)
// * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
// *
// * where U is the orthogonal matrix in (*) (regard-
// * less of the value of WANTT.)
// *
// * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
// * accessed.
// *
// *
// * ================================================================
// * Based on contributions by
// * Karen Braman and Ralph Byers, Department of Mathematics,
// * University of Kansas, USA
// *
// * ================================================================
// *
// * References:
// * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
// * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
// * Performance, SIAM Journal of Matrix Analysis, volume 23, pages
// * 929--947, 2002.
// *
// * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
// * Algorithm Part II: Aggressive Early Deflation, SIAM Journal
// * of Matrix Analysis, volume 23, pages 948--973, 2002.
// *
// * ================================================================
// * .. Parameters ..
// *
// * ==== Matrices of order NTINY or smaller must be processed by
// * . DLAHQR because of insufficient subdiagonal scratch space.
// * . (This is a hard limit.) ====
// *
// * ==== Exceptional deflation windows: try to cure rare
// * . slow convergence by increasing the size of the
// * . deflation window after KEXNW iterations. =====
// *
// * ==== Exceptional shifts: try to cure rare slow convergence
// * . with ad-hoc exceptional shifts every KEXSH iterations.
// * . The constants WILK1 and WILK2 are used to form the
// * . exceptional shifts. ====
// *
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD;
// * ..
// * .. Executable Statements ..
#endregion
#region Body
INFO = 0;
// *
// * ==== Quick return for N = 0: nothing to do. ====
// *
if (N == 0)
{
WORK[1 + o_work] = ONE;
return;
}
// *
// * ==== Set up job flags for ILAENV. ====
// *
if (WANTT)
{
FortranLib.Copy(ref JBCMPZ, 1, 1, "S");
}
else
{
FortranLib.Copy(ref JBCMPZ, 1, 1, "E");
}
if (WANTZ)
{
FortranLib.Copy(ref JBCMPZ, 2, 2, "V");
}
else
{
FortranLib.Copy(ref JBCMPZ, 2, 2, "N");
}
// *
// * ==== Tiny matrices must use DLAHQR. ====
// *
if (N <= NTINY)
{
// *
// * ==== Estimate optimal workspace. ====
// *
LWKOPT = 1;
if (LWORK != -1)
{
this._dlahqr.Run(WANTT, WANTZ, N, ILO, IHI, ref H, offset_h
, LDH, ref WR, offset_wr, ref WI, offset_wi, ILOZ, IHIZ, ref Z, offset_z
, LDZ, ref INFO);
}
}
else
{
// *
// * ==== Use small bulge multi-shift QR with aggressive early
// * . deflation on larger-than-tiny matrices. ====
// *
// * ==== Hope for the best. ====
// *
INFO = 0;
// *
// * ==== NWR = recommended deflation window size. At this
// * . point, N .GT. NTINY = 11, so there is enough
// * . subdiagonal workspace for NWR.GE.2 as required.
// * . (In fact, there is enough subdiagonal space for
// * . NWR.GE.3.) ====
// *
NWR = this._ilaenv.Run(13, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NWR = Math.Max(2, NWR);
NWR = Math.Min(IHI - ILO + 1, Math.Min((N - 1) / 3, NWR));
NW = NWR;
// *
// * ==== NSR = recommended number of simultaneous shifts.
// * . At this point N .GT. NTINY = 11, so there is at
// * . enough subdiagonal workspace for NSR to be even
// * . and greater than or equal to two as required. ====
// *
NSR = this._ilaenv.Run(15, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NSR = Math.Min(NSR, Math.Min((N + 6) / 9, IHI - ILO));
NSR = Math.Max(2, NSR - FortranLib.Mod(NSR, 2));
// *
// * ==== Estimate optimal workspace ====
// *
// * ==== Workspace query call to DLAQR3 ====
// *
this._dlaqr3.Run(WANTT, WANTZ, N, ILO, IHI, NWR + 1
, ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ
, ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, offset_h, LDH
, N, ref H, offset_h, LDH, N, ref H, offset_h, LDH
, ref WORK, offset_work, -1);
// *
// * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
// *
LWKOPT = Math.Max(3 * NSR / 2, Convert.ToInt32(Math.Truncate(WORK[1 + o_work])));
// *
// * ==== Quick return in case of workspace query. ====
// *
if (LWORK == -1)
{
WORK[1 + o_work] = Convert.ToDouble(LWKOPT);
return;
}
// *
// * ==== DLAHQR/DLAQR0 crossover point ====
// *
NMIN = this._ilaenv.Run(12, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NMIN = Math.Max(NTINY, NMIN);
// *
// * ==== Nibble crossover point ====
// *
NIBBLE = this._ilaenv.Run(14, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NIBBLE = Math.Max(0, NIBBLE);
// *
// * ==== Accumulate reflections during ttswp? Use block
// * . 2-by-2 structure during matrix-matrix multiply? ====
// *
KACC22 = this._ilaenv.Run(16, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
KACC22 = Math.Max(0, KACC22);
KACC22 = Math.Min(2, KACC22);
// *
// * ==== NWMAX = the largest possible deflation window for
// * . which there is sufficient workspace. ====
// *
NWMAX = Math.Min((N - 1) / 3, LWORK / 2);
// *
// * ==== NSMAX = the Largest number of simultaneous shifts
// * . for which there is sufficient workspace. ====
// *
NSMAX = Math.Min((N + 6) / 9, 2 * LWORK / 3);
NSMAX -= FortranLib.Mod(NSMAX, 2);
// *
// * ==== NDFL: an iteration count restarted at deflation. ====
// *
NDFL = 1;
// *
// * ==== ITMAX = iteration limit ====
// *
ITMAX = Math.Max(30, 2 * KEXSH) * Math.Max(10, (IHI - ILO + 1));
// *
// * ==== Last row and column in the active block ====
// *
KBOT = IHI;
// *
// * ==== Main Loop ====
// *
for (IT = 1; IT <= ITMAX; IT++)
{
// *
// * ==== Done when KBOT falls below ILO ====
// *
if (KBOT < ILO)
{
goto LABEL90;
}
// *
// * ==== Locate active block ====
// *
for (K = KBOT; K >= ILO + 1; K += -1)
{
if (H[K + (K - 1) * LDH + o_h] == ZERO)
{
goto LABEL20;
}
}
K = ILO;
LABEL20 :;
KTOP = K;
// *
// * ==== Select deflation window size ====
// *
NH = KBOT - KTOP + 1;
if (NDFL < KEXNW || NH < NW)
{
// *
// * ==== Typical deflation window. If possible and
// * . advisable, nibble the entire active block.
// * . If not, use size NWR or NWR+1 depending upon
// * . which has the smaller corresponding subdiagonal
// * . entry (a heuristic). ====
// *
NWINC = true;
if (NH <= Math.Min(NMIN, NWMAX))
{
NW = NH;
}
else
{
NW = Math.Min(NWR, Math.Min(NH, NWMAX));
if (NW < NWMAX)
{
if (NW >= NH - 1)
{
NW = NH;
}
else
{
KWTOP = KBOT - NW + 1;
if (Math.Abs(H[KWTOP + (KWTOP - 1) * LDH + o_h]) > Math.Abs(H[KWTOP - 1 + (KWTOP - 2) * LDH + o_h]))
{
NW += 1;
}
}
}
}
}
else
{
// *
// * ==== Exceptional deflation window. If there have
// * . been no deflations in KEXNW or more iterations,
// * . then vary the deflation window size. At first,
// * . because, larger windows are, in general, more
// * . powerful than smaller ones, rapidly increase the
// * . window up to the maximum reasonable and possible.
// * . Then maybe try a slightly smaller window. ====
// *
if (NWINC && NW < Math.Min(NWMAX, NH))
{
NW = Math.Min(NWMAX, Math.Min(NH, 2 * NW));
}
else
{
NWINC = false;
if (NW == NH && NH > 2)
{
NW = NH - 1;
}
}
}
// *
// * ==== Aggressive early deflation:
// * . split workspace under the subdiagonal into
// * . - an nw-by-nw work array V in the lower
// * . left-hand-corner,
// * . - an NW-by-at-least-NW-but-more-is-better
// * . (NW-by-NHO) horizontal work array along
// * . the bottom edge,
// * . - an at-least-NW-but-more-is-better (NHV-by-NW)
// * . vertical work array along the left-hand-edge.
// * . ====
// *
KV = N - NW + 1;
KT = NW + 1;
NHO = (N - NW - 1) - KT + 1;
KWV = NW + 2;
NVE = (N - NW) - KWV + 1;
// *
// * ==== Aggressive early deflation ====
// *
this._dlaqr3.Run(WANTT, WANTZ, N, KTOP, KBOT, NW
, ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ
, ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, KV + 1 * LDH + o_h, LDH
, NHO, ref H, KV + KT * LDH + o_h, LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH
, ref WORK, offset_work, LWORK);
// *
// * ==== Adjust KBOT accounting for new deflations. ====
// *
KBOT -= LD;
// *
// * ==== KS points to the shifts. ====
// *
KS = KBOT - LS + 1;
// *
// * ==== Skip an expensive QR sweep if there is a (partly
// * . heuristic) reason to expect that many eigenvalues
// * . will deflate without it. Here, the QR sweep is
// * . skipped if many eigenvalues have just been deflated
// * . or if the remaining active block is small.
// *
if ((LD == 0) || ((100 * LD <= NW * NIBBLE) && (KBOT - KTOP + 1 > Math.Min(NMIN, NWMAX))))
{
// *
// * ==== NS = nominal number of simultaneous shifts.
// * . This may be lowered (slightly) if DLAQR3
// * . did not provide that many shifts. ====
// *
NS = Math.Min(NSMAX, Math.Min(NSR, Math.Max(2, KBOT - KTOP)));
NS -= FortranLib.Mod(NS, 2);
// *
// * ==== If there have been no deflations
// * . in a multiple of KEXSH iterations,
// * . then try exceptional shifts.
// * . Otherwise use shifts provided by
// * . DLAQR3 above or from the eigenvalues
// * . of a trailing principal submatrix. ====
// *
if (FortranLib.Mod(NDFL, KEXSH) == 0)
{
KS = KBOT - NS + 1;
for (I = KBOT; I >= Math.Max(KS + 1, KTOP + 2); I += -2)
{
SS = Math.Abs(H[I + (I - 1) * LDH + o_h]) + Math.Abs(H[I - 1 + (I - 2) * LDH + o_h]);
AA = WILK1 * SS + H[I + I * LDH + o_h];
BB = SS;
CC = WILK2 * SS;
DD = AA;
this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[I - 1 + o_wr], ref WI[I - 1 + o_wi]
, ref WR[I + o_wr], ref WI[I + o_wi], ref CS, ref SN);
}
if (KS == KTOP)
{
WR[KS + 1 + o_wr] = H[KS + 1 + (KS + 1) * LDH + o_h];
WI[KS + 1 + o_wi] = ZERO;
WR[KS + o_wr] = WR[KS + 1 + o_wr];
WI[KS + o_wi] = WI[KS + 1 + o_wi];
}
}
else
{
// *
// * ==== Got NS/2 or fewer shifts? Use DLAQR4 or
// * . DLAHQR on a trailing principal submatrix to
// * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
// * . there is enough space below the subdiagonal
// * . to fit an NS-by-NS scratch array.) ====
// *
if (KBOT - KS + 1 <= NS / 2)
{
KS = KBOT - NS + 1;
KT = N - NS + 1;
this._dlacpy.Run("A", NS, NS, H, KS + KS * LDH + o_h, LDH, ref H, KT + 1 * LDH + o_h
, LDH);
if (NS > NMIN)
{
this._dlaqr4.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h
, LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum
, 1, ref WORK, offset_work, LWORK, ref INF);
}
else
{
this._dlahqr.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h
, LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum
, 1, ref INF);
}
KS += INF;
// *
// * ==== In case of a rare QR failure use
// * . eigenvalues of the trailing 2-by-2
// * . principal submatrix. ====
// *
if (KS >= KBOT)
{
AA = H[KBOT - 1 + (KBOT - 1) * LDH + o_h];
CC = H[KBOT + (KBOT - 1) * LDH + o_h];
BB = H[KBOT - 1 + KBOT * LDH + o_h];
DD = H[KBOT + KBOT * LDH + o_h];
this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[KBOT - 1 + o_wr], ref WI[KBOT - 1 + o_wi]
, ref WR[KBOT + o_wr], ref WI[KBOT + o_wi], ref CS, ref SN);
KS = KBOT - 1;
}
}
// *
if (KBOT - KS + 1 > NS)
{
// *
// * ==== Sort the shifts (Helps a little)
// * . Bubble sort keeps complex conjugate
// * . pairs together. ====
// *
SORTED = false;
for (K = KBOT; K >= KS + 1; K += -1)
{
if (SORTED)
{
goto LABEL60;
}
SORTED = true;
for (I = KS; I <= K - 1; I++)
{
if (Math.Abs(WR[I + o_wr]) + Math.Abs(WI[I + o_wi]) < Math.Abs(WR[I + 1 + o_wr]) + Math.Abs(WI[I + 1 + o_wi]))
{
SORTED = false;
// *
SWAP = WR[I + o_wr];
WR[I + o_wr] = WR[I + 1 + o_wr];
WR[I + 1 + o_wr] = SWAP;
// *
SWAP = WI[I + o_wi];
WI[I + o_wi] = WI[I + 1 + o_wi];
WI[I + 1 + o_wi] = SWAP;
}
}
}
LABEL60 :;
}
// *
// * ==== Shuffle shifts into pairs of real shifts
// * . and pairs of complex conjugate shifts
// * . assuming complex conjugate shifts are
// * . already adjacent to one another. (Yes,
// * . they are.) ====
// *
for (I = KBOT; I >= KS + 2; I += -2)
{
if (WI[I + o_wi] != -WI[I - 1 + o_wi])
{
// *
SWAP = WR[I + o_wr];
WR[I + o_wr] = WR[I - 1 + o_wr];
WR[I - 1 + o_wr] = WR[I - 2 + o_wr];
WR[I - 2 + o_wr] = SWAP;
// *
SWAP = WI[I + o_wi];
WI[I + o_wi] = WI[I - 1 + o_wi];
WI[I - 1 + o_wi] = WI[I - 2 + o_wi];
WI[I - 2 + o_wi] = SWAP;
}
}
}
// *
// * ==== If there are only two shifts and both are
// * . real, then use only one. ====
// *
if (KBOT - KS + 1 == 2)
{
if (WI[KBOT + o_wi] == ZERO)
{
if (Math.Abs(WR[KBOT + o_wr] - H[KBOT + KBOT * LDH + o_h]) < Math.Abs(WR[KBOT - 1 + o_wr] - H[KBOT + KBOT * LDH + o_h]))
{
WR[KBOT - 1 + o_wr] = WR[KBOT + o_wr];
}
else
{
WR[KBOT + o_wr] = WR[KBOT - 1 + o_wr];
}
}
}
// *
// * ==== Use up to NS of the the smallest magnatiude
// * . shifts. If there aren't NS shifts available,
// * . then use them all, possibly dropping one to
// * . make the number of shifts even. ====
// *
NS = Math.Min(NS, KBOT - KS + 1);
NS -= FortranLib.Mod(NS, 2);
KS = KBOT - NS + 1;
// *
// * ==== Small-bulge multi-shift QR sweep:
// * . split workspace under the subdiagonal into
// * . - a KDU-by-KDU work array U in the lower
// * . left-hand-corner,
// * . - a KDU-by-at-least-KDU-but-more-is-better
// * . (KDU-by-NHo) horizontal work array WH along
// * . the bottom edge,
// * . - and an at-least-KDU-but-more-is-better-by-KDU
// * . (NVE-by-KDU) vertical work WV arrow along
// * . the left-hand-edge. ====
// *
KDU = 3 * NS - 3;
KU = N - KDU + 1;
KWH = KDU + 1;
NHO = (N - KDU + 1 - 4) - (KDU + 1) + 1;
KWV = KDU + 4;
NVE = N - KDU - KWV + 1;
// *
// * ==== Small-bulge multi-shift QR sweep ====
// *
this._dlaqr5.Run(WANTT, WANTZ, KACC22, N, KTOP, KBOT
, NS, ref WR, KS + o_wr, ref WI, KS + o_wi, ref H, offset_h, LDH, ILOZ
, IHIZ, ref Z, offset_z, LDZ, ref WORK, offset_work, 3, ref H, KU + 1 * LDH + o_h
, LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH, NHO, ref H, KU + KWH * LDH + o_h
, LDH);
}
// *
// * ==== Note progress (or the lack of it). ====
// *
if (LD > 0)
{
NDFL = 1;
}
else
{
NDFL += 1;
}
// *
// * ==== End of main loop ====
}
// *
// * ==== Iteration limit exceeded. Set INFO to show where
// * . the problem occurred and exit. ====
// *
INFO = KBOT;
LABEL90 :;
}
// *
// * ==== Return the optimal value of LWORK. ====
// *
WORK[1 + o_work] = Convert.ToDouble(LWKOPT);
// *
// * ==== End of DLAQR0 ====
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// ILAENV is called from the LAPACK routines to choose problem-dependent
/// parameters for the local environment. See ISPEC for a description of
/// the parameters.
///
/// ILAENV returns an INTEGER
/// if ILAENV .GE. 0: ILAENV returns the value of the parameter specified by ISPEC
/// if ILAENV .LT. 0: if ILAENV = -k, the k-th argument had an illegal value.
///
/// This version provides a set of parameters which should give good,
/// but not optimal, performance on many of the currently available
/// computers. Users are encouraged to modify this subroutine to set
/// the tuning parameters for their particular machine using the option
/// and problem size information in the arguments.
///
/// This routine will not function correctly if it is converted to all
/// lower case. Converting it to all upper case is allowed.
///
///</summary>
/// <param name="ISPEC">
/// (input) INTEGER
/// Specifies the parameter to be returned as the value of
/// ILAENV.
/// = 1: the optimal blocksize; if this value is 1, an unblocked
/// algorithm will give the best performance.
/// = 2: the minimum block size for which the block routine
/// should be used; if the usable block size is less than
/// this value, an unblocked routine should be used.
/// = 3: the crossover point (in a block routine, for N less
/// than this value, an unblocked routine should be used)
/// = 4: the number of shifts, used in the nonsymmetric
/// eigenvalue routines (DEPRECATED)
/// = 5: the minimum column dimension for blocking to be used;
/// rectangular blocks must have dimension at least k by m,
/// where k is given by ILAENV(2,...) and m by ILAENV(5,...)
/// = 6: the crossover point for the SVD (when reducing an m by n
/// matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
/// this value, a QR factorization is used first to reduce
/// the matrix to a triangular form.)
/// = 7: the number of processors
/// = 8: the crossover point for the multishift QR method
/// for nonsymmetric eigenvalue problems (DEPRECATED)
/// = 9: maximum size of the subproblems at the bottom of the
/// computation tree in the divide-and-conquer algorithm
/// (used by xGELSD and xGESDD)
/// =10: ieee NaN arithmetic can be trusted not to trap
/// =11: infinity arithmetic can be trusted not to trap
/// 12 .LE. ISPEC .LE. 16:
/// xHSEQR or one of its subroutines,
/// see IPARMQ for detailed explanation
///</param>
/// <param name="NAME">
/// (input) CHARACTER*(*)
/// The name of the calling subroutine, in either upper case or
/// lower case.
///</param>
/// <param name="OPTS">
/// (input) CHARACTER*(*)
/// The character options to the subroutine NAME, concatenated
/// into a single character string. For example, UPLO = 'U',
/// TRANS = 'T', and DIAG = 'N' for a triangular routine would
/// be specified as OPTS = 'UTN'.
///</param>
/// <param name="N1">
/// (input) INTEGER
///</param>
/// <param name="N2">
/// (input) INTEGER
///</param>
/// <param name="N3">
/// (input) INTEGER
///</param>
/// <param name="N4">
/// (input) INTEGER
/// Problem dimensions for the subroutine NAME; these may not all
/// be required.
///</param>
public int Run(int ISPEC, string NAME, string OPTS, int N1, int N2, int N3
, int N4)
{
int ilaenv = 0;
#region Variables
int I = 0; int IC = 0; int IZ = 0; int NB = 0; int NBMIN = 0; int NX = 0; bool CNAME = false; bool SNAME = false;
string C1 = new string(' ', 1); string C2 = new string(' ', 2); string C4 = new string(' ', 2);
string C3 = new string(' ', 3); string SUBNAM = new string(' ', 6);
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * January 2007
// *
// * .. Scalar Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * ILAENV is called from the LAPACK routines to choose problem-dependent
// * parameters for the local environment. See ISPEC for a description of
// * the parameters.
// *
// * ILAENV returns an INTEGER
// * if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
// * if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
// *
// * This version provides a set of parameters which should give good,
// * but not optimal, performance on many of the currently available
// * computers. Users are encouraged to modify this subroutine to set
// * the tuning parameters for their particular machine using the option
// * and problem size information in the arguments.
// *
// * This routine will not function correctly if it is converted to all
// * lower case. Converting it to all upper case is allowed.
// *
// * Arguments
// * =========
// *
// * ISPEC (input) INTEGER
// * Specifies the parameter to be returned as the value of
// * ILAENV.
// * = 1: the optimal blocksize; if this value is 1, an unblocked
// * algorithm will give the best performance.
// * = 2: the minimum block size for which the block routine
// * should be used; if the usable block size is less than
// * this value, an unblocked routine should be used.
// * = 3: the crossover point (in a block routine, for N less
// * than this value, an unblocked routine should be used)
// * = 4: the number of shifts, used in the nonsymmetric
// * eigenvalue routines (DEPRECATED)
// * = 5: the minimum column dimension for blocking to be used;
// * rectangular blocks must have dimension at least k by m,
// * where k is given by ILAENV(2,...) and m by ILAENV(5,...)
// * = 6: the crossover point for the SVD (when reducing an m by n
// * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
// * this value, a QR factorization is used first to reduce
// * the matrix to a triangular form.)
// * = 7: the number of processors
// * = 8: the crossover point for the multishift QR method
// * for nonsymmetric eigenvalue problems (DEPRECATED)
// * = 9: maximum size of the subproblems at the bottom of the
// * computation tree in the divide-and-conquer algorithm
// * (used by xGELSD and xGESDD)
// * =10: ieee NaN arithmetic can be trusted not to trap
// * =11: infinity arithmetic can be trusted not to trap
// * 12 <= ISPEC <= 16:
// * xHSEQR or one of its subroutines,
// * see IPARMQ for detailed explanation
// *
// * NAME (input) CHARACTER*(*)
// * The name of the calling subroutine, in either upper case or
// * lower case.
// *
// * OPTS (input) CHARACTER*(*)
// * The character options to the subroutine NAME, concatenated
// * into a single character string. For example, UPLO = 'U',
// * TRANS = 'T', and DIAG = 'N' for a triangular routine would
// * be specified as OPTS = 'UTN'.
// *
// * N1 (input) INTEGER
// * N2 (input) INTEGER
// * N3 (input) INTEGER
// * N4 (input) INTEGER
// * Problem dimensions for the subroutine NAME; these may not all
// * be required.
// *
// * Further Details
// * ===============
// *
// * The following conventions have been used when calling ILAENV from the
// * LAPACK routines:
// * 1) OPTS is a concatenation of all of the character options to
// * subroutine NAME, in the same order that they appear in the
// * argument list for NAME, even if they are not used in determining
// * the value of the parameter specified by ISPEC.
// * 2) The problem dimensions N1, N2, N3, N4 are specified in the order
// * that they appear in the argument list for NAME. N1 is used
// * first, N2 second, and so on, and unused problem dimensions are
// * passed a value of -1.
// * 3) The parameter value returned by ILAENV is checked for validity in
// * the calling subroutine. For example, ILAENV is used to retrieve
// * the optimal blocksize for STRTRI as follows:
// *
// * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
// * IF( NB.LE.1 ) NB = MAX( 1, N )
// *
// * =====================================================================
// *
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC CHAR, ICHAR, INT, MIN, REAL;
// * ..
// * .. External Functions ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
switch (ISPEC)
{
case 1: goto LABEL10;
case 2: goto LABEL10;
case 3: goto LABEL10;
case 4: goto LABEL80;
case 5: goto LABEL90;
case 6: goto LABEL100;
case 7: goto LABEL110;
case 8: goto LABEL120;
case 9: goto LABEL130;
case 10: goto LABEL140;
case 11: goto LABEL150;
case 12: goto LABEL160;
case 13: goto LABEL160;
case 14: goto LABEL160;
case 15: goto LABEL160;
case 16: goto LABEL160;
}
// *
// * Invalid value for ISPEC
// *
ilaenv = -1;
return(ilaenv);
// *
LABEL10 :;
// *
// * Convert NAME to upper case if the first character is lower case.
// *
ilaenv = 1;
FortranLib.Copy(ref SUBNAM, NAME);
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, 1, 1)));
IZ = Convert.ToInt32('Z');
if (IZ == 90 || IZ == 122)
{
// *
// * ASCII character set
// *
if (IC >= 97 && IC <= 122)
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if (IC >= 97 && IC <= 122)
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32));
}
}
}
// *
}
else
{
if (IZ == 233 || IZ == 169)
{
// *
// * EBCDIC character set
// *
if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169))
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC + 64));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169))
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC + 64));
}
}
}
// *
}
else
{
if (IZ == 218 || IZ == 250)
{
// *
// * Prime machines: ASCII+128
// *
if (IC >= 225 && IC <= 250)
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if (IC >= 225 && IC <= 250)
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32));
}
}
}
}
}
}
// *
FortranLib.Copy(ref C1, FortranLib.Substring(SUBNAM, 1, 1));
SNAME = C1 == "S" || C1 == "D";
CNAME = C1 == "C" || C1 == "Z";
if (!(CNAME || SNAME))
{
return(ilaenv);
}
FortranLib.Copy(ref C2, FortranLib.Substring(SUBNAM, 2, 3));
FortranLib.Copy(ref C3, FortranLib.Substring(SUBNAM, 4, 6));
FortranLib.Copy(ref C4, FortranLib.Substring(C3, 2, 3));
// *
switch (ISPEC)
{
case 1: goto LABEL50;
case 2: goto LABEL60;
case 3: goto LABEL70;
}
// *
LABEL50 :;
// *
// * ISPEC = 1: block size
// *
// * In these examples, separate code is provided for setting NB for
// * real and complex. We assume that NB will take the same value in
// * single or double precision.
// *
NB = 1;
// *
if (C2 == "GE")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
else
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "TRI")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
}
}
}
}
else
{
if (C2 == "PO")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (C2 == "SY")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
else
{
if (SNAME && C3 == "TRD")
{
NB = 32;
}
else
{
if (SNAME && C3 == "GST")
{
NB = 64;
}
}
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRF")
{
NB = 64;
}
else
{
if (C3 == "TRD")
{
NB = 32;
}
else
{
if (C3 == "GST")
{
NB = 64;
}
}
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
}
}
else
{
if (C2 == "GB")
{
if (C3 == "TRF")
{
if (SNAME)
{
if (N4 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
else
{
if (N4 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
}
}
else
{
if (C2 == "PB")
{
if (C3 == "TRF")
{
if (SNAME)
{
if (N2 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
else
{
if (N2 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
}
}
else
{
if (C2 == "TR")
{
if (C3 == "TRI")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (C2 == "LA")
{
if (C3 == "UUM")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (SNAME && C2 == "ST")
{
if (C3 == "EBZ")
{
NB = 1;
}
}
}
}
}
}
}
}
}
}
}
}
ilaenv = NB;
return(ilaenv);
// *
LABEL60 :;
// *
// * ISPEC = 2: minimum block size
// *
NBMIN = 2;
if (C2 == "GE")
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "TRI")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
}
}
}
}
else
{
if (C2 == "SY")
{
if (C3 == "TRF")
{
if (SNAME)
{
NBMIN = 8;
}
else
{
NBMIN = 8;
}
}
else
{
if (SNAME && C3 == "TRD")
{
NBMIN = 2;
}
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRD")
{
NBMIN = 2;
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
}
}
}
}
}
}
ilaenv = NBMIN;
return(ilaenv);
// *
LABEL70 :;
// *
// * ISPEC = 3: crossover point
// *
NX = 0;
if (C2 == "GE")
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
}
}
}
else
{
if (C2 == "SY")
{
if (SNAME && C3 == "TRD")
{
NX = 32;
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRD")
{
NX = 32;
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NX = 128;
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NX = 128;
}
}
}
}
}
}
}
ilaenv = NX;
return(ilaenv);
// *
LABEL80 :;
// *
// * ISPEC = 4: number of shifts (used by xHSEQR)
// *
ilaenv = 6;
return(ilaenv);
// *
LABEL90 :;
// *
// * ISPEC = 5: minimum column dimension (not used)
// *
ilaenv = 2;
return(ilaenv);
// *
LABEL100 :;
// *
// * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
// *
ilaenv = Convert.ToInt32(Math.Truncate(Convert.ToSingle(Math.Min(N1, N2)) * 1.6E0));
return(ilaenv);
// *
LABEL110 :;
// *
// * ISPEC = 7: number of processors (not used)
// *
ilaenv = 1;
return(ilaenv);
// *
LABEL120 :;
// *
// * ISPEC = 8: crossover point for multishift (used by xHSEQR)
// *
ilaenv = 50;
return(ilaenv);
// *
LABEL130 :;
// *
// * ISPEC = 9: maximum size of the subproblems at the bottom of the
// * computation tree in the divide-and-conquer algorithm
// * (used by xGELSD and xGESDD)
// *
ilaenv = 25;
return(ilaenv);
// *
LABEL140 :;
// *
// * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
// *
// * ILAENV = 0
ilaenv = 1;
if (ilaenv == 1)
{
ilaenv = this._ieeeck.Run(0, 0.0, 1.0);
}
return(ilaenv);
// *
LABEL150 :;
// *
// * ISPEC = 11: infinity arithmetic can be trusted not to trap
// *
// * ILAENV = 0
ilaenv = 1;
if (ilaenv == 1)
{
ilaenv = this._ieeeck.Run(1, 0.0, 1.0);
}
return(ilaenv);
// *
LABEL160 :;
// *
// * 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
// *
ilaenv = this._iparmq.Run(ISPEC, NAME, OPTS, N1, N2, N3, N4);
return(ilaenv);
// *
// * End of ILAENV
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DGEEV computes for an N-by-N real nonsymmetric matrix A, the
/// eigenvalues and, optionally, the left and/or right eigenvectors.
///
/// The right eigenvector v(j) of A satisfies
/// A * v(j) = lambda(j) * v(j)
/// where lambda(j) is its eigenvalue.
/// The left eigenvector u(j) of A satisfies
/// u(j)**H * A = lambda(j) * u(j)**H
/// where u(j)**H denotes the conjugate transpose of u(j).
///
/// The computed eigenvectors are normalized to have Euclidean norm
/// equal to 1 and largest component real.
///
///</summary>
/// <param name="JOBVL">
/// (input) CHARACTER*1
/// = 'N': left eigenvectors of A are not computed;
/// = 'V': left eigenvectors of A are computed.
///</param>
/// <param name="JOBVR">
/// (input) CHARACTER*1
/// = 'N': right eigenvectors of A are not computed;
/// = 'V': right eigenvectors of A are computed.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix A. N .GE. 0.
///</param>
/// <param name="A">
/// (input/output) DOUBLE PRECISION array, dimension (LDA,N)
/// On entry, the N-by-N matrix A.
/// On exit, A has been overwritten.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,N).
///</param>
/// <param name="WR">
/// (output) DOUBLE PRECISION array, dimension (N)
///</param>
/// <param name="WI">
/// (output) DOUBLE PRECISION array, dimension (N)
/// WR and WI contain the real and imaginary parts,
/// respectively, of the computed eigenvalues. Complex
/// conjugate pairs of eigenvalues appear consecutively
/// with the eigenvalue having the positive imaginary part
/// first.
///</param>
/// <param name="VL">
/// (output) DOUBLE PRECISION array, dimension (LDVL,N)
/// If JOBVL = 'V', the left eigenvectors u(j) are stored one
/// after another in the columns of VL, in the same order
/// as their eigenvalues.
/// If JOBVL = 'N', VL is not referenced.
/// If the j-th eigenvalue is real, then u(j) = VL(:,j),
/// the j-th column of VL.
/// If the j-th and (j+1)-st eigenvalues form a complex
/// conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
/// u(j+1) = VL(:,j) - i*VL(:,j+1).
///</param>
/// <param name="LDVL">
/// (input) INTEGER
/// The leading dimension of the array VL. LDVL .GE. 1; if
/// JOBVL = 'V', LDVL .GE. N.
///</param>
/// <param name="VR">
/// (output) DOUBLE PRECISION array, dimension (LDVR,N)
/// If JOBVR = 'V', the right eigenvectors v(j) are stored one
/// after another in the columns of VR, in the same order
/// as their eigenvalues.
/// If JOBVR = 'N', VR is not referenced.
/// If the j-th eigenvalue is real, then v(j) = VR(:,j),
/// the j-th column of VR.
/// If the j-th and (j+1)-st eigenvalues form a complex
/// conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
/// v(j+1) = VR(:,j) - i*VR(:,j+1).
///</param>
/// <param name="LDVR">
/// (input) INTEGER
/// The leading dimension of the array VR. LDVR .GE. 1; if
/// JOBVR = 'V', LDVR .GE. N.
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK. LWORK .GE. max(1,3*N), and
/// if JOBVL = 'V' or JOBVR = 'V', LWORK .GE. 4*N. For good
/// performance, LWORK must generally be larger.
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value.
/// .GT. 0: if INFO = i, the QR algorithm failed to compute all the
/// eigenvalues, and no eigenvectors have been computed;
/// elements i+1:N of WR and WI contain eigenvalues which
/// have converged.
///</param>
public void Run(string JOBVL, string JOBVR, int N, ref double[] A, int offset_a, int LDA, ref double[] WR, int offset_wr
, ref double[] WI, int offset_wi, ref double[] VL, int offset_vl, int LDVL, ref double[] VR, int offset_vr, int LDVR, ref double[] WORK, int offset_work
, int LWORK, ref int INFO)
{
#region Variables
bool LQUERY = false; bool SCALEA = false; bool WANTVL = false; bool WANTVR = false; string SIDE = new string(' ', 1);
int HSWORK = 0; int I = 0; int IBAL = 0; int IERR = 0; int IHI = 0; int ILO = 0; int ITAU = 0; int IWRK = 0; int K = 0;
int MAXWRK = 0; int MINWRK = 0; int NOUT = 0; double ANRM = 0; double BIGNUM = 0; double CS = 0; double CSCALE = 0;
double EPS = 0; double R = 0; double SCL = 0; double SMLNUM = 0; double SN = 0;
int offset_select = 0; int offset_dum = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi;
int o_vl = -1 - LDVL + offset_vl; int o_vr = -1 - LDVR + offset_vr; int o_work = -1 + offset_work;
#endregion
#region Strings
JOBVL = JOBVL.Substring(0, 1); JOBVR = JOBVR.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK driver routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DGEEV computes for an N-by-N real nonsymmetric matrix A, the
// * eigenvalues and, optionally, the left and/or right eigenvectors.
// *
// * The right eigenvector v(j) of A satisfies
// * A * v(j) = lambda(j) * v(j)
// * where lambda(j) is its eigenvalue.
// * The left eigenvector u(j) of A satisfies
// * u(j)**H * A = lambda(j) * u(j)**H
// * where u(j)**H denotes the conjugate transpose of u(j).
// *
// * The computed eigenvectors are normalized to have Euclidean norm
// * equal to 1 and largest component real.
// *
// * Arguments
// * =========
// *
// * JOBVL (input) CHARACTER*1
// * = 'N': left eigenvectors of A are not computed;
// * = 'V': left eigenvectors of A are computed.
// *
// * JOBVR (input) CHARACTER*1
// * = 'N': right eigenvectors of A are not computed;
// * = 'V': right eigenvectors of A are computed.
// *
// * 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.
// * On exit, A has been overwritten.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,N).
// *
// * WR (output) DOUBLE PRECISION array, dimension (N)
// * WI (output) DOUBLE PRECISION array, dimension (N)
// * WR and WI contain the real and imaginary parts,
// * respectively, of the computed eigenvalues. Complex
// * conjugate pairs of eigenvalues appear consecutively
// * with the eigenvalue having the positive imaginary part
// * first.
// *
// * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
// * If JOBVL = 'V', the left eigenvectors u(j) are stored one
// * after another in the columns of VL, in the same order
// * as their eigenvalues.
// * If JOBVL = 'N', VL is not referenced.
// * If the j-th eigenvalue is real, then u(j) = VL(:,j),
// * the j-th column of VL.
// * If the j-th and (j+1)-st eigenvalues form a complex
// * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
// * u(j+1) = VL(:,j) - i*VL(:,j+1).
// *
// * LDVL (input) INTEGER
// * The leading dimension of the array VL. LDVL >= 1; if
// * JOBVL = 'V', LDVL >= N.
// *
// * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
// * If JOBVR = 'V', the right eigenvectors v(j) are stored one
// * after another in the columns of VR, in the same order
// * as their eigenvalues.
// * If JOBVR = 'N', VR is not referenced.
// * If the j-th eigenvalue is real, then v(j) = VR(:,j),
// * the j-th column of VR.
// * If the j-th and (j+1)-st eigenvalues form a complex
// * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
// * v(j+1) = VR(:,j) - i*VR(:,j+1).
// *
// * LDVR (input) INTEGER
// * The leading dimension of the array VR. LDVR >= 1; if
// * JOBVR = 'V', LDVR >= N.
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK. LWORK >= max(1,3*N), and
// * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
// * performance, LWORK must generally be larger.
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = i, the QR algorithm failed to compute all the
// * eigenvalues, and no eigenvectors have been computed;
// * elements i+1:N of WR and WI contain eigenvalues which
// * have converged.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. External Functions ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input arguments
// *
#endregion
#region Body
INFO = 0;
LQUERY = (LWORK == -1);
WANTVL = this._lsame.Run(JOBVL, "V");
WANTVR = this._lsame.Run(JOBVR, "V");
if ((!WANTVL) && (!this._lsame.Run(JOBVL, "N")))
{
INFO = -1;
}
else
{
if ((!WANTVR) && (!this._lsame.Run(JOBVR, "N")))
{
INFO = -2;
}
else
{
if (N < 0)
{
INFO = -3;
}
else
{
if (LDA < Math.Max(1, N))
{
INFO = -5;
}
else
{
if (LDVL < 1 || (WANTVL && LDVL < N))
{
INFO = -9;
}
else
{
if (LDVR < 1 || (WANTVR && LDVR < N))
{
INFO = -11;
}
}
}
}
}
}
// *
// * Compute workspace
// * (Note: Comments in the code beginning "Workspace:" describe the
// * minimal amount of workspace needed at that point in the code,
// * as well as the preferred amount for good performance.
// * NB refers to the optimal block size for the immediately
// * following subroutine, as returned by ILAENV.
// * HSWORK refers to the workspace preferred by DHSEQR, as
// * calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
// * the worst case.)
// *
if (INFO == 0)
{
if (N == 0)
{
MINWRK = 1;
MAXWRK = 1;
}
else
{
MAXWRK = 2 * N + N * this._ilaenv.Run(1, "DGEHRD", " ", N, 1, N, 0);
if (WANTVL)
{
MINWRK = 4 * N;
MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1));
this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
MAXWRK = Math.Max(MAXWRK, 4 * N);
}
else
{
if (WANTVR)
{
MINWRK = 4 * N;
MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1));
this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
MAXWRK = Math.Max(MAXWRK, 4 * N);
}
else
{
MINWRK = 3 * N;
this._dhseqr.Run("E", "N", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
}
}
MAXWRK = Math.Max(MAXWRK, MINWRK);
}
WORK[1 + o_work] = MAXWRK;
// *
if (LWORK < MINWRK && !LQUERY)
{
INFO = -13;
}
}
// *
if (INFO != 0)
{
this._xerbla.Run("DGEEV ", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
if (N == 0)
{
return;
}
// *
// * Get machine constants
// *
EPS = this._dlamch.Run("P");
SMLNUM = this._dlamch.Run("S");
BIGNUM = ONE / SMLNUM;
this._dlabad.Run(ref SMLNUM, ref BIGNUM);
SMLNUM = Math.Sqrt(SMLNUM) / EPS;
BIGNUM = ONE / SMLNUM;
// *
// * Scale A if max element outside range [SMLNUM,BIGNUM]
// *
ANRM = this._dlange.Run("M", N, N, A, offset_a, LDA, ref DUM, offset_dum);
SCALEA = false;
if (ANRM > ZERO && ANRM < SMLNUM)
{
SCALEA = true;
CSCALE = SMLNUM;
}
else
{
if (ANRM > BIGNUM)
{
SCALEA = true;
CSCALE = BIGNUM;
}
}
if (SCALEA)
{
this._dlascl.Run("G", 0, 0, ANRM, CSCALE, N
, N, ref A, offset_a, LDA, ref IERR);
}
// *
// * Balance the matrix
// * (Workspace: need N)
// *
IBAL = 1;
this._dgebal.Run("B", N, ref A, offset_a, LDA, ref ILO, ref IHI
, ref WORK, IBAL + o_work, ref IERR);
// *
// * Reduce to upper Hessenberg form
// * (Workspace: need 3*N, prefer 2*N+N*NB)
// *
ITAU = IBAL + N;
IWRK = ITAU + N;
this._dgehrd.Run(N, ILO, IHI, ref A, offset_a, LDA, ref WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
if (WANTVL)
{
// *
// * Want left eigenvectors
// * Copy Householder vectors to VL
// *
FortranLib.Copy(ref SIDE, "L");
this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VL, offset_vl
, LDVL);
// *
// * Generate orthogonal matrix in VL
// * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
// *
this._dorghr.Run(N, ILO, IHI, ref VL, offset_vl, LDVL, WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
// * Perform QR iteration, accumulating Schur vectors in VL
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
// *
if (WANTVR)
{
// *
// * Want left and right eigenvectors
// * Copy Schur vectors to VR
// *
FortranLib.Copy(ref SIDE, "B");
this._dlacpy.Run("F", N, N, VL, offset_vl, LDVL, ref VR, offset_vr
, LDVR);
}
// *
}
else
{
if (WANTVR)
{
// *
// * Want right eigenvectors
// * Copy Householder vectors to VR
// *
FortranLib.Copy(ref SIDE, "R");
this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VR, offset_vr
, LDVR);
// *
// * Generate orthogonal matrix in VR
// * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
// *
this._dorghr.Run(N, ILO, IHI, ref VR, offset_vr, LDVR, WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
// * Perform QR iteration, accumulating Schur vectors in VR
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
// *
}
else
{
// *
// * Compute eigenvalues only
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("E", "N", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
}
}
// *
// * If INFO > 0 from DHSEQR, then quit
// *
if (INFO > 0)
{
goto LABEL50;
}
// *
if (WANTVL || WANTVR)
{
// *
// * Compute left and/or right eigenvectors
// * (Workspace: need 4*N)
// *
this._dtrevc.Run(SIDE, "B", ref SELECT, offset_select, N, A, offset_a, LDA
, ref VL, offset_vl, LDVL, ref VR, offset_vr, LDVR, N, ref NOUT
, ref WORK, IWRK + o_work, ref IERR);
}
// *
if (WANTVL)
{
// *
// * Undo balancing of left eigenvectors
// * (Workspace: need N)
// *
this._dgebak.Run("B", "L", N, ILO, IHI, WORK, IBAL + o_work
, N, ref VL, offset_vl, LDVL, ref IERR);
// *
// * Normalize left eigenvectors and make largest component real
// *
for (I = 1; I <= N; I++)
{
if (WI[I + o_wi] == ZERO)
{
SCL = ONE / this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1);
this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1);
}
else
{
if (WI[I + o_wi] > ZERO)
{
SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1), this._dnrm2.Run(N, VL, 1 + (I + 1) * LDVL + o_vl, 1));
this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1);
this._dscal.Run(N, SCL, ref VL, 1 + (I + 1) * LDVL + o_vl, 1);
for (K = 1; K <= N; K++)
{
WORK[IWRK + K - 1 + o_work] = Math.Pow(VL[K + I * LDVL + o_vl], 2) + Math.Pow(VL[K + (I + 1) * LDVL + o_vl], 2);
}
K = this._idamax.Run(N, WORK, IWRK + o_work, 1);
this._dlartg.Run(VL[K + I * LDVL + o_vl], VL[K + (I + 1) * LDVL + o_vl], ref CS, ref SN, ref R);
this._drot.Run(N, ref VL, 1 + I * LDVL + o_vl, 1, ref VL, 1 + (I + 1) * LDVL + o_vl, 1, CS
, SN);
VL[K + (I + 1) * LDVL + o_vl] = ZERO;
}
}
}
}
// *
if (WANTVR)
{
// *
// * Undo balancing of right eigenvectors
// * (Workspace: need N)
// *
this._dgebak.Run("B", "R", N, ILO, IHI, WORK, IBAL + o_work
, N, ref VR, offset_vr, LDVR, ref IERR);
// *
// * Normalize right eigenvectors and make largest component real
// *
for (I = 1; I <= N; I++)
{
if (WI[I + o_wi] == ZERO)
{
SCL = ONE / this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1);
this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1);
}
else
{
if (WI[I + o_wi] > ZERO)
{
SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1), this._dnrm2.Run(N, VR, 1 + (I + 1) * LDVR + o_vr, 1));
this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1);
this._dscal.Run(N, SCL, ref VR, 1 + (I + 1) * LDVR + o_vr, 1);
for (K = 1; K <= N; K++)
{
WORK[IWRK + K - 1 + o_work] = Math.Pow(VR[K + I * LDVR + o_vr], 2) + Math.Pow(VR[K + (I + 1) * LDVR + o_vr], 2);
}
K = this._idamax.Run(N, WORK, IWRK + o_work, 1);
this._dlartg.Run(VR[K + I * LDVR + o_vr], VR[K + (I + 1) * LDVR + o_vr], ref CS, ref SN, ref R);
this._drot.Run(N, ref VR, 1 + I * LDVR + o_vr, 1, ref VR, 1 + (I + 1) * LDVR + o_vr, 1, CS
, SN);
VR[K + (I + 1) * LDVR + o_vr] = ZERO;
}
}
}
}
// *
// * Undo scaling if necessary
// *
LABEL50 :;
if (SCALEA)
{
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO
, 1, ref WR, INFO + 1 + o_wr, Math.Max(N - INFO, 1), ref IERR);
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO
, 1, ref WI, INFO + 1 + o_wi, Math.Max(N - INFO, 1), ref IERR);
if (INFO > 0)
{
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1
, 1, ref WR, offset_wr, N, ref IERR);
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1
, 1, ref WI, offset_wi, N, ref IERR);
}
}
// *
WORK[1 + o_work] = MAXWRK;
return;
// *
// * End of DGEEV
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DTRCON estimates the reciprocal of the condition number of a
/// triangular matrix A, in either the 1-norm or the infinity-norm.
///
/// The norm of A is computed and an estimate is obtained for
/// norm(inv(A)), then the reciprocal of the condition number is
/// computed as
/// RCOND = 1 / ( norm(A) * norm(inv(A)) ).
///
///</summary>
/// <param name="NORM">
/// (input) CHARACTER*1
/// Specifies whether the 1-norm condition number or the
/// infinity-norm condition number is required:
/// = '1' or 'O': 1-norm;
/// = 'I': Infinity-norm.
///</param>
/// <param name="UPLO">
/// (input) CHARACTER*1
/// = 'U': A is upper triangular;
/// = 'L': A is lower triangular.
///</param>
/// <param name="DIAG">
/// (input) CHARACTER*1
/// = 'N': A is non-unit triangular;
/// = 'U': A is unit triangular.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix A. N .GE. 0.
///</param>
/// <param name="A">
/// (input) DOUBLE PRECISION array, dimension (LDA,N)
/// The triangular matrix A. If UPLO = 'U', the leading N-by-N
/// upper triangular part of the array A contains the upper
/// triangular matrix, and the strictly lower triangular part of
/// A is not referenced. If UPLO = 'L', the leading N-by-N lower
/// triangular part of the array A contains the lower triangular
/// matrix, and the strictly upper triangular part of A is not
/// referenced. If DIAG = 'U', the diagonal elements of A are
/// also not referenced and are assumed to be 1.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,N).
///</param>
/// <param name="RCOND">
/// (output) DOUBLE PRECISION
/// The reciprocal of the condition number of the matrix A,
/// computed as RCOND = 1/(norm(A) * norm(inv(A))).
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (3*N)
///</param>
/// <param name="IWORK">
/// (workspace) INTEGER array, dimension (N)
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
///</param>
public void Run(string NORM, string UPLO, string DIAG, int N, double[] A, int offset_a, int LDA
, ref double RCOND, ref double[] WORK, int offset_work, ref int[] IWORK, int offset_iwork, ref int INFO)
{
#region Variables
bool NOUNIT = false; bool ONENRM = false; bool UPPER = false; string NORMIN = new string(' ', 1); int IX = 0;
int KASE = 0; int KASE1 = 0; double AINVNM = 0; double ANORM = 0; double SCALE = 0; double SMLNUM = 0;
double XNORM = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork;
#endregion
#region Strings
NORM = NORM.Substring(0, 1); UPLO = UPLO.Substring(0, 1); DIAG = DIAG.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.0) --
// * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
// * Courant Institute, Argonne National Lab, and Rice University
// * March 31, 1993
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DTRCON estimates the reciprocal of the condition number of a
// * triangular matrix A, in either the 1-norm or the infinity-norm.
// *
// * The norm of A is computed and an estimate is obtained for
// * norm(inv(A)), then the reciprocal of the condition number is
// * computed as
// * RCOND = 1 / ( norm(A) * norm(inv(A)) ).
// *
// * Arguments
// * =========
// *
// * NORM (input) CHARACTER*1
// * Specifies whether the 1-norm condition number or the
// * infinity-norm condition number is required:
// * = '1' or 'O': 1-norm;
// * = 'I': Infinity-norm.
// *
// * UPLO (input) CHARACTER*1
// * = 'U': A is upper triangular;
// * = 'L': A is lower triangular.
// *
// * DIAG (input) CHARACTER*1
// * = 'N': A is non-unit triangular;
// * = 'U': A is unit triangular.
// *
// * N (input) INTEGER
// * The order of the matrix A. N >= 0.
// *
// * A (input) DOUBLE PRECISION array, dimension (LDA,N)
// * The triangular matrix A. If UPLO = 'U', the leading N-by-N
// * upper triangular part of the array A contains the upper
// * triangular matrix, and the strictly lower triangular part of
// * A is not referenced. If UPLO = 'L', the leading N-by-N lower
// * triangular part of the array A contains the lower triangular
// * matrix, and the strictly upper triangular part of A is not
// * referenced. If DIAG = 'U', the diagonal elements of A are
// * also not referenced and are assumed to be 1.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,N).
// *
// * RCOND (output) DOUBLE PRECISION
// * The reciprocal of the condition number of the matrix A,
// * computed as RCOND = 1/(norm(A) * norm(inv(A))).
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
// *
// * IWORK (workspace) INTEGER array, dimension (N)
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, MAX;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
UPPER = this._lsame.Run(UPLO, "U");
ONENRM = NORM == "1" || this._lsame.Run(NORM, "O");
NOUNIT = this._lsame.Run(DIAG, "N");
// *
if (!ONENRM && !this._lsame.Run(NORM, "I"))
{
INFO = -1;
}
else
{
if (!UPPER && !this._lsame.Run(UPLO, "L"))
{
INFO = -2;
}
else
{
if (!NOUNIT && !this._lsame.Run(DIAG, "U"))
{
INFO = -3;
}
else
{
if (N < 0)
{
INFO = -4;
}
else
{
if (LDA < Math.Max(1, N))
{
INFO = -6;
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DTRCON", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (N == 0)
{
RCOND = ONE;
return;
}
// *
RCOND = ZERO;
SMLNUM = this._dlamch.Run("Safe minimum") * Convert.ToDouble(Math.Max(1, N));
// *
// * Compute the norm of the triangular matrix A.
// *
ANORM = this._dlantr.Run(NORM, UPLO, DIAG, N, N, A, offset_a, LDA, ref WORK, offset_work);
// *
// * Continue only if ANORM > 0.
// *
if (ANORM > ZERO)
{
// *
// * Estimate the norm of the inverse of A.
// *
AINVNM = ZERO;
FortranLib.Copy(ref NORMIN, "N");
if (ONENRM)
{
KASE1 = 1;
}
else
{
KASE1 = 2;
}
KASE = 0;
LABEL10 :;
this._dlacon.Run(N, ref WORK, N + 1 + o_work, ref WORK, offset_work, ref IWORK, offset_iwork, ref AINVNM, ref KASE);
if (KASE != 0)
{
if (KASE == KASE1)
{
// *
// * Multiply by inv(A).
// *
this._dlatrs.Run(UPLO, "No transpose", DIAG, NORMIN, N, A, offset_a
, LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO);
}
else
{
// *
// * Multiply by inv(A').
// *
this._dlatrs.Run(UPLO, "Transpose", DIAG, NORMIN, N, A, offset_a
, LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO);
}
FortranLib.Copy(ref NORMIN, "Y");
// *
// * Multiply by 1/SCALE if doing so will not cause overflow.
// *
if (SCALE != ONE)
{
IX = this._idamax.Run(N, WORK, offset_work, 1);
XNORM = Math.Abs(WORK[IX + o_work]);
if (SCALE < XNORM * SMLNUM || SCALE == ZERO)
{
goto LABEL20;
}
this._drscl.Run(N, SCALE, ref WORK, offset_work, 1);
}
goto LABEL10;
}
// *
// * Compute the estimate of the reciprocal condition number.
// *
if (AINVNM != ZERO)
{
RCOND = (ONE / ANORM) / AINVNM;
}
}
// *
LABEL20 :;
return;
// *
// * End of DTRCON
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
/// with
/// SIDE = 'L' SIDE = 'R'
/// TRANS = 'N': Q * C C * Q
/// TRANS = 'T': Q**T * C C * Q**T
///
/// If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
/// with
/// SIDE = 'L' SIDE = 'R'
/// TRANS = 'N': P * C C * P
/// TRANS = 'T': P**T * C C * P**T
///
/// Here Q and P**T are the orthogonal matrices determined by DGEBRD when
/// reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
/// P**T are defined as products of elementary reflectors H(i) and G(i)
/// respectively.
///
/// Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
/// order of the orthogonal matrix Q or P**T that is applied.
///
/// If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
/// if nq .GE. k, Q = H(1) H(2) . . . H(k);
/// if nq .LT. k, Q = H(1) H(2) . . . H(nq-1).
///
/// If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
/// if k .LT. nq, P = G(1) G(2) . . . G(k);
/// if k .GE. nq, P = G(1) G(2) . . . G(nq-1).
///
///</summary>
/// <param name="VECT">
/// (input) CHARACTER*1
/// = 'Q': apply Q or Q**T;
/// = 'P': apply P or P**T.
///</param>
/// <param name="SIDE">
/// (input) CHARACTER*1
/// = 'L': apply Q, Q**T, P or P**T from the Left;
/// = 'R': apply Q, Q**T, P or P**T from the Right.
///</param>
/// <param name="TRANS">
/// (input) CHARACTER*1
/// = 'N': No transpose, apply Q or P;
/// = 'T': Transpose, apply Q**T or P**T.
///</param>
/// <param name="M">
/// (input) INTEGER
/// The number of rows of the matrix C. M .GE. 0.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of columns of the matrix C. N .GE. 0.
///</param>
/// <param name="K">
/// (input) INTEGER
/// If VECT = 'Q', the number of columns in the original
/// matrix reduced by DGEBRD.
/// If VECT = 'P', the number of rows in the original
/// matrix reduced by DGEBRD.
/// K .GE. 0.
///</param>
/// <param name="A">
/// (input) DOUBLE PRECISION array, dimension
/// (LDA,min(nq,K)) if VECT = 'Q'
/// (LDA,nq) if VECT = 'P'
/// The vectors which define the elementary reflectors H(i) and
/// G(i), whose products determine the matrices Q and P, as
/// returned by DGEBRD.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A.
/// If VECT = 'Q', LDA .GE. max(1,nq);
/// if VECT = 'P', LDA .GE. max(1,min(nq,K)).
///</param>
/// <param name="TAU">
/// (input) DOUBLE PRECISION array, dimension (min(nq,K))
/// TAU(i) must contain the scalar factor of the elementary
/// reflector H(i) or G(i) which determines Q or P, as returned
/// by DGEBRD in the array argument TAUQ or TAUP.
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC,N)
/// On entry, the M-by-N matrix C.
/// On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
/// or P*C or P**T*C or C*P or C*P**T.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C. LDC .GE. max(1,M).
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK.
/// If SIDE = 'L', LWORK .GE. max(1,N);
/// if SIDE = 'R', LWORK .GE. max(1,M).
/// For optimum performance LWORK .GE. N*NB if SIDE = 'L', and
/// LWORK .GE. M*NB if SIDE = 'R', where NB is the optimal
/// blocksize.
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
///</param>
public void Run(string VECT, string SIDE, string TRANS, int M, int N, int K
, ref double[] A, int offset_a, int LDA, double[] TAU, int offset_tau, ref double[] C, int offset_c, int LDC, ref double[] WORK, int offset_work
, int LWORK, ref int INFO)
{
#region Variables
bool APPLYQ = false; bool LEFT = false; bool LQUERY = false; bool NOTRAN = false; string TRANST = new string(' ', 1);
int I1 = 0; int I2 = 0; int IINFO = 0; int LWKOPT = 0; int MI = 0; int NB = 0; int NI = 0; int NQ = 0; int NW = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_tau = -1 + offset_tau; int o_c = -1 - LDC + offset_c;
int o_work = -1 + offset_work;
#endregion
#region Strings
VECT = VECT.Substring(0, 1); SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
// * with
// * SIDE = 'L' SIDE = 'R'
// * TRANS = 'N': Q * C C * Q
// * TRANS = 'T': Q**T * C C * Q**T
// *
// * If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
// * with
// * SIDE = 'L' SIDE = 'R'
// * TRANS = 'N': P * C C * P
// * TRANS = 'T': P**T * C C * P**T
// *
// * Here Q and P**T are the orthogonal matrices determined by DGEBRD when
// * reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
// * P**T are defined as products of elementary reflectors H(i) and G(i)
// * respectively.
// *
// * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
// * order of the orthogonal matrix Q or P**T that is applied.
// *
// * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
// * if nq >= k, Q = H(1) H(2) . . . H(k);
// * if nq < k, Q = H(1) H(2) . . . H(nq-1).
// *
// * If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
// * if k < nq, P = G(1) G(2) . . . G(k);
// * if k >= nq, P = G(1) G(2) . . . G(nq-1).
// *
// * Arguments
// * =========
// *
// * VECT (input) CHARACTER*1
// * = 'Q': apply Q or Q**T;
// * = 'P': apply P or P**T.
// *
// * SIDE (input) CHARACTER*1
// * = 'L': apply Q, Q**T, P or P**T from the Left;
// * = 'R': apply Q, Q**T, P or P**T from the Right.
// *
// * TRANS (input) CHARACTER*1
// * = 'N': No transpose, apply Q or P;
// * = 'T': Transpose, apply Q**T or P**T.
// *
// * M (input) INTEGER
// * The number of rows of the matrix C. M >= 0.
// *
// * N (input) INTEGER
// * The number of columns of the matrix C. N >= 0.
// *
// * K (input) INTEGER
// * If VECT = 'Q', the number of columns in the original
// * matrix reduced by DGEBRD.
// * If VECT = 'P', the number of rows in the original
// * matrix reduced by DGEBRD.
// * K >= 0.
// *
// * A (input) DOUBLE PRECISION array, dimension
// * (LDA,min(nq,K)) if VECT = 'Q'
// * (LDA,nq) if VECT = 'P'
// * The vectors which define the elementary reflectors H(i) and
// * G(i), whose products determine the matrices Q and P, as
// * returned by DGEBRD.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A.
// * If VECT = 'Q', LDA >= max(1,nq);
// * if VECT = 'P', LDA >= max(1,min(nq,K)).
// *
// * TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))
// * TAU(i) must contain the scalar factor of the elementary
// * reflector H(i) or G(i) which determines Q or P, as returned
// * by DGEBRD in the array argument TAUQ or TAUP.
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
// * On entry, the M-by-N matrix C.
// * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
// * or P*C or P**T*C or C*P or C*P**T.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C. LDC >= max(1,M).
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK.
// * If SIDE = 'L', LWORK >= max(1,N);
// * if SIDE = 'R', LWORK >= max(1,M).
// * For optimum performance LWORK >= N*NB if SIDE = 'L', and
// * LWORK >= M*NB if SIDE = 'R', where NB is the optimal
// * blocksize.
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// *
// * =====================================================================
// *
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, MIN;
// * ..
// * .. Executable Statements ..
// *
// * Test the input arguments
// *
#endregion
#region Body
INFO = 0;
APPLYQ = this._lsame.Run(VECT, "Q");
LEFT = this._lsame.Run(SIDE, "L");
NOTRAN = this._lsame.Run(TRANS, "N");
LQUERY = (LWORK == -1);
// *
// * NQ is the order of Q or P and NW is the minimum dimension of WORK
// *
if (LEFT)
{
NQ = M;
NW = N;
}
else
{
NQ = N;
NW = M;
}
if (!APPLYQ && !this._lsame.Run(VECT, "P"))
{
INFO = -1;
}
else
{
if (!LEFT && !this._lsame.Run(SIDE, "R"))
{
INFO = -2;
}
else
{
if (!NOTRAN && !this._lsame.Run(TRANS, "T"))
{
INFO = -3;
}
else
{
if (M < 0)
{
INFO = -4;
}
else
{
if (N < 0)
{
INFO = -5;
}
else
{
if (K < 0)
{
INFO = -6;
}
else
{
if ((APPLYQ && LDA < Math.Max(1, NQ)) || (!APPLYQ && LDA < Math.Max(1, Math.Min(NQ, K))))
{
INFO = -8;
}
else
{
if (LDC < Math.Max(1, M))
{
INFO = -11;
}
else
{
if (LWORK < Math.Max(1, NW) && !LQUERY)
{
INFO = -13;
}
}
}
}
}
}
}
}
}
// *
if (INFO == 0)
{
if (APPLYQ)
{
if (LEFT)
{
NB = this._ilaenv.Run(1, "DORMQR", SIDE + TRANS, M - 1, N, M - 1, -1);
}
else
{
NB = this._ilaenv.Run(1, "DORMQR", SIDE + TRANS, M, N - 1, N - 1, -1);
}
}
else
{
if (LEFT)
{
NB = this._ilaenv.Run(1, "DORMLQ", SIDE + TRANS, M - 1, N, M - 1, -1);
}
else
{
NB = this._ilaenv.Run(1, "DORMLQ", SIDE + TRANS, M, N - 1, N - 1, -1);
}
}
LWKOPT = Math.Max(1, NW) * NB;
WORK[1 + o_work] = LWKOPT;
}
// *
if (INFO != 0)
{
this._xerbla.Run("DORMBR", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
WORK[1 + o_work] = 1;
if (M == 0 || N == 0)
{
return;
}
// *
if (APPLYQ)
{
// *
// * Apply Q
// *
if (NQ >= K)
{
// *
// * Q was determined by a call to DGEBRD with nq >= k
// *
this._dormqr.Run(SIDE, TRANS, M, N, K, ref A, offset_a
, LDA, TAU, offset_tau, ref C, offset_c, LDC, ref WORK, offset_work, LWORK
, ref IINFO);
}
else
{
if (NQ > 1)
{
// *
// * Q was determined by a call to DGEBRD with nq < k
// *
if (LEFT)
{
MI = M - 1;
NI = N;
I1 = 2;
I2 = 1;
}
else
{
MI = M;
NI = N - 1;
I1 = 1;
I2 = 2;
}
this._dormqr.Run(SIDE, TRANS, MI, NI, NQ - 1, ref A, 2 + 1 * LDA + o_a
, LDA, TAU, offset_tau, ref C, I1 + I2 * LDC + o_c, LDC, ref WORK, offset_work, LWORK
, ref IINFO);
}
}
}
else
{
// *
// * Apply P
// *
if (NOTRAN)
{
FortranLib.Copy(ref TRANST, "T");
}
else
{
FortranLib.Copy(ref TRANST, "N");
}
if (NQ > K)
{
// *
// * P was determined by a call to DGEBRD with nq > k
// *
this._dormlq.Run(SIDE, TRANST, M, N, K, ref A, offset_a
, LDA, TAU, offset_tau, ref C, offset_c, LDC, ref WORK, offset_work, LWORK
, ref IINFO);
}
else
{
if (NQ > 1)
{
// *
// * P was determined by a call to DGEBRD with nq <= k
// *
if (LEFT)
{
MI = M - 1;
NI = N;
I1 = 2;
I2 = 1;
}
else
{
MI = M;
NI = N - 1;
I1 = 1;
I2 = 2;
}
this._dormlq.Run(SIDE, TRANST, MI, NI, NQ - 1, ref A, 1 + 2 * LDA + o_a
, LDA, TAU, offset_tau, ref C, I1 + I2 * LDC + o_c, LDC, ref WORK, offset_work, LWORK
, ref IINFO);
}
}
}
WORK[1 + o_work] = LWKOPT;
return;
// *
// * End of DORMBR
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLARZB applies a real block reflector H or its transpose H**T to
/// a real distributed M-by-N C from the left or the right.
///
/// Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
///
///</summary>
/// <param name="SIDE">
/// (input) CHARACTER*1
/// = 'L': apply H or H' from the Left
/// = 'R': apply H or H' from the Right
///</param>
/// <param name="TRANS">
/// (input) CHARACTER*1
/// = 'N': apply H (No transpose)
/// = 'C': apply H' (Transpose)
///</param>
/// <param name="DIRECT">
/// (input) CHARACTER*1
/// Indicates how H is formed from a product of elementary
/// reflectors
/// = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
/// = 'B': H = H(k) . . . H(2) H(1) (Backward)
///</param>
/// <param name="STOREV">
/// (input) CHARACTER*1
/// Indicates how the vectors which define the elementary
/// reflectors are stored:
/// = 'C': Columnwise (not supported yet)
/// = 'R': Rowwise
///</param>
/// <param name="M">
/// (input) INTEGER
/// The number of rows of the matrix C.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of columns of the matrix C.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The order of the matrix T (= the number of elementary
/// reflectors whose product defines the block reflector).
///</param>
/// <param name="L">
/// (input) INTEGER
/// The number of columns of the matrix V containing the
/// meaningful part of the Householder reflectors.
/// If SIDE = 'L', M .GE. L .GE. 0, if SIDE = 'R', N .GE. L .GE. 0.
///</param>
/// <param name="V">
/// (input) DOUBLE PRECISION array, dimension (LDV,NV).
/// If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
///</param>
/// <param name="LDV">
/// (input) INTEGER
/// The leading dimension of the array V.
/// If STOREV = 'C', LDV .GE. L; if STOREV = 'R', LDV .GE. K.
///</param>
/// <param name="T">
/// (input) DOUBLE PRECISION array, dimension (LDT,K)
/// The triangular K-by-K matrix T in the representation of the
/// block reflector.
///</param>
/// <param name="LDT">
/// (input) INTEGER
/// The leading dimension of the array T. LDT .GE. K.
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC,N)
/// On entry, the M-by-N matrix C.
/// On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C. LDC .GE. max(1,M).
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
///</param>
/// <param name="LDWORK">
/// (input) INTEGER
/// The leading dimension of the array WORK.
/// If SIDE = 'L', LDWORK .GE. max(1,N);
/// if SIDE = 'R', LDWORK .GE. max(1,M).
///</param>
public void Run(string SIDE, string TRANS, string DIRECT, string STOREV, int M, int N
, int K, int L, double[] V, int offset_v, int LDV, double[] T, int offset_t, int LDT
, ref double[] C, int offset_c, int LDC, ref double[] WORK, int offset_work, int LDWORK)
{
#region Variables
string TRANST = new string(' ', 1); int I = 0; int INFO = 0; int J = 0;
#endregion
#region Implicit Variables
int C_J = 0; int WORK_J = 0;
#endregion
#region Array Index Correction
int o_v = -1 - LDV + offset_v; int o_t = -1 - LDT + offset_t; int o_c = -1 - LDC + offset_c;
int o_work = -1 - LDWORK + offset_work;
#endregion
#region Strings
SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1); DIRECT = DIRECT.Substring(0, 1);
STOREV = STOREV.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLARZB applies a real block reflector H or its transpose H**T to
// * a real distributed M-by-N C from the left or the right.
// *
// * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
// *
// * Arguments
// * =========
// *
// * SIDE (input) CHARACTER*1
// * = 'L': apply H or H' from the Left
// * = 'R': apply H or H' from the Right
// *
// * TRANS (input) CHARACTER*1
// * = 'N': apply H (No transpose)
// * = 'C': apply H' (Transpose)
// *
// * DIRECT (input) CHARACTER*1
// * Indicates how H is formed from a product of elementary
// * reflectors
// * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
// * = 'B': H = H(k) . . . H(2) H(1) (Backward)
// *
// * STOREV (input) CHARACTER*1
// * Indicates how the vectors which define the elementary
// * reflectors are stored:
// * = 'C': Columnwise (not supported yet)
// * = 'R': Rowwise
// *
// * M (input) INTEGER
// * The number of rows of the matrix C.
// *
// * N (input) INTEGER
// * The number of columns of the matrix C.
// *
// * K (input) INTEGER
// * The order of the matrix T (= the number of elementary
// * reflectors whose product defines the block reflector).
// *
// * L (input) INTEGER
// * The number of columns of the matrix V containing the
// * meaningful part of the Householder reflectors.
// * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
// *
// * V (input) DOUBLE PRECISION array, dimension (LDV,NV).
// * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
// *
// * LDV (input) INTEGER
// * The leading dimension of the array V.
// * If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
// *
// * T (input) DOUBLE PRECISION array, dimension (LDT,K)
// * The triangular K-by-K matrix T in the representation of the
// * block reflector.
// *
// * LDT (input) INTEGER
// * The leading dimension of the array T. LDT >= K.
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
// * On entry, the M-by-N matrix C.
// * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C. LDC >= max(1,M).
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
// *
// * LDWORK (input) INTEGER
// * The leading dimension of the array WORK.
// * If SIDE = 'L', LDWORK >= max(1,N);
// * if SIDE = 'R', LDWORK >= max(1,M).
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Executable Statements ..
// *
// * Quick return if possible
// *
#endregion
#region Body
if (M <= 0 || N <= 0)
{
return;
}
// *
// * Check for currently supported options
// *
INFO = 0;
if (!this._lsame.Run(DIRECT, "B"))
{
INFO = -3;
}
else
{
if (!this._lsame.Run(STOREV, "R"))
{
INFO = -4;
}
}
if (INFO != 0)
{
this._xerbla.Run("DLARZB", -INFO);
return;
}
// *
if (this._lsame.Run(TRANS, "N"))
{
FortranLib.Copy(ref TRANST, "T");
}
else
{
FortranLib.Copy(ref TRANST, "N");
}
// *
if (this._lsame.Run(SIDE, "L"))
{
// *
// * Form H * C or H' * C
// *
// * W( 1:n, 1:k ) = C( 1:k, 1:n )'
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(N, C, J + 1 * LDC + o_c, LDC, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
// * C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
// *
if (L > 0)
{
this._dgemm.Run("Transpose", "Transpose", N, K, L, ONE
, C, M - L + 1 + 1 * LDC + o_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T
// *
this._dtrmm.Run("Right", "Lower", TRANST, "Non-unit", N, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
// *
for (J = 1; J <= N; J++)
{
C_J = J * LDC + o_c;
for (I = 1; I <= K; I++)
{
C[I + C_J] -= WORK[J + I * LDWORK + o_work];
}
}
// *
// * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
// * V( 1:k, 1:l )' * W( 1:n, 1:k )'
// *
if (L > 0)
{
this._dgemm.Run("Transpose", "Transpose", L, N, K, -ONE
, V, offset_v, LDV, WORK, offset_work, LDWORK, ONE, ref C, M - L + 1 + 1 * LDC + o_c
, LDC);
}
// *
}
else
{
if (this._lsame.Run(SIDE, "R"))
{
// *
// * Form C * H or C * H'
// *
// * W( 1:m, 1:k ) = C( 1:m, 1:k )
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(M, C, 1 + J * LDC + o_c, 1, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
// * C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
// *
if (L > 0)
{
this._dgemm.Run("No transpose", "Transpose", M, K, L, ONE
, C, 1 + (N - L + 1) * LDC + o_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T'
// *
this._dtrmm.Run("Right", "Lower", TRANS, "Non-unit", M, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
// *
for (J = 1; J <= K; J++)
{
C_J = J * LDC + o_c;
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= M; I++)
{
C[I + C_J] -= WORK[I + WORK_J];
}
}
// *
// * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
// * W( 1:m, 1:k ) * V( 1:k, 1:l )
// *
if (L > 0)
{
this._dgemm.Run("No transpose", "No transpose", M, L, K, -ONE
, WORK, offset_work, LDWORK, V, offset_v, LDV, ONE, ref C, 1 + (N - L + 1) * LDC + o_c
, LDC);
}
// *
}
}
// *
return;
// *
// * End of DLARZB
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLARFB applies a real block reflector H or its transpose H' to a
/// real m by n matrix C, from either the left or the right.
///
///</summary>
/// <param name="SIDE">
/// (input) CHARACTER*1
/// = 'L': apply H or H' from the Left
/// = 'R': apply H or H' from the Right
///</param>
/// <param name="TRANS">
/// (input) CHARACTER*1
/// = 'N': apply H (No transpose)
/// = 'T': apply H' (Transpose)
///</param>
/// <param name="DIRECT">
/// (input) CHARACTER*1
/// Indicates how H is formed from a product of elementary
/// reflectors
/// = 'F': H = H(1) H(2) . . . H(k) (Forward)
/// = 'B': H = H(k) . . . H(2) H(1) (Backward)
///</param>
/// <param name="STOREV">
/// (input) CHARACTER*1
/// Indicates how the vectors which define the elementary
/// reflectors are stored:
/// = 'C': Columnwise
/// = 'R': Rowwise
///</param>
/// <param name="M">
/// (input) INTEGER
/// The number of rows of the matrix C.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of columns of the matrix C.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The order of the matrix T (= the number of elementary
/// reflectors whose product defines the block reflector).
///</param>
/// <param name="V">
/// (input) DOUBLE PRECISION array, dimension
/// (LDV,K) if STOREV = 'C'
/// (LDV,M) if STOREV = 'R' and SIDE = 'L'
/// (LDV,N) if STOREV = 'R' and SIDE = 'R'
/// The matrix V. See further details.
///</param>
/// <param name="LDV">
/// (input) INTEGER
/// The leading dimension of the array V.
/// If STOREV = 'C' and SIDE = 'L', LDV .GE. max(1,M);
/// if STOREV = 'C' and SIDE = 'R', LDV .GE. max(1,N);
/// if STOREV = 'R', LDV .GE. K.
///</param>
/// <param name="T">
/// (input) DOUBLE PRECISION array, dimension (LDT,K)
/// The triangular k by k matrix T in the representation of the
/// block reflector.
///</param>
/// <param name="LDT">
/// (input) INTEGER
/// The leading dimension of the array T. LDT .GE. K.
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC,N)
/// On entry, the m by n matrix C.
/// On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C. LDA .GE. max(1,M).
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
///</param>
/// <param name="LDWORK">
/// (input) INTEGER
/// The leading dimension of the array WORK.
/// If SIDE = 'L', LDWORK .GE. max(1,N);
/// if SIDE = 'R', LDWORK .GE. max(1,M).
///</param>
public void Run(string SIDE, string TRANS, string DIRECT, string STOREV, int M, int N
, int K, double[] V, int offset_v, int LDV, double[] T, int offset_t, int LDT, ref double[] C, int offset_c
, int LDC, ref double[] WORK, int offset_work, int LDWORK)
{
#region Variables
string TRANST = new string(' ', 1); int I = 0; int J = 0;
#endregion
#region Implicit Variables
int WORK_J = 0; int C_J = 0; int C_0 = 0; int C_1 = 0;
#endregion
#region Array Index Correction
int o_v = -1 - LDV + offset_v; int o_t = -1 - LDT + offset_t; int o_c = -1 - LDC + offset_c;
int o_work = -1 - LDWORK + offset_work;
#endregion
#region Strings
SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1); DIRECT = DIRECT.Substring(0, 1);
STOREV = STOREV.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLARFB applies a real block reflector H or its transpose H' to a
// * real m by n matrix C, from either the left or the right.
// *
// * Arguments
// * =========
// *
// * SIDE (input) CHARACTER*1
// * = 'L': apply H or H' from the Left
// * = 'R': apply H or H' from the Right
// *
// * TRANS (input) CHARACTER*1
// * = 'N': apply H (No transpose)
// * = 'T': apply H' (Transpose)
// *
// * DIRECT (input) CHARACTER*1
// * Indicates how H is formed from a product of elementary
// * reflectors
// * = 'F': H = H(1) H(2) . . . H(k) (Forward)
// * = 'B': H = H(k) . . . H(2) H(1) (Backward)
// *
// * STOREV (input) CHARACTER*1
// * Indicates how the vectors which define the elementary
// * reflectors are stored:
// * = 'C': Columnwise
// * = 'R': Rowwise
// *
// * M (input) INTEGER
// * The number of rows of the matrix C.
// *
// * N (input) INTEGER
// * The number of columns of the matrix C.
// *
// * K (input) INTEGER
// * The order of the matrix T (= the number of elementary
// * reflectors whose product defines the block reflector).
// *
// * V (input) DOUBLE PRECISION array, dimension
// * (LDV,K) if STOREV = 'C'
// * (LDV,M) if STOREV = 'R' and SIDE = 'L'
// * (LDV,N) if STOREV = 'R' and SIDE = 'R'
// * The matrix V. See further details.
// *
// * LDV (input) INTEGER
// * The leading dimension of the array V.
// * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
// * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
// * if STOREV = 'R', LDV >= K.
// *
// * T (input) DOUBLE PRECISION array, dimension (LDT,K)
// * The triangular k by k matrix T in the representation of the
// * block reflector.
// *
// * LDT (input) INTEGER
// * The leading dimension of the array T. LDT >= K.
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
// * On entry, the m by n matrix C.
// * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C. LDA >= max(1,M).
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
// *
// * LDWORK (input) INTEGER
// * The leading dimension of the array WORK.
// * If SIDE = 'L', LDWORK >= max(1,N);
// * if SIDE = 'R', LDWORK >= max(1,M).
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Executable Statements ..
// *
// * Quick return if possible
// *
#endregion
#region Body
if (M <= 0 || N <= 0)
{
return;
}
// *
if (this._lsame.Run(TRANS, "N"))
{
FortranLib.Copy(ref TRANST, "T");
}
else
{
FortranLib.Copy(ref TRANST, "N");
}
// *
if (this._lsame.Run(STOREV, "C"))
{
// *
if (this._lsame.Run(DIRECT, "F"))
{
// *
// * Let V = ( V1 ) (first K rows)
// * ( V2 )
// * where V1 is unit lower triangular.
// *
if (this._lsame.Run(SIDE, "L"))
{
// *
// * Form H * C or H' * C where C = ( C1 )
// * ( C2 )
// *
// * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
// *
// * W := C1'
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(N, C, J + 1 * LDC + o_c, LDC, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V1
// *
this._dtrmm.Run("Right", "Lower", "No transpose", "Unit", N, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
if (M > K)
{
// *
// * W := W + C2'*V2
// *
this._dgemm.Run("Transpose", "No transpose", N, K, M - K, ONE
, C, K + 1 + 1 * LDC + o_c, LDC, V, K + 1 + 1 * LDV + o_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T' or W * T
// *
this._dtrmm.Run("Right", "Upper", TRANST, "Non-unit", N, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - V * W'
// *
if (M > K)
{
// *
// * C2 := C2 - V2 * W'
// *
this._dgemm.Run("No transpose", "Transpose", M - K, N, K, -ONE
, V, K + 1 + 1 * LDV + o_v, LDV, WORK, offset_work, LDWORK, ONE, ref C, K + 1 + 1 * LDC + o_c
, LDC);
}
// *
// * W := W * V1'
// *
this._dtrmm.Run("Right", "Lower", "Transpose", "Unit", N, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C1 := C1 - W'
// *
for (J = 1; J <= K; J++)
{
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= N; I++)
{
C[J + I * LDC + o_c] -= WORK[I + WORK_J];
}
}
// *
}
else
{
if (this._lsame.Run(SIDE, "R"))
{
// *
// * Form C * H or C * H' where C = ( C1 C2 )
// *
// * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
// *
// * W := C1
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(M, C, 1 + J * LDC + o_c, 1, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V1
// *
this._dtrmm.Run("Right", "Lower", "No transpose", "Unit", M, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
if (N > K)
{
// *
// * W := W + C2 * V2
// *
this._dgemm.Run("No transpose", "No transpose", M, K, N - K, ONE
, C, 1 + (K + 1) * LDC + o_c, LDC, V, K + 1 + 1 * LDV + o_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T or W * T'
// *
this._dtrmm.Run("Right", "Upper", TRANS, "Non-unit", M, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - W * V'
// *
if (N > K)
{
// *
// * C2 := C2 - W * V2'
// *
this._dgemm.Run("No transpose", "Transpose", M, N - K, K, -ONE
, WORK, offset_work, LDWORK, V, K + 1 + 1 * LDV + o_v, LDV, ONE, ref C, 1 + (K + 1) * LDC + o_c
, LDC);
}
// *
// * W := W * V1'
// *
this._dtrmm.Run("Right", "Lower", "Transpose", "Unit", M, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C1 := C1 - W
// *
for (J = 1; J <= K; J++)
{
C_J = J * LDC + o_c;
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= M; I++)
{
C[I + C_J] -= WORK[I + WORK_J];
}
}
}
}
// *
}
else
{
// *
// * Let V = ( V1 )
// * ( V2 ) (last K rows)
// * where V2 is unit upper triangular.
// *
if (this._lsame.Run(SIDE, "L"))
{
// *
// * Form H * C or H' * C where C = ( C1 )
// * ( C2 )
// *
// * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
// *
// * W := C2'
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(N, C, M - K + J + 1 * LDC + o_c, LDC, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V2
// *
this._dtrmm.Run("Right", "Upper", "No transpose", "Unit", N, K
, ONE, V, M - K + 1 + 1 * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
if (M > K)
{
// *
// * W := W + C1'*V1
// *
this._dgemm.Run("Transpose", "No transpose", N, K, M - K, ONE
, C, offset_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T' or W * T
// *
this._dtrmm.Run("Right", "Lower", TRANST, "Non-unit", N, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - V * W'
// *
if (M > K)
{
// *
// * C1 := C1 - V1 * W'
// *
this._dgemm.Run("No transpose", "Transpose", M - K, N, K, -ONE
, V, offset_v, LDV, WORK, offset_work, LDWORK, ONE, ref C, offset_c
, LDC);
}
// *
// * W := W * V2'
// *
this._dtrmm.Run("Right", "Upper", "Transpose", "Unit", N, K
, ONE, V, M - K + 1 + 1 * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C2 := C2 - W'
// *
for (J = 1; J <= K; J++)
{
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= N; I++)
{
C[M - K + J + I * LDC + o_c] -= WORK[I + WORK_J];
}
}
// *
}
else
{
if (this._lsame.Run(SIDE, "R"))
{
// *
// * Form C * H or C * H' where C = ( C1 C2 )
// *
// * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
// *
// * W := C2
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(M, C, 1 + (N - K + J) * LDC + o_c, 1, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V2
// *
this._dtrmm.Run("Right", "Upper", "No transpose", "Unit", M, K
, ONE, V, N - K + 1 + 1 * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
if (N > K)
{
// *
// * W := W + C1 * V1
// *
this._dgemm.Run("No transpose", "No transpose", M, K, N - K, ONE
, C, offset_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T or W * T'
// *
this._dtrmm.Run("Right", "Lower", TRANS, "Non-unit", M, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - W * V'
// *
if (N > K)
{
// *
// * C1 := C1 - W * V1'
// *
this._dgemm.Run("No transpose", "Transpose", M, N - K, K, -ONE
, WORK, offset_work, LDWORK, V, offset_v, LDV, ONE, ref C, offset_c
, LDC);
}
// *
// * W := W * V2'
// *
this._dtrmm.Run("Right", "Upper", "Transpose", "Unit", M, K
, ONE, V, N - K + 1 + 1 * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C2 := C2 - W
// *
for (J = 1; J <= K; J++)
{
C_0 = (N - K + J) * LDC + o_c;
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= M; I++)
{
C[I + C_0] -= WORK[I + WORK_J];
}
}
}
}
}
// *
}
else
{
if (this._lsame.Run(STOREV, "R"))
{
// *
if (this._lsame.Run(DIRECT, "F"))
{
// *
// * Let V = ( V1 V2 ) (V1: first K columns)
// * where V1 is unit upper triangular.
// *
if (this._lsame.Run(SIDE, "L"))
{
// *
// * Form H * C or H' * C where C = ( C1 )
// * ( C2 )
// *
// * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
// *
// * W := C1'
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(N, C, J + 1 * LDC + o_c, LDC, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V1'
// *
this._dtrmm.Run("Right", "Upper", "Transpose", "Unit", N, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
if (M > K)
{
// *
// * W := W + C2'*V2'
// *
this._dgemm.Run("Transpose", "Transpose", N, K, M - K, ONE
, C, K + 1 + 1 * LDC + o_c, LDC, V, 1 + (K + 1) * LDV + o_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T' or W * T
// *
this._dtrmm.Run("Right", "Upper", TRANST, "Non-unit", N, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - V' * W'
// *
if (M > K)
{
// *
// * C2 := C2 - V2' * W'
// *
this._dgemm.Run("Transpose", "Transpose", M - K, N, K, -ONE
, V, 1 + (K + 1) * LDV + o_v, LDV, WORK, offset_work, LDWORK, ONE, ref C, K + 1 + 1 * LDC + o_c
, LDC);
}
// *
// * W := W * V1
// *
this._dtrmm.Run("Right", "Upper", "No transpose", "Unit", N, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C1 := C1 - W'
// *
for (J = 1; J <= K; J++)
{
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= N; I++)
{
C[J + I * LDC + o_c] -= WORK[I + WORK_J];
}
}
// *
}
else
{
if (this._lsame.Run(SIDE, "R"))
{
// *
// * Form C * H or C * H' where C = ( C1 C2 )
// *
// * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
// *
// * W := C1
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(M, C, 1 + J * LDC + o_c, 1, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V1'
// *
this._dtrmm.Run("Right", "Upper", "Transpose", "Unit", M, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
if (N > K)
{
// *
// * W := W + C2 * V2'
// *
this._dgemm.Run("No transpose", "Transpose", M, K, N - K, ONE
, C, 1 + (K + 1) * LDC + o_c, LDC, V, 1 + (K + 1) * LDV + o_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T or W * T'
// *
this._dtrmm.Run("Right", "Upper", TRANS, "Non-unit", M, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - W * V
// *
if (N > K)
{
// *
// * C2 := C2 - W * V2
// *
this._dgemm.Run("No transpose", "No transpose", M, N - K, K, -ONE
, WORK, offset_work, LDWORK, V, 1 + (K + 1) * LDV + o_v, LDV, ONE, ref C, 1 + (K + 1) * LDC + o_c
, LDC);
}
// *
// * W := W * V1
// *
this._dtrmm.Run("Right", "Upper", "No transpose", "Unit", M, K
, ONE, V, offset_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C1 := C1 - W
// *
for (J = 1; J <= K; J++)
{
C_J = J * LDC + o_c;
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= M; I++)
{
C[I + C_J] -= WORK[I + WORK_J];
}
}
// *
}
}
// *
}
else
{
// *
// * Let V = ( V1 V2 ) (V2: last K columns)
// * where V2 is unit lower triangular.
// *
if (this._lsame.Run(SIDE, "L"))
{
// *
// * Form H * C or H' * C where C = ( C1 )
// * ( C2 )
// *
// * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
// *
// * W := C2'
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(N, C, M - K + J + 1 * LDC + o_c, LDC, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V2'
// *
this._dtrmm.Run("Right", "Lower", "Transpose", "Unit", N, K
, ONE, V, 1 + (M - K + 1) * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
if (M > K)
{
// *
// * W := W + C1'*V1'
// *
this._dgemm.Run("Transpose", "Transpose", N, K, M - K, ONE
, C, offset_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T' or W * T
// *
this._dtrmm.Run("Right", "Lower", TRANST, "Non-unit", N, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - V' * W'
// *
if (M > K)
{
// *
// * C1 := C1 - V1' * W'
// *
this._dgemm.Run("Transpose", "Transpose", M - K, N, K, -ONE
, V, offset_v, LDV, WORK, offset_work, LDWORK, ONE, ref C, offset_c
, LDC);
}
// *
// * W := W * V2
// *
this._dtrmm.Run("Right", "Lower", "No transpose", "Unit", N, K
, ONE, V, 1 + (M - K + 1) * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C2 := C2 - W'
// *
for (J = 1; J <= K; J++)
{
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= N; I++)
{
C[M - K + J + I * LDC + o_c] -= WORK[I + WORK_J];
}
}
// *
}
else
{
if (this._lsame.Run(SIDE, "R"))
{
// *
// * Form C * H or C * H' where C = ( C1 C2 )
// *
// * W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
// *
// * W := C2
// *
for (J = 1; J <= K; J++)
{
this._dcopy.Run(M, C, 1 + (N - K + J) * LDC + o_c, 1, ref WORK, 1 + J * LDWORK + o_work, 1);
}
// *
// * W := W * V2'
// *
this._dtrmm.Run("Right", "Lower", "Transpose", "Unit", M, K
, ONE, V, 1 + (N - K + 1) * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
if (N > K)
{
// *
// * W := W + C1 * V1'
// *
this._dgemm.Run("No transpose", "Transpose", M, K, N - K, ONE
, C, offset_c, LDC, V, offset_v, LDV, ONE, ref WORK, offset_work
, LDWORK);
}
// *
// * W := W * T or W * T'
// *
this._dtrmm.Run("Right", "Lower", TRANS, "Non-unit", M, K
, ONE, T, offset_t, LDT, ref WORK, offset_work, LDWORK);
// *
// * C := C - W * V
// *
if (N > K)
{
// *
// * C1 := C1 - W * V1
// *
this._dgemm.Run("No transpose", "No transpose", M, N - K, K, -ONE
, WORK, offset_work, LDWORK, V, offset_v, LDV, ONE, ref C, offset_c
, LDC);
}
// *
// * W := W * V2
// *
this._dtrmm.Run("Right", "Lower", "No transpose", "Unit", M, K
, ONE, V, 1 + (N - K + 1) * LDV + o_v, LDV, ref WORK, offset_work, LDWORK);
// *
// * C1 := C1 - W
// *
for (J = 1; J <= K; J++)
{
C_1 = (N - K + J) * LDC + o_c;
WORK_J = J * LDWORK + o_work;
for (I = 1; I <= M; I++)
{
C[I + C_1] -= WORK[I + WORK_J];
}
}
// *
}
}
// *
}
}
}
// *
return;
// *
// * End of DLARFB
// *
#endregion
}