/// <summary>
/// Purpose
/// =======
///
/// DLAIC1 applies one step of incremental condition estimation in
/// its simplest version:
///
/// Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
/// lower triangular matrix L, such that
/// twonorm(L*x) = sest
/// Then DLAIC1 computes sestpr, s, c such that
/// the vector
/// [ s*x ]
/// xhat = [ c ]
/// is an approximate singular vector of
/// [ L 0 ]
/// Lhat = [ w' gamma ]
/// in the sense that
/// twonorm(Lhat*xhat) = sestpr.
///
/// Depending on JOB, an estimate for the largest or smallest singular
/// value is computed.
///
/// Note that [s c]' and sestpr**2 is an eigenpair of the system
///
/// diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
/// [ gamma ]
///
/// where alpha = x'*w.
///
///</summary>
/// <param name="JOB">
/// (input) INTEGER
/// = 1: an estimate for the largest singular value is computed.
/// = 2: an estimate for the smallest singular value is computed.
///</param>
/// <param name="J">
/// (input) INTEGER
/// Length of X and W
///</param>
/// <param name="X">
/// (input) DOUBLE PRECISION array, dimension (J)
/// The j-vector x.
///</param>
/// <param name="SEST">
/// (input) DOUBLE PRECISION
/// Estimated singular value of j by j matrix L
///</param>
/// <param name="W">
/// (input) DOUBLE PRECISION array, dimension (J)
/// The j-vector w.
///</param>
/// <param name="GAMMA">
/// (input) DOUBLE PRECISION
/// The diagonal element gamma.
///</param>
/// <param name="SESTPR">
/// (output) DOUBLE PRECISION
/// Estimated singular value of (j+1) by (j+1) matrix Lhat.
///</param>
/// <param name="S">
/// (output) DOUBLE PRECISION
/// Sine needed in forming xhat.
///</param>
/// <param name="C">
/// (output) DOUBLE PRECISION
/// Cosine needed in forming xhat.
///</param>
public void Run(int JOB, int J, double[] X, int offset_x, double SEST, double[] W, int offset_w, double GAMMA
, ref double SESTPR, ref double S, ref double C)
{
#region Variables
double ABSALP = 0; double ABSEST = 0; double ABSGAM = 0; double ALPHA = 0; double B = 0; double COSINE = 0;
double EPS = 0; double NORMA = 0; double S1 = 0; double S2 = 0; double SINE = 0; double T = 0; double TEST = 0;
double TMP = 0; double ZETA1 = 0; double ZETA2 = 0;
#endregion
#region Array Index Correction
int o_x = -1 + offset_x; int o_w = -1 + offset_w;
#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
// * =======
// *
// * DLAIC1 applies one step of incremental condition estimation in
// * its simplest version:
// *
// * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
// * lower triangular matrix L, such that
// * twonorm(L*x) = sest
// * Then DLAIC1 computes sestpr, s, c such that
// * the vector
// * [ s*x ]
// * xhat = [ c ]
// * is an approximate singular vector of
// * [ L 0 ]
// * Lhat = [ w' gamma ]
// * in the sense that
// * twonorm(Lhat*xhat) = sestpr.
// *
// * Depending on JOB, an estimate for the largest or smallest singular
// * value is computed.
// *
// * Note that [s c]' and sestpr**2 is an eigenpair of the system
// *
// * diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
// * [ gamma ]
// *
// * where alpha = x'*w.
// *
// * Arguments
// * =========
// *
// * JOB (input) INTEGER
// * = 1: an estimate for the largest singular value is computed.
// * = 2: an estimate for the smallest singular value is computed.
// *
// * J (input) INTEGER
// * Length of X and W
// *
// * X (input) DOUBLE PRECISION array, dimension (J)
// * The j-vector x.
// *
// * SEST (input) DOUBLE PRECISION
// * Estimated singular value of j by j matrix L
// *
// * W (input) DOUBLE PRECISION array, dimension (J)
// * The j-vector w.
// *
// * GAMMA (input) DOUBLE PRECISION
// * The diagonal element gamma.
// *
// * SESTPR (output) DOUBLE PRECISION
// * Estimated singular value of (j+1) by (j+1) matrix Lhat.
// *
// * S (output) DOUBLE PRECISION
// * Sine needed in forming xhat.
// *
// * C (output) DOUBLE PRECISION
// * Cosine needed in forming xhat.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, MAX, SIGN, SQRT;
// * ..
// * .. External Functions ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
EPS = this._dlamch.Run("Epsilon");
ALPHA = this._ddot.Run(J, X, offset_x, 1, W, offset_w, 1);
// *
ABSALP = Math.Abs(ALPHA);
ABSGAM = Math.Abs(GAMMA);
ABSEST = Math.Abs(SEST);
// *
if (JOB == 1)
{
// *
// * Estimating largest singular value
// *
// * special cases
// *
if (SEST == ZERO)
{
S1 = Math.Max(ABSGAM, ABSALP);
if (S1 == ZERO)
{
S = ZERO;
C = ONE;
SESTPR = ZERO;
}
else
{
S = ALPHA / S1;
C = GAMMA / S1;
TMP = Math.Sqrt(S * S + C * C);
S /= TMP;
C /= TMP;
SESTPR = S1 * TMP;
}
return;
}
else
{
if (ABSGAM <= EPS * ABSEST)
{
S = ONE;
C = ZERO;
TMP = Math.Max(ABSEST, ABSALP);
S1 = ABSEST / TMP;
S2 = ABSALP / TMP;
SESTPR = TMP * Math.Sqrt(S1 * S1 + S2 * S2);
return;
}
else
{
if (ABSALP <= EPS * ABSEST)
{
S1 = ABSGAM;
S2 = ABSEST;
if (S1 <= S2)
{
S = ONE;
C = ZERO;
SESTPR = S2;
}
else
{
S = ZERO;
C = ONE;
SESTPR = S1;
}
return;
}
else
{
if (ABSEST <= EPS * ABSALP || ABSEST <= EPS * ABSGAM)
{
S1 = ABSGAM;
S2 = ABSALP;
if (S1 <= S2)
{
TMP = S1 / S2;
S = Math.Sqrt(ONE + TMP * TMP);
SESTPR = S2 * S;
C = (GAMMA / S2) / S;
S = FortranLib.Sign(ONE, ALPHA) / S;
}
else
{
TMP = S2 / S1;
C = Math.Sqrt(ONE + TMP * TMP);
SESTPR = S1 * C;
S = (ALPHA / S1) / C;
C = FortranLib.Sign(ONE, GAMMA) / C;
}
return;
}
else
{
// *
// * normal case
// *
ZETA1 = ALPHA / ABSEST;
ZETA2 = GAMMA / ABSEST;
// *
B = (ONE - ZETA1 * ZETA1 - ZETA2 * ZETA2) * HALF;
C = ZETA1 * ZETA1;
if (B > ZERO)
{
T = C / (B + Math.Sqrt(B * B + C));
}
else
{
T = Math.Sqrt(B * B + C) - B;
}
// *
SINE = -ZETA1 / T;
COSINE = -ZETA2 / (ONE + T);
TMP = Math.Sqrt(SINE * SINE + COSINE * COSINE);
S = SINE / TMP;
C = COSINE / TMP;
SESTPR = Math.Sqrt(T + ONE) * ABSEST;
return;
}
}
}
}
// *
}
else
{
if (JOB == 2)
{
// *
// * Estimating smallest singular value
// *
// * special cases
// *
if (SEST == ZERO)
{
SESTPR = ZERO;
if (Math.Max(ABSGAM, ABSALP) == ZERO)
{
SINE = ONE;
COSINE = ZERO;
}
else
{
SINE = -GAMMA;
COSINE = ALPHA;
}
S1 = Math.Max(Math.Abs(SINE), Math.Abs(COSINE));
S = SINE / S1;
C = COSINE / S1;
TMP = Math.Sqrt(S * S + C * C);
S /= TMP;
C /= TMP;
return;
}
else
{
if (ABSGAM <= EPS * ABSEST)
{
S = ZERO;
C = ONE;
SESTPR = ABSGAM;
return;
}
else
{
if (ABSALP <= EPS * ABSEST)
{
S1 = ABSGAM;
S2 = ABSEST;
if (S1 <= S2)
{
S = ZERO;
C = ONE;
SESTPR = S1;
}
else
{
S = ONE;
C = ZERO;
SESTPR = S2;
}
return;
}
else
{
if (ABSEST <= EPS * ABSALP || ABSEST <= EPS * ABSGAM)
{
S1 = ABSGAM;
S2 = ABSALP;
if (S1 <= S2)
{
TMP = S1 / S2;
C = Math.Sqrt(ONE + TMP * TMP);
SESTPR = ABSEST * (TMP / C);
S = -(GAMMA / S2) / C;
C = FortranLib.Sign(ONE, ALPHA) / C;
}
else
{
TMP = S2 / S1;
S = Math.Sqrt(ONE + TMP * TMP);
SESTPR = ABSEST / S;
C = (ALPHA / S1) / S;
S = -FortranLib.Sign(ONE, GAMMA) / S;
}
return;
}
else
{
// *
// * normal case
// *
ZETA1 = ALPHA / ABSEST;
ZETA2 = GAMMA / ABSEST;
// *
NORMA = Math.Max(ONE + ZETA1 * ZETA1 + Math.Abs(ZETA1 * ZETA2), Math.Abs(ZETA1 * ZETA2) + ZETA2 * ZETA2);
// *
// * See if root is closer to zero or to ONE
// *
TEST = ONE + TWO * (ZETA1 - ZETA2) * (ZETA1 + ZETA2);
if (TEST >= ZERO)
{
// *
// * root is close to zero, compute directly
// *
B = (ZETA1 * ZETA1 + ZETA2 * ZETA2 + ONE) * HALF;
C = ZETA2 * ZETA2;
T = C / (B + Math.Sqrt(Math.Abs(B * B - C)));
SINE = ZETA1 / (ONE - T);
COSINE = -ZETA2 / T;
SESTPR = Math.Sqrt(T + FOUR * EPS * EPS * NORMA) * ABSEST;
}
else
{
// *
// * root is closer to ONE, shift by that amount
// *
B = (ZETA2 * ZETA2 + ZETA1 * ZETA1 - ONE) * HALF;
C = ZETA1 * ZETA1;
if (B >= ZERO)
{
T = -C / (B + Math.Sqrt(B * B + C));
}
else
{
T = B - Math.Sqrt(B * B + C);
}
SINE = -ZETA1 / T;
COSINE = -ZETA2 / (ONE + T);
SESTPR = Math.Sqrt(ONE + T + FOUR * EPS * EPS * NORMA) * ABSEST;
}
TMP = Math.Sqrt(SINE * SINE + COSINE * COSINE);
S = SINE / TMP;
C = COSINE / TMP;
return;
// *
}
}
}
}
}
}
return;
// *
// * End of DLAIC1
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DBDSQR computes the singular values and, optionally, the right and/or
/// left singular vectors from the singular value decomposition (SVD) of
/// a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
/// zero-shift QR algorithm. The SVD of B has the form
///
/// B = Q * S * P**T
///
/// where S is the diagonal matrix of singular values, Q is an orthogonal
/// matrix of left singular vectors, and P is an orthogonal matrix of
/// right singular vectors. If left singular vectors are requested, this
/// subroutine actually returns U*Q instead of Q, and, if right singular
/// vectors are requested, this subroutine returns P**T*VT instead of
/// P**T, for given real input matrices U and VT. When U and VT are the
/// orthogonal matrices that reduce a general matrix A to bidiagonal
/// form: A = U*B*VT, as computed by DGEBRD, then
///
/// A = (U*Q) * S * (P**T*VT)
///
/// is the SVD of A. Optionally, the subroutine may also compute Q**T*C
/// for a given real input matrix C.
///
/// See "Computing Small Singular Values of Bidiagonal Matrices With
/// Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
/// LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
/// no. 5, pp. 873-912, Sept 1990) and
/// "Accurate singular values and differential qd algorithms," by
/// B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
/// Department, University of California at Berkeley, July 1992
/// for a detailed description of the algorithm.
///
///</summary>
/// <param name="UPLO">
/// (input) CHARACTER*1
/// = 'U': B is upper bidiagonal;
/// = 'L': B is lower bidiagonal.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix B. N .GE. 0.
///</param>
/// <param name="NCVT">
/// (input) INTEGER
/// The number of columns of the matrix VT. NCVT .GE. 0.
///</param>
/// <param name="NRU">
/// (input) INTEGER
/// The number of rows of the matrix U. NRU .GE. 0.
///</param>
/// <param name="NCC">
/// (input) INTEGER
/// The number of columns of the matrix C. NCC .GE. 0.
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On entry, the n diagonal elements of the bidiagonal matrix B.
/// On exit, if INFO=0, the singular values of B in decreasing
/// order.
///</param>
/// <param name="E">
/// (input/output) DOUBLE PRECISION array, dimension (N-1)
/// On entry, the N-1 offdiagonal elements of the bidiagonal
/// matrix B.
/// On exit, if INFO = 0, E is destroyed; if INFO .GT. 0, D and E
/// will contain the diagonal and superdiagonal elements of a
/// bidiagonal matrix orthogonally equivalent to the one given
/// as input.
///</param>
/// <param name="VT">
/// (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
/// On entry, an N-by-NCVT matrix VT.
/// On exit, VT is overwritten by P**T * VT.
/// Not referenced if NCVT = 0.
///</param>
/// <param name="LDVT">
/// (input) INTEGER
/// The leading dimension of the array VT.
/// LDVT .GE. max(1,N) if NCVT .GT. 0; LDVT .GE. 1 if NCVT = 0.
///</param>
/// <param name="U">
/// (input/output) DOUBLE PRECISION array, dimension (LDU, N)
/// On entry, an NRU-by-N matrix U.
/// On exit, U is overwritten by U * Q.
/// Not referenced if NRU = 0.
///</param>
/// <param name="LDU">
/// (input) INTEGER
/// The leading dimension of the array U. LDU .GE. max(1,NRU).
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
/// On entry, an N-by-NCC matrix C.
/// On exit, C is overwritten by Q**T * C.
/// Not referenced if NCC = 0.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C.
/// LDC .GE. max(1,N) if NCC .GT. 0; LDC .GE.1 if NCC = 0.
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (2*N)
/// if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: If INFO = -i, the i-th argument had an illegal value
/// .GT. 0: the algorithm did not converge; D and E contain the
/// elements of a bidiagonal matrix which is orthogonally
/// similar to the input matrix B; if INFO = i, i
/// elements of E have not converged to zero.
///</param>
public void Run(string UPLO, int N, int NCVT, int NRU, int NCC, ref double[] D, int offset_d
, ref double[] E, int offset_e, ref double[] VT, int offset_vt, int LDVT, ref double[] U, int offset_u, int LDU, ref double[] C, int offset_c
, int LDC, ref double[] WORK, int offset_work, ref int INFO)
{
#region Variables
bool LOWER = false; bool ROTATE = false; int I = 0; int IDIR = 0; int ISUB = 0; int ITER = 0; int J = 0; int LL = 0;
int LLL = 0; int M = 0; int MAXIT = 0; int NM1 = 0; int NM12 = 0; int NM13 = 0; int OLDLL = 0; int OLDM = 0;
double ABSE = 0; double ABSS = 0; double COSL = 0; double COSR = 0; double CS = 0; double EPS = 0; double F = 0;
double G = 0; double H = 0; double MU = 0; double OLDCS = 0; double OLDSN = 0; double R = 0; double SHIFT = 0;
double SIGMN = 0; double SIGMX = 0; double SINL = 0; double SINR = 0; double SLL = 0; double SMAX = 0; double SMIN = 0;
double SMINL = 0; double SMINOA = 0; double SN = 0; double THRESH = 0; double TOL = 0; double TOLMUL = 0;
double UNFL = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_vt = -1 - LDVT + offset_vt; int o_u = -1 - LDU + offset_u;
int o_c = -1 - LDC + offset_c; int o_work = -1 + offset_work;
#endregion
#region Strings
UPLO = UPLO.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
// * =======
// *
// * DBDSQR computes the singular values and, optionally, the right and/or
// * left singular vectors from the singular value decomposition (SVD) of
// * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
// * zero-shift QR algorithm. The SVD of B has the form
// *
// * B = Q * S * P**T
// *
// * where S is the diagonal matrix of singular values, Q is an orthogonal
// * matrix of left singular vectors, and P is an orthogonal matrix of
// * right singular vectors. If left singular vectors are requested, this
// * subroutine actually returns U*Q instead of Q, and, if right singular
// * vectors are requested, this subroutine returns P**T*VT instead of
// * P**T, for given real input matrices U and VT. When U and VT are the
// * orthogonal matrices that reduce a general matrix A to bidiagonal
// * form: A = U*B*VT, as computed by DGEBRD, then
// *
// * A = (U*Q) * S * (P**T*VT)
// *
// * is the SVD of A. Optionally, the subroutine may also compute Q**T*C
// * for a given real input matrix C.
// *
// * See "Computing Small Singular Values of Bidiagonal Matrices With
// * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
// * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
// * no. 5, pp. 873-912, Sept 1990) and
// * "Accurate singular values and differential qd algorithms," by
// * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
// * Department, University of California at Berkeley, July 1992
// * for a detailed description of the algorithm.
// *
// * Arguments
// * =========
// *
// * UPLO (input) CHARACTER*1
// * = 'U': B is upper bidiagonal;
// * = 'L': B is lower bidiagonal.
// *
// * N (input) INTEGER
// * The order of the matrix B. N >= 0.
// *
// * NCVT (input) INTEGER
// * The number of columns of the matrix VT. NCVT >= 0.
// *
// * NRU (input) INTEGER
// * The number of rows of the matrix U. NRU >= 0.
// *
// * NCC (input) INTEGER
// * The number of columns of the matrix C. NCC >= 0.
// *
// * D (input/output) DOUBLE PRECISION array, dimension (N)
// * On entry, the n diagonal elements of the bidiagonal matrix B.
// * On exit, if INFO=0, the singular values of B in decreasing
// * order.
// *
// * E (input/output) DOUBLE PRECISION array, dimension (N-1)
// * On entry, the N-1 offdiagonal elements of the bidiagonal
// * matrix B.
// * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
// * will contain the diagonal and superdiagonal elements of a
// * bidiagonal matrix orthogonally equivalent to the one given
// * as input.
// *
// * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
// * On entry, an N-by-NCVT matrix VT.
// * On exit, VT is overwritten by P**T * VT.
// * Not referenced if NCVT = 0.
// *
// * LDVT (input) INTEGER
// * The leading dimension of the array VT.
// * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
// *
// * U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
// * On entry, an NRU-by-N matrix U.
// * On exit, U is overwritten by U * Q.
// * Not referenced if NRU = 0.
// *
// * LDU (input) INTEGER
// * The leading dimension of the array U. LDU >= max(1,NRU).
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
// * On entry, an N-by-NCC matrix C.
// * On exit, C is overwritten by Q**T * C.
// * Not referenced if NCC = 0.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C.
// * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
// * if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: If INFO = -i, the i-th argument had an illegal value
// * > 0: the algorithm did not converge; D and E contain the
// * elements of a bidiagonal matrix which is orthogonally
// * similar to the input matrix B; if INFO = i, i
// * elements of E have not converged to zero.
// *
// * Internal Parameters
// * ===================
// *
// * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
// * TOLMUL controls the convergence criterion of the QR loop.
// * If it is positive, TOLMUL*EPS is the desired relative
// * precision in the computed singular values.
// * If it is negative, abs(TOLMUL*EPS*sigma_max) is the
// * desired absolute accuracy in the computed singular
// * values (corresponds to relative accuracy
// * abs(TOLMUL*EPS) in the largest singular value.
// * abs(TOLMUL) should be between 1 and 1/EPS, and preferably
// * between 10 (for fast convergence) and .1/EPS
// * (for there to be some accuracy in the results).
// * Default is to lose at either one eighth or 2 of the
// * available decimal digits in each computed singular value
// * (whichever is smaller).
// *
// * MAXITR INTEGER, default = 6
// * MAXITR controls the maximum number of passes of the
// * algorithm through its inner loop. The algorithms stops
// * (and so fails to converge) if the number of passes
// * through the inner loop exceeds MAXITR*N**2.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
LOWER = this._lsame.Run(UPLO, "L");
if (!this._lsame.Run(UPLO, "U") && !LOWER)
{
INFO = -1;
}
else
{
if (N < 0)
{
INFO = -2;
}
else
{
if (NCVT < 0)
{
INFO = -3;
}
else
{
if (NRU < 0)
{
INFO = -4;
}
else
{
if (NCC < 0)
{
INFO = -5;
}
else
{
if ((NCVT == 0 && LDVT < 1) || (NCVT > 0 && LDVT < Math.Max(1, N)))
{
INFO = -9;
}
else
{
if (LDU < Math.Max(1, NRU))
{
INFO = -11;
}
else
{
if ((NCC == 0 && LDC < 1) || (NCC > 0 && LDC < Math.Max(1, N)))
{
INFO = -13;
}
}
}
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DBDSQR", -INFO);
return;
}
if (N == 0)
{
return;
}
if (N == 1)
{
goto LABEL160;
}
// *
// * ROTATE is true if any singular vectors desired, false otherwise
// *
ROTATE = (NCVT > 0) || (NRU > 0) || (NCC > 0);
// *
// * If no singular vectors desired, use qd algorithm
// *
if (!ROTATE)
{
this._dlasq1.Run(N, ref D, offset_d, E, offset_e, ref WORK, offset_work, ref INFO);
return;
}
// *
NM1 = N - 1;
NM12 = NM1 + NM1;
NM13 = NM12 + NM1;
IDIR = 0;
// *
// * Get machine constants
// *
EPS = this._dlamch.Run("Epsilon");
UNFL = this._dlamch.Run("Safe minimum");
// *
// * If matrix lower bidiagonal, rotate to be upper bidiagonal
// * by applying Givens rotations on the left
// *
if (LOWER)
{
for (I = 1; I <= N - 1; I++)
{
this._dlartg.Run(D[I + o_d], E[I + o_e], ref CS, ref SN, ref R);
D[I + o_d] = R;
E[I + o_e] = SN * D[I + 1 + o_d];
D[I + 1 + o_d] *= CS;
WORK[I + o_work] = CS;
WORK[NM1 + I + o_work] = SN;
}
// *
// * Update singular vectors if desired
// *
if (NRU > 0)
{
this._dlasr.Run("R", "V", "F", NRU, N, WORK, 1 + o_work
, WORK, N + o_work, ref U, offset_u, LDU);
}
if (NCC > 0)
{
this._dlasr.Run("L", "V", "F", N, NCC, WORK, 1 + o_work
, WORK, N + o_work, ref C, offset_c, LDC);
}
}
// *
// * Compute singular values to relative accuracy TOL
// * (By setting TOL to be negative, algorithm will compute
// * singular values to absolute accuracy ABS(TOL)*norm(input matrix))
// *
TOLMUL = Math.Max(TEN, Math.Min(HNDRD, Math.Pow(EPS, MEIGTH)));
TOL = TOLMUL * EPS;
// *
// * Compute approximate maximum, minimum singular values
// *
SMAX = ZERO;
for (I = 1; I <= N; I++)
{
SMAX = Math.Max(SMAX, Math.Abs(D[I + o_d]));
}
for (I = 1; I <= N - 1; I++)
{
SMAX = Math.Max(SMAX, Math.Abs(E[I + o_e]));
}
SMINL = ZERO;
if (TOL >= ZERO)
{
// *
// * Relative accuracy desired
// *
SMINOA = Math.Abs(D[1 + o_d]);
if (SMINOA == ZERO)
{
goto LABEL50;
}
MU = SMINOA;
for (I = 2; I <= N; I++)
{
MU = Math.Abs(D[I + o_d]) * (MU / (MU + Math.Abs(E[I - 1 + o_e])));
SMINOA = Math.Min(SMINOA, MU);
if (SMINOA == ZERO)
{
goto LABEL50;
}
}
LABEL50 :;
SMINOA /= Math.Sqrt(Convert.ToDouble(N));
THRESH = Math.Max(TOL * SMINOA, MAXITR * N * N * UNFL);
}
else
{
// *
// * Absolute accuracy desired
// *
THRESH = Math.Max(Math.Abs(TOL) * SMAX, MAXITR * N * N * UNFL);
}
// *
// * Prepare for main iteration loop for the singular values
// * (MAXIT is the maximum number of passes through the inner
// * loop permitted before nonconvergence signalled.)
// *
MAXIT = MAXITR * N * N;
ITER = 0;
OLDLL = -1;
OLDM = -1;
// *
// * M points to last element of unconverged part of matrix
// *
M = N;
// *
// * Begin main iteration loop
// *
LABEL60 :;
// *
// * Check for convergence or exceeding iteration count
// *
if (M <= 1)
{
goto LABEL160;
}
if (ITER > MAXIT)
{
goto LABEL200;
}
// *
// * Find diagonal block of matrix to work on
// *
if (TOL < ZERO && Math.Abs(D[M + o_d]) <= THRESH)
{
D[M + o_d] = ZERO;
}
SMAX = Math.Abs(D[M + o_d]);
SMIN = SMAX;
for (LLL = 1; LLL <= M - 1; LLL++)
{
LL = M - LLL;
ABSS = Math.Abs(D[LL + o_d]);
ABSE = Math.Abs(E[LL + o_e]);
if (TOL < ZERO && ABSS <= THRESH)
{
D[LL + o_d] = ZERO;
}
if (ABSE <= THRESH)
{
goto LABEL80;
}
SMIN = Math.Min(SMIN, ABSS);
SMAX = Math.Max(SMAX, Math.Max(ABSS, ABSE));
}
LL = 0;
goto LABEL90;
LABEL80 :;
E[LL + o_e] = ZERO;
// *
// * Matrix splits since E(LL) = 0
// *
if (LL == M - 1)
{
// *
// * Convergence of bottom singular value, return to top of loop
// *
M -= 1;
goto LABEL60;
}
LABEL90 :;
LL += 1;
// *
// * E(LL) through E(M-1) are nonzero, E(LL-1) is zero
// *
if (LL == M - 1)
{
// *
// * 2 by 2 block, handle separately
// *
this._dlasv2.Run(D[M - 1 + o_d], E[M - 1 + o_e], D[M + o_d], ref SIGMN, ref SIGMX, ref SINR
, ref COSR, ref SINL, ref COSL);
D[M - 1 + o_d] = SIGMX;
E[M - 1 + o_e] = ZERO;
D[M + o_d] = SIGMN;
// *
// * Compute singular vectors, if desired
// *
if (NCVT > 0)
{
this._drot.Run(NCVT, ref VT, M - 1 + 1 * LDVT + o_vt, LDVT, ref VT, M + 1 * LDVT + o_vt, LDVT, COSR
, SINR);
}
if (NRU > 0)
{
this._drot.Run(NRU, ref U, 1 + (M - 1) * LDU + o_u, 1, ref U, 1 + M * LDU + o_u, 1, COSL
, SINL);
}
if (NCC > 0)
{
this._drot.Run(NCC, ref C, M - 1 + 1 * LDC + o_c, LDC, ref C, M + 1 * LDC + o_c, LDC, COSL
, SINL);
}
M -= 2;
goto LABEL60;
}
// *
// * If working on new submatrix, choose shift direction
// * (from larger end diagonal element towards smaller)
// *
if (LL > OLDM || M < OLDLL)
{
if (Math.Abs(D[LL + o_d]) >= Math.Abs(D[M + o_d]))
{
// *
// * Chase bulge from top (big end) to bottom (small end)
// *
IDIR = 1;
}
else
{
// *
// * Chase bulge from bottom (big end) to top (small end)
// *
IDIR = 2;
}
}
// *
// * Apply convergence tests
// *
if (IDIR == 1)
{
// *
// * Run convergence test in forward direction
// * First apply standard test to bottom of matrix
// *
if (Math.Abs(E[M - 1 + o_e]) <= Math.Abs(TOL) * Math.Abs(D[M + o_d]) || (TOL < ZERO && Math.Abs(E[M - 1 + o_e]) <= THRESH))
{
E[M - 1 + o_e] = ZERO;
goto LABEL60;
}
// *
if (TOL >= ZERO)
{
// *
// * If relative accuracy desired,
// * apply convergence criterion forward
// *
MU = Math.Abs(D[LL + o_d]);
SMINL = MU;
for (LLL = LL; LLL <= M - 1; LLL++)
{
if (Math.Abs(E[LLL + o_e]) <= TOL * MU)
{
E[LLL + o_e] = ZERO;
goto LABEL60;
}
MU = Math.Abs(D[LLL + 1 + o_d]) * (MU / (MU + Math.Abs(E[LLL + o_e])));
SMINL = Math.Min(SMINL, MU);
}
}
// *
}
else
{
// *
// * Run convergence test in backward direction
// * First apply standard test to top of matrix
// *
if (Math.Abs(E[LL + o_e]) <= Math.Abs(TOL) * Math.Abs(D[LL + o_d]) || (TOL < ZERO && Math.Abs(E[LL + o_e]) <= THRESH))
{
E[LL + o_e] = ZERO;
goto LABEL60;
}
// *
if (TOL >= ZERO)
{
// *
// * If relative accuracy desired,
// * apply convergence criterion backward
// *
MU = Math.Abs(D[M + o_d]);
SMINL = MU;
for (LLL = M - 1; LLL >= LL; LLL += -1)
{
if (Math.Abs(E[LLL + o_e]) <= TOL * MU)
{
E[LLL + o_e] = ZERO;
goto LABEL60;
}
MU = Math.Abs(D[LLL + o_d]) * (MU / (MU + Math.Abs(E[LLL + o_e])));
SMINL = Math.Min(SMINL, MU);
}
}
}
OLDLL = LL;
OLDM = M;
// *
// * Compute shift. First, test if shifting would ruin relative
// * accuracy, and if so set the shift to zero.
// *
if (TOL >= ZERO && N * TOL * (SMINL / SMAX) <= Math.Max(EPS, HNDRTH * TOL))
{
// *
// * Use a zero shift to avoid loss of relative accuracy
// *
SHIFT = ZERO;
}
else
{
// *
// * Compute the shift from 2-by-2 block at end of matrix
// *
if (IDIR == 1)
{
SLL = Math.Abs(D[LL + o_d]);
this._dlas2.Run(D[M - 1 + o_d], E[M - 1 + o_e], D[M + o_d], ref SHIFT, ref R);
}
else
{
SLL = Math.Abs(D[M + o_d]);
this._dlas2.Run(D[LL + o_d], E[LL + o_e], D[LL + 1 + o_d], ref SHIFT, ref R);
}
// *
// * Test if shift negligible, and if so set to zero
// *
if (SLL > ZERO)
{
if (Math.Pow(SHIFT / SLL, 2) < EPS)
{
SHIFT = ZERO;
}
}
}
// *
// * Increment iteration count
// *
ITER += M - LL;
// *
// * If SHIFT = 0, do simplified QR iteration
// *
if (SHIFT == ZERO)
{
if (IDIR == 1)
{
// *
// * Chase bulge from top to bottom
// * Save cosines and sines for later singular vector updates
// *
CS = ONE;
OLDCS = ONE;
for (I = LL; I <= M - 1; I++)
{
this._dlartg.Run(D[I + o_d] * CS, E[I + o_e], ref CS, ref SN, ref R);
if (I > LL)
{
E[I - 1 + o_e] = OLDSN * R;
}
this._dlartg.Run(OLDCS * R, D[I + 1 + o_d] * SN, ref OLDCS, ref OLDSN, ref D[I + o_d]);
WORK[I - LL + 1 + o_work] = CS;
WORK[I - LL + 1 + NM1 + o_work] = SN;
WORK[I - LL + 1 + NM12 + o_work] = OLDCS;
WORK[I - LL + 1 + NM13 + o_work] = OLDSN;
}
H = D[M + o_d] * CS;
D[M + o_d] = H * OLDCS;
E[M - 1 + o_e] = H * OLDSN;
// *
// * Update singular vectors
// *
if (NCVT > 0)
{
this._dlasr.Run("L", "V", "F", M - LL + 1, NCVT, WORK, 1 + o_work
, WORK, N + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT);
}
if (NRU > 0)
{
this._dlasr.Run("R", "V", "F", NRU, M - LL + 1, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref U, 1 + LL * LDU + o_u, LDU);
}
if (NCC > 0)
{
this._dlasr.Run("L", "V", "F", M - LL + 1, NCC, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref C, LL + 1 * LDC + o_c, LDC);
}
// *
// * Test convergence
// *
if (Math.Abs(E[M - 1 + o_e]) <= THRESH)
{
E[M - 1 + o_e] = ZERO;
}
// *
}
else
{
// *
// * Chase bulge from bottom to top
// * Save cosines and sines for later singular vector updates
// *
CS = ONE;
OLDCS = ONE;
for (I = M; I >= LL + 1; I += -1)
{
this._dlartg.Run(D[I + o_d] * CS, E[I - 1 + o_e], ref CS, ref SN, ref R);
if (I < M)
{
E[I + o_e] = OLDSN * R;
}
this._dlartg.Run(OLDCS * R, D[I - 1 + o_d] * SN, ref OLDCS, ref OLDSN, ref D[I + o_d]);
WORK[I - LL + o_work] = CS;
WORK[I - LL + NM1 + o_work] = -SN;
WORK[I - LL + NM12 + o_work] = OLDCS;
WORK[I - LL + NM13 + o_work] = -OLDSN;
}
H = D[LL + o_d] * CS;
D[LL + o_d] = H * OLDCS;
E[LL + o_e] = H * OLDSN;
// *
// * Update singular vectors
// *
if (NCVT > 0)
{
this._dlasr.Run("L", "V", "B", M - LL + 1, NCVT, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT);
}
if (NRU > 0)
{
this._dlasr.Run("R", "V", "B", NRU, M - LL + 1, WORK, 1 + o_work
, WORK, N + o_work, ref U, 1 + LL * LDU + o_u, LDU);
}
if (NCC > 0)
{
this._dlasr.Run("L", "V", "B", M - LL + 1, NCC, WORK, 1 + o_work
, WORK, N + o_work, ref C, LL + 1 * LDC + o_c, LDC);
}
// *
// * Test convergence
// *
if (Math.Abs(E[LL + o_e]) <= THRESH)
{
E[LL + o_e] = ZERO;
}
}
}
else
{
// *
// * Use nonzero shift
// *
if (IDIR == 1)
{
// *
// * Chase bulge from top to bottom
// * Save cosines and sines for later singular vector updates
// *
F = (Math.Abs(D[LL + o_d]) - SHIFT) * (FortranLib.Sign(ONE, D[LL + o_d]) + SHIFT / D[LL + o_d]);
G = E[LL + o_e];
for (I = LL; I <= M - 1; I++)
{
this._dlartg.Run(F, G, ref COSR, ref SINR, ref R);
if (I > LL)
{
E[I - 1 + o_e] = R;
}
F = COSR * D[I + o_d] + SINR * E[I + o_e];
E[I + o_e] = COSR * E[I + o_e] - SINR * D[I + o_d];
G = SINR * D[I + 1 + o_d];
D[I + 1 + o_d] *= COSR;
this._dlartg.Run(F, G, ref COSL, ref SINL, ref R);
D[I + o_d] = R;
F = COSL * E[I + o_e] + SINL * D[I + 1 + o_d];
D[I + 1 + o_d] = COSL * D[I + 1 + o_d] - SINL * E[I + o_e];
if (I < M - 1)
{
G = SINL * E[I + 1 + o_e];
E[I + 1 + o_e] *= COSL;
}
WORK[I - LL + 1 + o_work] = COSR;
WORK[I - LL + 1 + NM1 + o_work] = SINR;
WORK[I - LL + 1 + NM12 + o_work] = COSL;
WORK[I - LL + 1 + NM13 + o_work] = SINL;
}
E[M - 1 + o_e] = F;
// *
// * Update singular vectors
// *
if (NCVT > 0)
{
this._dlasr.Run("L", "V", "F", M - LL + 1, NCVT, WORK, 1 + o_work
, WORK, N + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT);
}
if (NRU > 0)
{
this._dlasr.Run("R", "V", "F", NRU, M - LL + 1, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref U, 1 + LL * LDU + o_u, LDU);
}
if (NCC > 0)
{
this._dlasr.Run("L", "V", "F", M - LL + 1, NCC, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref C, LL + 1 * LDC + o_c, LDC);
}
// *
// * Test convergence
// *
if (Math.Abs(E[M - 1 + o_e]) <= THRESH)
{
E[M - 1 + o_e] = ZERO;
}
// *
}
else
{
// *
// * Chase bulge from bottom to top
// * Save cosines and sines for later singular vector updates
// *
F = (Math.Abs(D[M + o_d]) - SHIFT) * (FortranLib.Sign(ONE, D[M + o_d]) + SHIFT / D[M + o_d]);
G = E[M - 1 + o_e];
for (I = M; I >= LL + 1; I += -1)
{
this._dlartg.Run(F, G, ref COSR, ref SINR, ref R);
if (I < M)
{
E[I + o_e] = R;
}
F = COSR * D[I + o_d] + SINR * E[I - 1 + o_e];
E[I - 1 + o_e] = COSR * E[I - 1 + o_e] - SINR * D[I + o_d];
G = SINR * D[I - 1 + o_d];
D[I - 1 + o_d] *= COSR;
this._dlartg.Run(F, G, ref COSL, ref SINL, ref R);
D[I + o_d] = R;
F = COSL * E[I - 1 + o_e] + SINL * D[I - 1 + o_d];
D[I - 1 + o_d] = COSL * D[I - 1 + o_d] - SINL * E[I - 1 + o_e];
if (I > LL + 1)
{
G = SINL * E[I - 2 + o_e];
E[I - 2 + o_e] *= COSL;
}
WORK[I - LL + o_work] = COSR;
WORK[I - LL + NM1 + o_work] = -SINR;
WORK[I - LL + NM12 + o_work] = COSL;
WORK[I - LL + NM13 + o_work] = -SINL;
}
E[LL + o_e] = F;
// *
// * Test convergence
// *
if (Math.Abs(E[LL + o_e]) <= THRESH)
{
E[LL + o_e] = ZERO;
}
// *
// * Update singular vectors if desired
// *
if (NCVT > 0)
{
this._dlasr.Run("L", "V", "B", M - LL + 1, NCVT, WORK, NM12 + 1 + o_work
, WORK, NM13 + 1 + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT);
}
if (NRU > 0)
{
this._dlasr.Run("R", "V", "B", NRU, M - LL + 1, WORK, 1 + o_work
, WORK, N + o_work, ref U, 1 + LL * LDU + o_u, LDU);
}
if (NCC > 0)
{
this._dlasr.Run("L", "V", "B", M - LL + 1, NCC, WORK, 1 + o_work
, WORK, N + o_work, ref C, LL + 1 * LDC + o_c, LDC);
}
}
}
// *
// * QR iteration finished, go back and check convergence
// *
goto LABEL60;
// *
// * All singular values converged, so make them positive
// *
LABEL160 :;
for (I = 1; I <= N; I++)
{
if (D[I + o_d] < ZERO)
{
D[I + o_d] = -D[I + o_d];
// *
// * Change sign of singular vectors, if desired
// *
if (NCVT > 0)
{
this._dscal.Run(NCVT, NEGONE, ref VT, I + 1 * LDVT + o_vt, LDVT);
}
}
}
// *
// * Sort the singular values into decreasing order (insertion sort on
// * singular values, but only one transposition per singular vector)
// *
for (I = 1; I <= N - 1; I++)
{
// *
// * Scan for smallest D(I)
// *
ISUB = 1;
SMIN = D[1 + o_d];
for (J = 2; J <= N + 1 - I; J++)
{
if (D[J + o_d] <= SMIN)
{
ISUB = J;
SMIN = D[J + o_d];
}
}
if (ISUB != N + 1 - I)
{
// *
// * Swap singular values and vectors
// *
D[ISUB + o_d] = D[N + 1 - I + o_d];
D[N + 1 - I + o_d] = SMIN;
if (NCVT > 0)
{
this._dswap.Run(NCVT, ref VT, ISUB + 1 * LDVT + o_vt, LDVT, ref VT, N + 1 - I + 1 * LDVT + o_vt, LDVT);
}
if (NRU > 0)
{
this._dswap.Run(NRU, ref U, 1 + ISUB * LDU + o_u, 1, ref U, 1 + (N + 1 - I) * LDU + o_u, 1);
}
if (NCC > 0)
{
this._dswap.Run(NCC, ref C, ISUB + 1 * LDC + o_c, LDC, ref C, N + 1 - I + 1 * LDC + o_c, LDC);
}
}
}
goto LABEL220;
// *
// * Maximum number of iterations exceeded, failure to converge
// *
LABEL200 :;
INFO = 0;
for (I = 1; I <= N - 1; I++)
{
if (E[I + o_e] != ZERO)
{
INFO += 1;
}
}
LABEL220 :;
return;
// *
// * End of DBDSQR
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLASV2 computes the singular value decomposition of a 2-by-2
/// triangular matrix
/// [ F G ]
/// [ 0 H ].
/// On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
/// smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
/// right singular vectors for abs(SSMAX), giving the decomposition
///
/// [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
/// [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
///
///</summary>
/// <param name="F">
/// (input) DOUBLE PRECISION
/// The (1,1) element of the 2-by-2 matrix.
///</param>
/// <param name="G">
/// (input) DOUBLE PRECISION
/// The (1,2) element of the 2-by-2 matrix.
///</param>
/// <param name="H">
/// (input) DOUBLE PRECISION
/// The (2,2) element of the 2-by-2 matrix.
///</param>
/// <param name="SSMIN">
/// (output) DOUBLE PRECISION
/// abs(SSMIN) is the smaller singular value.
///</param>
/// <param name="SSMAX">
/// (output) DOUBLE PRECISION
/// abs(SSMAX) is the larger singular value.
///</param>
/// <param name="SNR">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="CSR">
/// (output) DOUBLE PRECISION
/// The vector (CSR, SNR) is a unit right singular vector for the
/// singular value abs(SSMAX).
///</param>
/// <param name="SNL">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="CSL">
/// (output) DOUBLE PRECISION
/// The vector (CSL, SNL) is a unit left singular vector for the
/// singular value abs(SSMAX).
///</param>
public void Run(double F, double G, double H, ref double SSMIN, ref double SSMAX, ref double SNR
, ref double CSR, ref double SNL, ref double CSL)
{
#region Variables
bool GASMAL = false; bool SWAP = false; int PMAX = 0; double A = 0; double CLT = 0; double CRT = 0; double D = 0;
double FA = 0; double FT = 0; double GA = 0; double GT = 0; double HA = 0; double HT = 0; double L = 0; double M = 0;
double MM = 0; double R = 0; double S = 0; double SLT = 0; double SRT = 0; double T = 0; double TEMP = 0;
double TSIGN = 0; double TT = 0;
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLASV2 computes the singular value decomposition of a 2-by-2
// * triangular matrix
// * [ F G ]
// * [ 0 H ].
// * On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
// * smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
// * right singular vectors for abs(SSMAX), giving the decomposition
// *
// * [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
// * [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
// *
// * Arguments
// * =========
// *
// * F (input) DOUBLE PRECISION
// * The (1,1) element of the 2-by-2 matrix.
// *
// * G (input) DOUBLE PRECISION
// * The (1,2) element of the 2-by-2 matrix.
// *
// * H (input) DOUBLE PRECISION
// * The (2,2) element of the 2-by-2 matrix.
// *
// * SSMIN (output) DOUBLE PRECISION
// * abs(SSMIN) is the smaller singular value.
// *
// * SSMAX (output) DOUBLE PRECISION
// * abs(SSMAX) is the larger singular value.
// *
// * SNL (output) DOUBLE PRECISION
// * CSL (output) DOUBLE PRECISION
// * The vector (CSL, SNL) is a unit left singular vector for the
// * singular value abs(SSMAX).
// *
// * SNR (output) DOUBLE PRECISION
// * CSR (output) DOUBLE PRECISION
// * The vector (CSR, SNR) is a unit right singular vector for the
// * singular value abs(SSMAX).
// *
// * Further Details
// * ===============
// *
// * Any input parameter may be aliased with any output parameter.
// *
// * Barring over/underflow and assuming a guard digit in subtraction, all
// * output quantities are correct to within a few units in the last
// * place (ulps).
// *
// * In IEEE arithmetic, the code works correctly if one matrix element is
// * infinite.
// *
// * Overflow will not occur unless the largest singular value itself
// * overflows or is within a few ulps of overflow. (On machines with
// * partial overflow, like the Cray, overflow may occur if the largest
// * singular value is within a factor of 2 of overflow.)
// *
// * Underflow is harmless if underflow is gradual. Otherwise, results
// * may correspond to a matrix modified by perturbations of size near
// * the underflow threshold.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, SIGN, SQRT;
// * ..
// * .. External Functions ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
FT = F;
FA = Math.Abs(FT);
HT = H;
HA = Math.Abs(H);
// *
// * PMAX points to the maximum absolute element of matrix
// * PMAX = 1 if F largest in absolute values
// * PMAX = 2 if G largest in absolute values
// * PMAX = 3 if H largest in absolute values
// *
PMAX = 1;
SWAP = (HA > FA);
if (SWAP)
{
PMAX = 3;
TEMP = FT;
FT = HT;
HT = TEMP;
TEMP = FA;
FA = HA;
HA = TEMP;
// *
// * Now FA .ge. HA
// *
}
GT = G;
GA = Math.Abs(GT);
if (GA == ZERO)
{
// *
// * Diagonal matrix
// *
SSMIN = HA;
SSMAX = FA;
CLT = ONE;
CRT = ONE;
SLT = ZERO;
SRT = ZERO;
}
else
{
GASMAL = true;
if (GA > FA)
{
PMAX = 2;
if ((FA / GA) < this._dlamch.Run("EPS"))
{
// *
// * Case of very large GA
// *
GASMAL = false;
SSMAX = GA;
if (HA > ONE)
{
SSMIN = FA / (GA / HA);
}
else
{
SSMIN = (FA / GA) * HA;
}
CLT = ONE;
SLT = HT / GT;
SRT = ONE;
CRT = FT / GT;
}
}
if (GASMAL)
{
// *
// * Normal case
// *
D = FA - HA;
if (D == FA)
{
// *
// * Copes with infinite F or H
// *
L = ONE;
}
else
{
L = D / FA;
}
// *
// * Note that 0 .le. L .le. 1
// *
M = GT / FT;
// *
// * Note that abs(M) .le. 1/macheps
// *
T = TWO - L;
// *
// * Note that T .ge. 1
// *
MM = M * M;
TT = T * T;
S = Math.Sqrt(TT + MM);
// *
// * Note that 1 .le. S .le. 1 + 1/macheps
// *
if (L == ZERO)
{
R = Math.Abs(M);
}
else
{
R = Math.Sqrt(L * L + MM);
}
// *
// * Note that 0 .le. R .le. 1 + 1/macheps
// *
A = HALF * (S + R);
// *
// * Note that 1 .le. A .le. 1 + abs(M)
// *
SSMIN = HA / A;
SSMAX = FA * A;
if (MM == ZERO)
{
// *
// * Note that M is very tiny
// *
if (L == ZERO)
{
T = FortranLib.Sign(TWO, FT) * FortranLib.Sign(ONE, GT);
}
else
{
T = GT / FortranLib.Sign(D, FT) + M / T;
}
}
else
{
T = (M / (S + T) + M / (R + L)) * (ONE + A);
}
L = Math.Sqrt(T * T + FOUR);
CRT = TWO / L;
SRT = T / L;
CLT = (CRT + SRT * M) / A;
SLT = (HT / FT) * SRT / A;
}
}
if (SWAP)
{
CSL = SRT;
SNL = CRT;
CSR = SLT;
SNR = CLT;
}
else
{
CSL = CLT;
SNL = SLT;
CSR = CRT;
SNR = SRT;
}
// *
// * Correct signs of SSMAX and SSMIN
// *
if (PMAX == 1)
{
TSIGN = FortranLib.Sign(ONE, CSR) * FortranLib.Sign(ONE, CSL) * FortranLib.Sign(ONE, F);
}
if (PMAX == 2)
{
TSIGN = FortranLib.Sign(ONE, SNR) * FortranLib.Sign(ONE, CSL) * FortranLib.Sign(ONE, G);
}
if (PMAX == 3)
{
TSIGN = FortranLib.Sign(ONE, SNR) * FortranLib.Sign(ONE, SNL) * FortranLib.Sign(ONE, H);
}
SSMAX = FortranLib.Sign(SSMAX, TSIGN);
SSMIN = FortranLib.Sign(SSMIN, TSIGN * FortranLib.Sign(ONE, F) * FortranLib.Sign(ONE, H));
return;
// *
// * End of DLASV2
// *
#endregion
}
public double Run(int N, IFAREN FCN, double X, double[] Y, int offset_y, double XEND, double POSNEG
, double[] F0, int offset_f0, ref double[] F1, int offset_f1, ref double[] Y1, int offset_y1, int IORD, double HMAX, double[] ATOL, int offset_atol
, double[] RTOL, int offset_rtol, int ITOL, double[] RPAR, int offset_rpar, int[] IPAR, int offset_ipar)
{
double hinit = 0;
#region Implicit Variables
double DNF = 0; double DNY = 0; double ATOLI = 0; double RTOLI = 0; double SK = 0; int I = 0; double H = 0;
double DER2 = 0; double DER12 = 0; double H1 = 0;
#endregion
#region Array Index Correction
int o_y = -1 + offset_y; int o_f0 = -1 + offset_f0; int o_f1 = -1 + offset_f1; int o_y1 = -1 + offset_y1;
int o_atol = -1 + offset_atol; int o_rtol = -1 + offset_rtol; int o_rpar = -1 + offset_rpar;
int o_ipar = -1 + offset_ipar;
#endregion
// C ----------------------------------------------------------
// C ---- COMPUTATION OF AN INITIAL STEP SIZE GUESS
// C ----------------------------------------------------------
// C ---- COMPUTE A FIRST GUESS FOR EXPLICIT EULER AS
// C ---- H = 0.01 * NORM (Y0) / NORM (F0)
// C ---- THE INCREMENT FOR EXPLICIT EULER IS SMALL
// C ---- COMPARED TO THE SOLUTION
#region Body
DNF = 0.0E0;
DNY = 0.0E0;
ATOLI = ATOL[1 + o_atol];
RTOLI = RTOL[1 + o_rtol];
if (ITOL == 0)
{
for (I = 1; I <= N; I++)
{
SK = ATOLI + RTOLI * Math.Abs(Y[I + o_y]);
DNF += Math.Pow(F0[I + o_f0] / SK, 2);
DNY += Math.Pow(Y[I + o_y] / SK, 2);
}
}
else
{
for (I = 1; I <= N; I++)
{
SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]);
DNF += Math.Pow(F0[I + o_f0] / SK, 2);
DNY += Math.Pow(Y[I + o_y] / SK, 2);
}
}
if (DNF <= 1.0E-10 || DNY <= 1.0E-10)
{
H = 1.0E-6;
}
else
{
H = Math.Sqrt(DNY / DNF) * 0.01E0;
}
H = Math.Min(H, HMAX);
H = FortranLib.Sign(H, POSNEG);
// C ---- PERFORM AN EXPLICIT EULER STEP
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * F0[I + o_f0];
}
FCN.Run(N, X + H, Y1, offset_y1, ref F1, offset_f1, RPAR, offset_rpar, IPAR[1 + o_ipar]);
// C ---- ESTIMATE THE SECOND DERIVATIVE OF THE SOLUTION
DER2 = 0.0E0;
if (ITOL == 0)
{
for (I = 1; I <= N; I++)
{
SK = ATOLI + RTOLI * Math.Abs(Y[I + o_y]);
DER2 += Math.Pow((F1[I + o_f1] - F0[I + o_f0]) / SK, 2);
}
}
else
{
for (I = 1; I <= N; I++)
{
SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]);
DER2 += Math.Pow((F1[I + o_f1] - F0[I + o_f0]) / SK, 2);
}
}
DER2 = Math.Sqrt(DER2) / H;
// C ---- STEP SIZE IS COMPUTED SUCH THAT
// C ---- H**IORD * MAX ( NORM (F0), NORM (DER2)) = 0.01
DER12 = Math.Max(Math.Abs(DER2), Math.Sqrt(DNF));
if (DER12 <= 1.0E-15)
{
H1 = Math.Max(1.0E-6, Math.Abs(H) * 1.0E-3);
}
else
{
H1 = Math.Pow(0.01E0 / DER12, 1.0E0 / IORD);
}
H = Math.Min(100 * Math.Abs(H), Math.Min(H1, HMAX));
hinit = FortranLib.Sign(H, POSNEG);
return(hinit);
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLALSD uses the singular value decomposition of A to solve the least
/// squares problem of finding X to minimize the Euclidean norm of each
/// column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
/// are N-by-NRHS. The solution X overwrites B.
///
/// The singular values of A smaller than RCOND times the largest
/// singular value are treated as zero in solving the least squares
/// problem; in this case a minimum norm solution is returned.
/// The actual singular values are returned in D in ascending order.
///
/// This code makes very mild assumptions about floating point
/// arithmetic. It will work on machines with a guard digit in
/// add/subtract, or on those binary machines without guard digits
/// which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
/// It could conceivably fail on hexadecimal or decimal machines
/// without guard digits, but we know of none.
///
///</summary>
/// <param name="UPLO">
/// (input) CHARACTER*1
/// = 'U': D and E define an upper bidiagonal matrix.
/// = 'L': D and E define a lower bidiagonal matrix.
///</param>
/// <param name="SMLSIZ">
/// (input) INTEGER
/// The maximum size of the subproblems at the bottom of the
/// computation tree.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The dimension of the bidiagonal matrix. N .GE. 0.
///</param>
/// <param name="NRHS">
/// (input) INTEGER
/// The number of columns of B. NRHS must be at least 1.
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On entry D contains the main diagonal of the bidiagonal
/// matrix. On exit, if INFO = 0, D contains its singular values.
///</param>
/// <param name="E">
/// (input/output) DOUBLE PRECISION array, dimension (N-1)
/// Contains the super-diagonal entries of the bidiagonal matrix.
/// On exit, E has been destroyed.
///</param>
/// <param name="B">
/// (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
/// On input, B contains the right hand sides of the least
/// squares problem. On output, B contains the solution X.
///</param>
/// <param name="LDB">
/// (input) INTEGER
/// The leading dimension of B in the calling subprogram.
/// LDB must be at least max(1,N).
///</param>
/// <param name="RCOND">
/// (input) DOUBLE PRECISION
/// The singular values of A less than or equal to RCOND times
/// the largest singular value are treated as zero in solving
/// the least squares problem. If RCOND is negative,
/// machine precision is used instead.
/// For example, if diag(S)*X=B were the least squares problem,
/// where diag(S) is a diagonal matrix of singular values, the
/// solution would be X(i) = B(i) / S(i) if S(i) is greater than
/// RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
/// RCOND*max(S).
///</param>
/// <param name="RANK">
/// (output) INTEGER
/// The number of singular values of A greater than RCOND times
/// the largest singular value.
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension at least
/// (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
/// where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
///</param>
/// <param name="IWORK">
/// (workspace) INTEGER array, dimension at least
/// (3*N*NLVL + 11*N)
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit.
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value.
/// .GT. 0: The algorithm failed to compute an singular value while
/// working on the submatrix lying in rows and columns
/// INFO/(N+1) through MOD(INFO,N+1).
///</param>
public void Run(string UPLO, int SMLSIZ, int N, int NRHS, ref double[] D, int offset_d, ref double[] E, int offset_e
, ref double[] B, int offset_b, int LDB, double RCOND, ref int RANK, ref double[] WORK, int offset_work, ref int[] IWORK, int offset_iwork
, ref int INFO)
{
#region Variables
int BX = 0; int BXST = 0; int C = 0; int DIFL = 0; int DIFR = 0; int GIVCOL = 0; int GIVNUM = 0; int GIVPTR = 0;
int I = 0; int ICMPQ1 = 0; int ICMPQ2 = 0; int IWK = 0; int J = 0; int K = 0; int NLVL = 0; int NM1 = 0; int NSIZE = 0;
int NSUB = 0; int NWORK = 0; int PERM = 0; int POLES = 0; int S = 0; int SIZEI = 0; int SMLSZP = 0; int SQRE = 0;
int ST = 0; int ST1 = 0; int U = 0; int VT = 0; int Z = 0; double CS = 0; double EPS = 0; double ORGNRM = 0;
double R = 0; double RCND = 0; double SN = 0; double TOL = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_b = -1 - LDB + offset_b; int o_work = -1 + offset_work;
int o_iwork = -1 + offset_iwork;
#endregion
#region Strings
UPLO = UPLO.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
// * =======
// *
// * DLALSD uses the singular value decomposition of A to solve the least
// * squares problem of finding X to minimize the Euclidean norm of each
// * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
// * are N-by-NRHS. The solution X overwrites B.
// *
// * The singular values of A smaller than RCOND times the largest
// * singular value are treated as zero in solving the least squares
// * problem; in this case a minimum norm solution is returned.
// * The actual singular values are returned in D in ascending order.
// *
// * This code makes very mild assumptions about floating point
// * arithmetic. It will work on machines with a guard digit in
// * add/subtract, or on those binary machines without guard digits
// * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
// * It could conceivably fail on hexadecimal or decimal machines
// * without guard digits, but we know of none.
// *
// * Arguments
// * =========
// *
// * UPLO (input) CHARACTER*1
// * = 'U': D and E define an upper bidiagonal matrix.
// * = 'L': D and E define a lower bidiagonal matrix.
// *
// * SMLSIZ (input) INTEGER
// * The maximum size of the subproblems at the bottom of the
// * computation tree.
// *
// * N (input) INTEGER
// * The dimension of the bidiagonal matrix. N >= 0.
// *
// * NRHS (input) INTEGER
// * The number of columns of B. NRHS must be at least 1.
// *
// * D (input/output) DOUBLE PRECISION array, dimension (N)
// * On entry D contains the main diagonal of the bidiagonal
// * matrix. On exit, if INFO = 0, D contains its singular values.
// *
// * E (input/output) DOUBLE PRECISION array, dimension (N-1)
// * Contains the super-diagonal entries of the bidiagonal matrix.
// * On exit, E has been destroyed.
// *
// * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
// * On input, B contains the right hand sides of the least
// * squares problem. On output, B contains the solution X.
// *
// * LDB (input) INTEGER
// * The leading dimension of B in the calling subprogram.
// * LDB must be at least max(1,N).
// *
// * RCOND (input) DOUBLE PRECISION
// * The singular values of A less than or equal to RCOND times
// * the largest singular value are treated as zero in solving
// * the least squares problem. If RCOND is negative,
// * machine precision is used instead.
// * For example, if diag(S)*X=B were the least squares problem,
// * where diag(S) is a diagonal matrix of singular values, the
// * solution would be X(i) = B(i) / S(i) if S(i) is greater than
// * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
// * RCOND*max(S).
// *
// * RANK (output) INTEGER
// * The number of singular values of A greater than RCOND times
// * the largest singular value.
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension at least
// * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
// * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
// *
// * IWORK (workspace) INTEGER array, dimension at least
// * (3*N*NLVL + 11*N)
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: The algorithm failed to compute an singular value while
// * working on the submatrix lying in rows and columns
// * INFO/(N+1) through MOD(INFO,N+1).
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Ming Gu and Ren-Cang Li, Computer Science Division, University of
// * California at Berkeley, USA
// * Osni Marques, LBNL/NERSC, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, INT, LOG, SIGN;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if (N < 0)
{
INFO = -3;
}
else
{
if (NRHS < 1)
{
INFO = -4;
}
else
{
if ((LDB < 1) || (LDB < N))
{
INFO = -8;
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DLALSD", -INFO);
return;
}
// *
EPS = this._dlamch.Run("Epsilon");
// *
// * Set up the tolerance.
// *
if ((RCOND <= ZERO) || (RCOND >= ONE))
{
RCND = EPS;
}
else
{
RCND = RCOND;
}
// *
RANK = 0;
// *
// * Quick return if possible.
// *
if (N == 0)
{
return;
}
else
{
if (N == 1)
{
if (D[1 + o_d] == ZERO)
{
this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref B, offset_b
, LDB);
}
else
{
RANK = 1;
this._dlascl.Run("G", 0, 0, D[1 + o_d], ONE, 1
, NRHS, ref B, offset_b, LDB, ref INFO);
D[1 + o_d] = Math.Abs(D[1 + o_d]);
}
return;
}
}
// *
// * Rotate the matrix if it is lower bidiagonal.
// *
if (UPLO == "L")
{
for (I = 1; I <= N - 1; I++)
{
this._dlartg.Run(D[I + o_d], E[I + o_e], ref CS, ref SN, ref R);
D[I + o_d] = R;
E[I + o_e] = SN * D[I + 1 + o_d];
D[I + 1 + o_d] *= CS;
if (NRHS == 1)
{
this._drot.Run(1, ref B, I + 1 * LDB + o_b, 1, ref B, I + 1 + 1 * LDB + o_b, 1, CS
, SN);
}
else
{
WORK[I * 2 - 1 + o_work] = CS;
WORK[I * 2 + o_work] = SN;
}
}
if (NRHS > 1)
{
for (I = 1; I <= NRHS; I++)
{
for (J = 1; J <= N - 1; J++)
{
CS = WORK[J * 2 - 1 + o_work];
SN = WORK[J * 2 + o_work];
this._drot.Run(1, ref B, J + I * LDB + o_b, 1, ref B, J + 1 + I * LDB + o_b, 1, CS
, SN);
}
}
}
}
// *
// * Scale.
// *
NM1 = N - 1;
ORGNRM = this._dlanst.Run("M", N, D, offset_d, E, offset_e);
if (ORGNRM == ZERO)
{
this._dlaset.Run("A", N, NRHS, ZERO, ZERO, ref B, offset_b
, LDB);
return;
}
// *
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N
, 1, ref D, offset_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, NM1
, 1, ref E, offset_e, NM1, ref INFO);
// *
// * If N is smaller than the minimum divide size SMLSIZ, then solve
// * the problem with another solver.
// *
if (N <= SMLSIZ)
{
NWORK = 1 + N * N;
this._dlaset.Run("A", N, N, ZERO, ONE, ref WORK, offset_work
, N);
this._dlasdq.Run("U", 0, N, N, 0, NRHS
, ref D, offset_d, ref E, offset_e, ref WORK, offset_work, N, ref WORK, offset_work, N
, ref B, offset_b, LDB, ref WORK, NWORK + o_work, ref INFO);
if (INFO != 0)
{
return;
}
TOL = RCND * Math.Abs(D[this._idamax.Run(N, D, offset_d, 1) + o_d]);
for (I = 1; I <= N; I++)
{
if (D[I + o_d] <= TOL)
{
this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref B, I + 1 * LDB + o_b
, LDB);
}
else
{
this._dlascl.Run("G", 0, 0, D[I + o_d], ONE, 1
, NRHS, ref B, I + 1 * LDB + o_b, LDB, ref INFO);
RANK += 1;
}
}
this._dgemm.Run("T", "N", N, NRHS, N, ONE
, WORK, offset_work, N, B, offset_b, LDB, ZERO, ref WORK, NWORK + o_work
, N);
this._dlacpy.Run("A", N, NRHS, WORK, NWORK + o_work, N, ref B, offset_b
, LDB);
// *
// * Unscale.
// *
this._dlascl.Run("G", 0, 0, ONE, ORGNRM, N
, 1, ref D, offset_d, N, ref INFO);
this._dlasrt.Run("D", N, ref D, offset_d, ref INFO);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N
, NRHS, ref B, offset_b, LDB, ref INFO);
// *
return;
}
// *
// * Book-keeping and setting up some constants.
// *
NLVL = Convert.ToInt32(Math.Truncate(Math.Log(Convert.ToDouble(N) / Convert.ToDouble(SMLSIZ + 1)) / Math.Log(TWO))) + 1;
// *
SMLSZP = SMLSIZ + 1;
// *
U = 1;
VT = 1 + SMLSIZ * N;
DIFL = VT + SMLSZP * N;
DIFR = DIFL + NLVL * N;
Z = DIFR + NLVL * N * 2;
C = Z + NLVL * N;
S = C + N;
POLES = S + N;
GIVNUM = POLES + 2 * NLVL * N;
BX = GIVNUM + 2 * NLVL * N;
NWORK = BX + N * NRHS;
// *
SIZEI = 1 + N;
K = SIZEI + N;
GIVPTR = K + N;
PERM = GIVPTR + N;
GIVCOL = PERM + NLVL * N;
IWK = GIVCOL + NLVL * N * 2;
// *
ST = 1;
SQRE = 0;
ICMPQ1 = 1;
ICMPQ2 = 0;
NSUB = 0;
// *
for (I = 1; I <= N; I++)
{
if (Math.Abs(D[I + o_d]) < EPS)
{
D[I + o_d] = FortranLib.Sign(EPS, D[I + o_d]);
}
}
// *
for (I = 1; I <= NM1; I++)
{
if ((Math.Abs(E[I + o_e]) < EPS) || (I == NM1))
{
NSUB += 1;
IWORK[NSUB + o_iwork] = ST;
// *
// * Subproblem found. First determine its size and then
// * apply divide and conquer on it.
// *
if (I < NM1)
{
// *
// * A subproblem with E(I) small for I < NM1.
// *
NSIZE = I - ST + 1;
IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE;
}
else
{
if (Math.Abs(E[I + o_e]) >= EPS)
{
// *
// * A subproblem with E(NM1) not too small but I = NM1.
// *
NSIZE = N - ST + 1;
IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE;
}
else
{
// *
// * A subproblem with E(NM1) small. This implies an
// * 1-by-1 subproblem at D(N), which is not solved
// * explicitly.
// *
NSIZE = I - ST + 1;
IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE;
NSUB += 1;
IWORK[NSUB + o_iwork] = N;
IWORK[SIZEI + NSUB - 1 + o_iwork] = 1;
this._dcopy.Run(NRHS, B, N + 1 * LDB + o_b, LDB, ref WORK, BX + NM1 + o_work, N);
}
}
ST1 = ST - 1;
if (NSIZE == 1)
{
// *
// * This is a 1-by-1 subproblem and is not solved
// * explicitly.
// *
this._dcopy.Run(NRHS, B, ST + 1 * LDB + o_b, LDB, ref WORK, BX + ST1 + o_work, N);
}
else
{
if (NSIZE <= SMLSIZ)
{
// *
// * This is a small subproblem and is solved by DLASDQ.
// *
this._dlaset.Run("A", NSIZE, NSIZE, ZERO, ONE, ref WORK, VT + ST1 + o_work
, N);
this._dlasdq.Run("U", 0, NSIZE, NSIZE, 0, NRHS
, ref D, ST + o_d, ref E, ST + o_e, ref WORK, VT + ST1 + o_work, N, ref WORK, NWORK + o_work, N
, ref B, ST + 1 * LDB + o_b, LDB, ref WORK, NWORK + o_work, ref INFO);
if (INFO != 0)
{
return;
}
this._dlacpy.Run("A", NSIZE, NRHS, B, ST + 1 * LDB + o_b, LDB, ref WORK, BX + ST1 + o_work
, N);
}
else
{
// *
// * A large problem. Solve it using divide and conquer.
// *
this._dlasda.Run(ICMPQ1, SMLSIZ, NSIZE, SQRE, ref D, ST + o_d, ref E, ST + o_e
, ref WORK, U + ST1 + o_work, N, ref WORK, VT + ST1 + o_work, ref IWORK, K + ST1 + o_iwork, ref WORK, DIFL + ST1 + o_work, ref WORK, DIFR + ST1 + o_work
, ref WORK, Z + ST1 + o_work, ref WORK, POLES + ST1 + o_work, ref IWORK, GIVPTR + ST1 + o_iwork, ref IWORK, GIVCOL + ST1 + o_iwork, N, ref IWORK, PERM + ST1 + o_iwork
, ref WORK, GIVNUM + ST1 + o_work, ref WORK, C + ST1 + o_work, ref WORK, S + ST1 + o_work, ref WORK, NWORK + o_work, ref IWORK, IWK + o_iwork, ref INFO);
if (INFO != 0)
{
return;
}
BXST = BX + ST1;
this._dlalsa.Run(ICMPQ2, SMLSIZ, NSIZE, NRHS, ref B, ST + 1 * LDB + o_b, LDB
, ref WORK, BXST + o_work, N, WORK, U + ST1 + o_work, N, WORK, VT + ST1 + o_work, IWORK, K + ST1 + o_iwork
, WORK, DIFL + ST1 + o_work, WORK, DIFR + ST1 + o_work, WORK, Z + ST1 + o_work, WORK, POLES + ST1 + o_work, IWORK, GIVPTR + ST1 + o_iwork, IWORK, GIVCOL + ST1 + o_iwork
, N, IWORK, PERM + ST1 + o_iwork, WORK, GIVNUM + ST1 + o_work, WORK, C + ST1 + o_work, WORK, S + ST1 + o_work, ref WORK, NWORK + o_work
, ref IWORK, IWK + o_iwork, ref INFO);
if (INFO != 0)
{
return;
}
}
}
ST = I + 1;
}
}
// *
// * Apply the singular values and treat the tiny ones as zero.
// *
TOL = RCND * Math.Abs(D[this._idamax.Run(N, D, offset_d, 1) + o_d]);
// *
for (I = 1; I <= N; I++)
{
// *
// * Some of the elements in D can be negative because 1-by-1
// * subproblems were not solved explicitly.
// *
if (Math.Abs(D[I + o_d]) <= TOL)
{
this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref WORK, BX + I - 1 + o_work
, N);
}
else
{
RANK += 1;
this._dlascl.Run("G", 0, 0, D[I + o_d], ONE, 1
, NRHS, ref WORK, BX + I - 1 + o_work, N, ref INFO);
}
D[I + o_d] = Math.Abs(D[I + o_d]);
}
// *
// * Now apply back the right singular vectors.
// *
ICMPQ2 = 1;
for (I = 1; I <= NSUB; I++)
{
ST = IWORK[I + o_iwork];
ST1 = ST - 1;
NSIZE = IWORK[SIZEI + I - 1 + o_iwork];
BXST = BX + ST1;
if (NSIZE == 1)
{
this._dcopy.Run(NRHS, WORK, BXST + o_work, N, ref B, ST + 1 * LDB + o_b, LDB);
}
else
{
if (NSIZE <= SMLSIZ)
{
this._dgemm.Run("T", "N", NSIZE, NRHS, NSIZE, ONE
, WORK, VT + ST1 + o_work, N, WORK, BXST + o_work, N, ZERO, ref B, ST + 1 * LDB + o_b
, LDB);
}
else
{
this._dlalsa.Run(ICMPQ2, SMLSIZ, NSIZE, NRHS, ref WORK, BXST + o_work, N
, ref B, ST + 1 * LDB + o_b, LDB, WORK, U + ST1 + o_work, N, WORK, VT + ST1 + o_work, IWORK, K + ST1 + o_iwork
, WORK, DIFL + ST1 + o_work, WORK, DIFR + ST1 + o_work, WORK, Z + ST1 + o_work, WORK, POLES + ST1 + o_work, IWORK, GIVPTR + ST1 + o_iwork, IWORK, GIVCOL + ST1 + o_iwork
, N, IWORK, PERM + ST1 + o_iwork, WORK, GIVNUM + ST1 + o_work, WORK, C + ST1 + o_work, WORK, S + ST1 + o_work, ref WORK, NWORK + o_work
, ref IWORK, IWK + o_iwork, ref INFO);
if (INFO != 0)
{
return;
}
}
}
}
// *
// * Unscale and sort the singular values.
// *
this._dlascl.Run("G", 0, 0, ONE, ORGNRM, N
, 1, ref D, offset_d, N, ref INFO);
this._dlasrt.Run("D", N, ref D, offset_d, ref INFO);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N
, NRHS, ref B, offset_b, LDB, ref INFO);
// *
return;
// *
// * End of DLALSD
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLACON estimates the 1-norm of a square, real matrix A.
/// Reverse communication is used for evaluating matrix-vector products.
///
///</summary>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix. N .GE. 1.
///</param>
/// <param name="V">
/// (workspace) DOUBLE PRECISION array, dimension (N)
/// On the final return, V = A*W, where EST = norm(V)/norm(W)
/// (W is not returned).
///</param>
/// <param name="X">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On an intermediate return, X should be overwritten by
/// A * X, if KASE=1,
/// A' * X, if KASE=2,
/// and DLACON must be re-called with all the other parameters
/// unchanged.
///</param>
/// <param name="ISGN">
/// (workspace) INTEGER array, dimension (N)
///</param>
/// <param name="EST">
/// (output) DOUBLE PRECISION
/// An estimate (a lower bound) for norm(A).
///</param>
/// <param name="KASE">
/// (input/output) INTEGER
/// On the initial call to DLACON, KASE should be 0.
/// On an intermediate return, KASE will be 1 or 2, indicating
/// whether X should be overwritten by A * X or A' * X.
/// On the final return from DLACON, KASE will again be 0.
///</param>
public void Run(int N, ref double[] V, int offset_v, ref double[] X, int offset_x, ref int[] ISGN, int offset_isgn, ref double EST, ref int KASE)
{
#region Array Index Correction
int o_v = -1 + offset_v; int o_x = -1 + offset_x; int o_isgn = -1 + offset_isgn;
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.0) --
// * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
// * Courant Institute, Argonne National Lab, and Rice University
// * February 29, 1992
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLACON estimates the 1-norm of a square, real matrix A.
// * Reverse communication is used for evaluating matrix-vector products.
// *
// * Arguments
// * =========
// *
// * N (input) INTEGER
// * The order of the matrix. N >= 1.
// *
// * V (workspace) DOUBLE PRECISION array, dimension (N)
// * On the final return, V = A*W, where EST = norm(V)/norm(W)
// * (W is not returned).
// *
// * X (input/output) DOUBLE PRECISION array, dimension (N)
// * On an intermediate return, X should be overwritten by
// * A * X, if KASE=1,
// * A' * X, if KASE=2,
// * and DLACON must be re-called with all the other parameters
// * unchanged.
// *
// * ISGN (workspace) INTEGER array, dimension (N)
// *
// * EST (output) DOUBLE PRECISION
// * An estimate (a lower bound) for norm(A).
// *
// * KASE (input/output) INTEGER
// * On the initial call to DLACON, KASE should be 0.
// * On an intermediate return, KASE will be 1 or 2, indicating
// * whether X should be overwritten by A * X or A' * X.
// * On the final return from DLACON, KASE will again be 0.
// *
// * Further Details
// * ======= =======
// *
// * Contributed by Nick Higham, University of Manchester.
// * Originally named SONEST, dated March 16, 1988.
// *
// * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
// * a real or complex matrix, with applications to condition estimation",
// * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, NINT, SIGN;
// * ..
// * .. Save statement ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
if (KASE == 0)
{
for (I = 1; I <= N; I++)
{
X[I + o_x] = ONE / Convert.ToDouble(N);
}
KASE = 1;
JUMP = 1;
return;
}
// *
switch (JUMP)
{
case 1: goto LABEL20;
case 2: goto LABEL40;
case 3: goto LABEL70;
case 4: goto LABEL110;
case 5: goto LABEL140;
}
// *
// * ................ ENTRY (JUMP = 1)
// * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
// *
LABEL20 :;
if (N == 1)
{
V[1 + o_v] = X[1 + o_x];
EST = Math.Abs(V[1 + o_v]);
// * ... QUIT
goto LABEL150;
}
EST = this._dasum.Run(N, X, offset_x, 1);
// *
for (I = 1; I <= N; I++)
{
X[I + o_x] = FortranLib.Sign(ONE, X[I + o_x]);
ISGN[I + o_isgn] = (int)Math.Round(X[I + o_x]);
}
KASE = 2;
JUMP = 2;
return;
// *
// * ................ ENTRY (JUMP = 2)
// * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
// *
LABEL40 :;
J = this._idamax.Run(N, X, offset_x, 1);
ITER = 2;
// *
// * MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
// *
LABEL50 :;
for (I = 1; I <= N; I++)
{
X[I + o_x] = ZERO;
}
X[J + o_x] = ONE;
KASE = 1;
JUMP = 3;
return;
// *
// * ................ ENTRY (JUMP = 3)
// * X HAS BEEN OVERWRITTEN BY A*X.
// *
LABEL70 :;
this._dcopy.Run(N, X, offset_x, 1, ref V, offset_v, 1);
ESTOLD = EST;
EST = this._dasum.Run(N, V, offset_v, 1);
for (I = 1; I <= N; I++)
{
if (Math.Round(FortranLib.Sign(ONE, X[I + o_x])) != ISGN[I + o_isgn])
{
goto LABEL90;
}
}
// * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
goto LABEL120;
// *
LABEL90 :;
// * TEST FOR CYCLING.
if (EST <= ESTOLD)
{
goto LABEL120;
}
// *
for (I = 1; I <= N; I++)
{
X[I + o_x] = FortranLib.Sign(ONE, X[I + o_x]);
ISGN[I + o_isgn] = (int)Math.Round(X[I + o_x]);
}
KASE = 2;
JUMP = 4;
return;
// *
// * ................ ENTRY (JUMP = 4)
// * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
// *
LABEL110 :;
JLAST = J;
J = this._idamax.Run(N, X, offset_x, 1);
if ((X[JLAST + o_x] != Math.Abs(X[J + o_x])) && (ITER < ITMAX))
{
ITER += 1;
goto LABEL50;
}
// *
// * ITERATION COMPLETE. FINAL STAGE.
// *
LABEL120 :;
ALTSGN = ONE;
for (I = 1; I <= N; I++)
{
X[I + o_x] = ALTSGN * (ONE + Convert.ToDouble(I - 1) / Convert.ToDouble(N - 1));
ALTSGN = -ALTSGN;
}
KASE = 1;
JUMP = 5;
return;
// *
// * ................ ENTRY (JUMP = 5)
// * X HAS BEEN OVERWRITTEN BY A*X.
// *
LABEL140 :;
TEMP = TWO * (this._dasum.Run(N, X, offset_x, 1) / Convert.ToDouble(3 * N));
if (TEMP > EST)
{
this._dcopy.Run(N, X, offset_x, 1, ref V, offset_v, 1);
EST = TEMP;
}
// *
LABEL150 :;
KASE = 0;
return;
// *
// * End of DLACON
// *
#endregion
}
public void Run(int N, IFAREN FCN, ref double X, ref double[] Y, int offset_y, double XEND, ref double HMAX
, ref double H, double[] RTOL, int offset_rtol, double[] ATOL, int offset_atol, int ITOL, int IPRINT, ISOLOUT SOLOUT
, int IOUT, ref int IDID, int NMAX, double UROUND, int METH, int NSTIFF
, double SAFE, double BETA, double FAC1, double FAC2, ref double[] Y1, int offset_y1, ref double[] K1, int offset_k1
, ref double[] K2, int offset_k2, ref double[] K3, int offset_k3, ref double[] K4, int offset_k4, ref double[] K5, int offset_k5, ref double[] K6, int offset_k6, ref double[] YSTI, int offset_ysti
, ref double[] CONT, int offset_cont, int[] ICOMP, int offset_icomp, int NRD, double[] RPAR, int offset_rpar, int[] IPAR, int offset_ipar, ref int NFCN
, ref int NSTEP, ref int NACCPT, ref int NREJCT)
{
#region Variables
bool REJECT = false; bool LAST = false;
#endregion
#region Implicit Variables
double FACOLD = 0; double EXPO1 = 0; double FACC1 = 0; double FACC2 = 0; double POSNEG = 0; double ATOLI = 0;
double RTOLI = 0; double HLAMB = 0; int IASTI = 0; int IORD = 0; int IRTRN = 0; int I = 0; double A21 = 0;
double A31 = 0; double A32 = 0; double A41 = 0; double A42 = 0; double A43 = 0; double A51 = 0; double A52 = 0;
double A53 = 0; double A54 = 0; double A61 = 0; double A62 = 0; double A63 = 0; double A64 = 0; double A65 = 0;
double XPH = 0; double A71 = 0; double A73 = 0; double A74 = 0; double A75 = 0; double A76 = 0; int J = 0;
double D1 = 0; double D3 = 0; double D4 = 0; double D5 = 0; double D6 = 0; double D7 = 0; double E1 = 0; double E3 = 0;
double E4 = 0; double E5 = 0; double E6 = 0; double E7 = 0; double ERR = 0; double SK = 0; double FAC11 = 0;
double FAC = 0; double HNEW = 0; double STNUM = 0; double STDEN = 0; int NONSTI = 0; double YD0 = 0; double YDIFF = 0;
double BSPL = 0; double C2 = 0; double C3 = 0; double C4 = 0; double C5 = 0;
#endregion
#region Array Index Correction
int o_y = -1 + offset_y; int o_rtol = -1 + offset_rtol; int o_atol = -1 + offset_atol; int o_y1 = -1 + offset_y1;
int o_k1 = -1 + offset_k1; int o_k2 = -1 + offset_k2; int o_k3 = -1 + offset_k3; int o_k4 = -1 + offset_k4;
int o_k5 = -1 + offset_k5; int o_k6 = -1 + offset_k6; int o_ysti = -1 + offset_ysti; int o_cont = -1 + offset_cont;
int o_icomp = -1 + offset_icomp; int o_rpar = -1 + offset_rpar; int o_ipar = -1 + offset_ipar;
#endregion
// C ----------------------------------------------------------
// C CORE INTEGRATOR FOR DOPRI5
// C PARAMETERS SAME AS IN DOPRI5 WITH WORKSPACE ADDED
// C ----------------------------------------------------------
// C DECLARATIONS
// C ----------------------------------------------------------
// C *** *** *** *** *** *** ***
// C INITIALISATIONS
// C *** *** *** *** *** *** ***
#region Body
if (METH == 1)
{
this._cdopri.Run(ref C2, ref C3, ref C4, ref C5, ref E1, ref E3
, ref E4, ref E5, ref E6, ref E7, ref A21, ref A31
, ref A32, ref A41, ref A42, ref A43, ref A51, ref A52
, ref A53, ref A54, ref A61, ref A62, ref A63, ref A64
, ref A65, ref A71, ref A73, ref A74, ref A75, ref A76
, ref D1, ref D3, ref D4, ref D5, ref D6, ref D7);
}
FACOLD = 1.0E-4;
EXPO1 = 0.2E0 - BETA * 0.75E0;
FACC1 = 1.0E0 / FAC1;
FACC2 = 1.0E0 / FAC2;
POSNEG = FortranLib.Sign(1.0E0, XEND - X);
// C --- INITIAL PREPARATIONS
ATOLI = ATOL[1 + o_atol];
RTOLI = RTOL[1 + o_rtol];
LAST = false;
HLAMB = 0.0E0;
IASTI = 0;
FCN.Run(N, X, Y, offset_y, ref K1, offset_k1, RPAR, offset_rpar, IPAR[1 + o_ipar]);
HMAX = Math.Abs(HMAX);
IORD = 5;
if (H == 0.0E0)
{
H = this._hinit.Run(N, FCN, X, Y, offset_y, XEND, POSNEG, K1, offset_k1, ref K2, offset_k2, ref K3, offset_k3, IORD, HMAX, ATOL, offset_atol, RTOL, offset_rtol, ITOL, RPAR, offset_rpar, IPAR, offset_ipar);
}
NFCN += 2;
REJECT = false;
XOLD.v = X;
if (IOUT != 0)
{
IRTRN = 1;
HOUT.v = H;
SOLOUT.Run(NACCPT + 1, XOLD.v, X, Y, offset_y, N, CONT, offset_cont
, ICOMP, offset_icomp, NRD, RPAR, offset_rpar, IPAR[1 + o_ipar], IRTRN);
if (IRTRN < 0)
{
goto LABEL79;
}
}
else
{
IRTRN = 0;
}
// C --- BASIC INTEGRATION STEP
LABEL1 :;
if (NSTEP > NMAX)
{
goto LABEL78;
}
if (0.1E0 * Math.Abs(H) <= Math.Abs(X) * UROUND)
{
goto LABEL77;
}
if ((X + 1.01E0 * H - XEND) * POSNEG > 0.0E0)
{
H = XEND - X;
LAST = true;
}
NSTEP += 1;
// C --- THE FIRST 6 STAGES
if (IRTRN >= 2)
{
FCN.Run(N, X, Y, offset_y, ref K1, offset_k1, RPAR, offset_rpar, IPAR[1 + o_ipar]);
}
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * A21 * K1[I + o_k1];
}
FCN.Run(N, X + C2 * H, Y1, offset_y1, ref K2, offset_k2, RPAR, offset_rpar, IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * (A31 * K1[I + o_k1] + A32 * K2[I + o_k2]);
}
FCN.Run(N, X + C3 * H, Y1, offset_y1, ref K3, offset_k3, RPAR, offset_rpar, IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * (A41 * K1[I + o_k1] + A42 * K2[I + o_k2] + A43 * K3[I + o_k3]);
}
FCN.Run(N, X + C4 * H, Y1, offset_y1, ref K4, offset_k4, RPAR, offset_rpar, IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * (A51 * K1[I + o_k1] + A52 * K2[I + o_k2] + A53 * K3[I + o_k3] + A54 * K4[I + o_k4]);
}
FCN.Run(N, X + C5 * H, Y1, offset_y1, ref K5, offset_k5, RPAR, offset_rpar, IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
YSTI[I + o_ysti] = Y[I + o_y] + H * (A61 * K1[I + o_k1] + A62 * K2[I + o_k2] + A63 * K3[I + o_k3] + A64 * K4[I + o_k4] + A65 * K5[I + o_k5]);
}
XPH = X + H;
FCN.Run(N, XPH, YSTI, offset_ysti, ref K6, offset_k6, RPAR, offset_rpar, IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
Y1[I + o_y1] = Y[I + o_y] + H * (A71 * K1[I + o_k1] + A73 * K3[I + o_k3] + A74 * K4[I + o_k4] + A75 * K5[I + o_k5] + A76 * K6[I + o_k6]);
}
FCN.Run(N, XPH, Y1, offset_y1, ref K2, offset_k2, RPAR, offset_rpar, IPAR[1 + o_ipar]);
if (IOUT >= 2)
{
for (J = 1; J <= NRD; J++)
{
I = ICOMP[J + o_icomp];
CONT[4 * NRD + J + o_cont] = H * (D1 * K1[I + o_k1] + D3 * K3[I + o_k3] + D4 * K4[I + o_k4] + D5 * K5[I + o_k5] + D6 * K6[I + o_k6] + D7 * K2[I + o_k2]);
}
}
for (I = 1; I <= N; I++)
{
K4[I + o_k4] = (E1 * K1[I + o_k1] + E3 * K3[I + o_k3] + E4 * K4[I + o_k4] + E5 * K5[I + o_k5] + E6 * K6[I + o_k6] + E7 * K2[I + o_k2]) * H;
}
NFCN += 6;
// C --- ERROR ESTIMATION
ERR = 0.0E0;
if (ITOL == 0)
{
for (I = 1; I <= N; I++)
{
SK = ATOLI + RTOLI * Math.Max(Math.Abs(Y[I + o_y]), Math.Abs(Y1[I + o_y1]));
ERR += Math.Pow(K4[I + o_k4] / SK, 2);
}
}
else
{
for (I = 1; I <= N; I++)
{
SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Max(Math.Abs(Y[I + o_y]), Math.Abs(Y1[I + o_y1]));
ERR += Math.Pow(K4[I + o_k4] / SK, 2);
}
}
ERR = Math.Sqrt(ERR / N);
// C --- COMPUTATION OF HNEW
FAC11 = Math.Pow(ERR, EXPO1);
// C --- LUND-STABILIZATION
FAC = FAC11 / Math.Pow(FACOLD, BETA);
// C --- WE REQUIRE FAC1 <= HNEW/H <= FAC2
FAC = Math.Max(FACC2, Math.Min(FACC1, FAC / SAFE));
HNEW = H / FAC;
if (ERR <= 1.0E0)
{
// C --- STEP IS ACCEPTED
FACOLD = Math.Max(ERR, 1.0E-4);
NACCPT += 1;
// C ------- STIFFNESS DETECTION
if (FortranLib.Mod(NACCPT, NSTIFF) == 0 || IASTI > 0)
{
STNUM = 0.0E0;
STDEN = 0.0E0;
for (I = 1; I <= N; I++)
{
STNUM += Math.Pow(K2[I + o_k2] - K6[I + o_k6], 2);
STDEN += Math.Pow(Y1[I + o_y1] - YSTI[I + o_ysti], 2);
}
if (STDEN > 0.0E0)
{
HLAMB = H * Math.Sqrt(STNUM / STDEN);
}
if (HLAMB > 3.25E0)
{
NONSTI = 0;
IASTI += 1;
if (IASTI == 15)
{
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,*)' THE PROBLEM SEEMS TO BECOME STIFF AT X = ',X
}
if (IPRINT <= 0)
{
goto LABEL76;
}
}
}
else
{
NONSTI += 1;
if (NONSTI == 6)
{
IASTI = 0;
}
}
}
if (IOUT >= 2)
{
for (J = 1; J <= NRD; J++)
{
I = ICOMP[J + o_icomp];
YD0 = Y[I + o_y];
YDIFF = Y1[I + o_y1] - YD0;
BSPL = H * K1[I + o_k1] - YDIFF;
CONT[J + o_cont] = Y[I + o_y];
CONT[NRD + J + o_cont] = YDIFF;
CONT[2 * NRD + J + o_cont] = BSPL;
CONT[3 * NRD + J + o_cont] = -H * K2[I + o_k2] + YDIFF - BSPL;
}
}
for (I = 1; I <= N; I++)
{
K1[I + o_k1] = K2[I + o_k2];
Y[I + o_y] = Y1[I + o_y1];
}
XOLD.v = X;
X = XPH;
if (IOUT != 0)
{
HOUT.v = H;
SOLOUT.Run(NACCPT + 1, XOLD.v, X, Y, offset_y, N, CONT, offset_cont
, ICOMP, offset_icomp, NRD, RPAR, offset_rpar, IPAR[1 + o_ipar], IRTRN);
if (IRTRN < 0)
{
goto LABEL79;
}
}
// C ------- NORMAL EXIT
if (LAST)
{
H = HNEW;
IDID = 1;
return;
}
if (Math.Abs(HNEW) > HMAX)
{
HNEW = POSNEG * HMAX;
}
if (REJECT)
{
HNEW = POSNEG * Math.Min(Math.Abs(HNEW), Math.Abs(H));
}
REJECT = false;
}
else
{
// C --- STEP IS REJECTED
HNEW = H / Math.Min(FACC1, FAC11 / SAFE);
REJECT = true;
if (NACCPT >= 1)
{
NREJCT += 1;
}
LAST = false;
}
H = HNEW;
goto LABEL1;
// C --- FAIL EXIT
LABEL76 :;
IDID = -4;
return;
LABEL77 :;
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,979)X
}
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,*)' STEP SIZE T0O SMALL, H=',H
}
IDID = -3;
return;
LABEL78 :;
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,979)X
}
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,*)' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED'
}
IDID = -2;
return;
LABEL79 :;
if (IPRINT > 0)
{
; //ERROR-ERRORWRITE(IPRINT,979)X
}
IDID = 2;
return;
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLAED3 finds the roots of the secular equation, as defined by the
/// values in D, W, and RHO, between 1 and K. It makes the
/// appropriate calls to DLAED4 and then updates the eigenvectors by
/// multiplying the matrix of eigenvectors of the pair of eigensystems
/// being combined by the matrix of eigenvectors of the K-by-K system
/// which is solved here.
///
/// This code makes very mild assumptions about floating point
/// arithmetic. It will work on machines with a guard digit in
/// add/subtract, or on those binary machines without guard digits
/// which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
/// It could conceivably fail on hexadecimal or decimal machines
/// without guard digits, but we know of none.
///
///</summary>
/// <param name="K">
/// (input) INTEGER
/// The number of terms in the rational function to be solved by
/// DLAED4. K .GE. 0.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of rows and columns in the Q matrix.
/// N .GE. K (deflation may result in N.GT.K).
///</param>
/// <param name="N1">
/// (input) INTEGER
/// The location of the last eigenvalue in the leading submatrix.
/// min(1,N) .LE. N1 .LE. N/2.
///</param>
/// <param name="D">
/// (output) DOUBLE PRECISION array, dimension (N)
/// D(I) contains the updated eigenvalues for
/// 1 .LE. I .LE. K.
///</param>
/// <param name="Q">
/// (output) DOUBLE PRECISION array, dimension (LDQ,N)
/// Initially the first K columns are used as workspace.
/// On output the columns 1 to K contain
/// the updated eigenvectors.
///</param>
/// <param name="LDQ">
/// (input) INTEGER
/// The leading dimension of the array Q. LDQ .GE. max(1,N).
///</param>
/// <param name="RHO">
/// (input) DOUBLE PRECISION
/// The value of the parameter in the rank one update equation.
/// RHO .GE. 0 required.
///</param>
/// <param name="DLAMDA">
/// (input/output) DOUBLE PRECISION array, dimension (K)
/// The first K elements of this array contain the old roots
/// of the deflated updating problem. These are the poles
/// of the secular equation. May be changed on output by
/// having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
/// Cray-2, or Cray C-90, as described above.
///</param>
/// <param name="Q2">
/// (input) DOUBLE PRECISION array, dimension (LDQ2, N)
/// The first K columns of this matrix contain the non-deflated
/// eigenvectors for the split problem.
///</param>
/// <param name="INDX">
/// (input) INTEGER array, dimension (N)
/// The permutation used to arrange the columns of the deflated
/// Q matrix into three groups (see DLAED2).
/// The rows of the eigenvectors found by DLAED4 must be likewise
/// permuted before the matrix multiply can take place.
///</param>
/// <param name="CTOT">
/// (input) INTEGER array, dimension (4)
/// A count of the total number of the various types of columns
/// in Q, as described in INDX. The fourth column type is any
/// column which has been deflated.
///</param>
/// <param name="W">
/// (input/output) DOUBLE PRECISION array, dimension (K)
/// The first K elements of this array contain the components
/// of the deflation-adjusted updating vector. Destroyed on
/// output.
///</param>
/// <param name="S">
/// (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
/// Will contain the eigenvectors of the repaired matrix which
/// will be multiplied by the previously accumulated eigenvectors
/// to update the system.
///</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 = 1, an eigenvalue did not converge
///</param>
public void Run(int K, int N, int N1, ref double[] D, int offset_d, ref double[] Q, int offset_q, int LDQ
, double RHO, ref double[] DLAMDA, int offset_dlamda, double[] Q2, int offset_q2, int[] INDX, int offset_indx, int[] CTOT, int offset_ctot, ref double[] W, int offset_w
, ref double[] S, int offset_s, ref int INFO)
{
#region Variables
int I = 0; int II = 0; int IQ2 = 0; int J = 0; int N12 = 0; int N2 = 0; int N23 = 0; double TEMP = 0;
#endregion
#region Implicit Variables
int Q_J = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_q = -1 - LDQ + offset_q; int o_dlamda = -1 + offset_dlamda;
int o_q2 = -1 + offset_q2; int o_indx = -1 + offset_indx; int o_ctot = -1 + offset_ctot; int o_w = -1 + offset_w;
int o_s = -1 + offset_s;
#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
// * =======
// *
// * DLAED3 finds the roots of the secular equation, as defined by the
// * values in D, W, and RHO, between 1 and K. It makes the
// * appropriate calls to DLAED4 and then updates the eigenvectors by
// * multiplying the matrix of eigenvectors of the pair of eigensystems
// * being combined by the matrix of eigenvectors of the K-by-K system
// * which is solved here.
// *
// * This code makes very mild assumptions about floating point
// * arithmetic. It will work on machines with a guard digit in
// * add/subtract, or on those binary machines without guard digits
// * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
// * It could conceivably fail on hexadecimal or decimal machines
// * without guard digits, but we know of none.
// *
// * Arguments
// * =========
// *
// * K (input) INTEGER
// * The number of terms in the rational function to be solved by
// * DLAED4. K >= 0.
// *
// * N (input) INTEGER
// * The number of rows and columns in the Q matrix.
// * N >= K (deflation may result in N>K).
// *
// * N1 (input) INTEGER
// * The location of the last eigenvalue in the leading submatrix.
// * min(1,N) <= N1 <= N/2.
// *
// * D (output) DOUBLE PRECISION array, dimension (N)
// * D(I) contains the updated eigenvalues for
// * 1 <= I <= K.
// *
// * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
// * Initially the first K columns are used as workspace.
// * On output the columns 1 to K contain
// * the updated eigenvectors.
// *
// * LDQ (input) INTEGER
// * The leading dimension of the array Q. LDQ >= max(1,N).
// *
// * RHO (input) DOUBLE PRECISION
// * The value of the parameter in the rank one update equation.
// * RHO >= 0 required.
// *
// * DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
// * The first K elements of this array contain the old roots
// * of the deflated updating problem. These are the poles
// * of the secular equation. May be changed on output by
// * having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
// * Cray-2, or Cray C-90, as described above.
// *
// * Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
// * The first K columns of this matrix contain the non-deflated
// * eigenvectors for the split problem.
// *
// * INDX (input) INTEGER array, dimension (N)
// * The permutation used to arrange the columns of the deflated
// * Q matrix into three groups (see DLAED2).
// * The rows of the eigenvectors found by DLAED4 must be likewise
// * permuted before the matrix multiply can take place.
// *
// * CTOT (input) INTEGER array, dimension (4)
// * A count of the total number of the various types of columns
// * in Q, as described in INDX. The fourth column type is any
// * column which has been deflated.
// *
// * W (input/output) DOUBLE PRECISION array, dimension (K)
// * The first K elements of this array contain the components
// * of the deflation-adjusted updating vector. Destroyed on
// * output.
// *
// * S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
// * Will contain the eigenvectors of the repaired matrix which
// * will be multiplied by the previously accumulated eigenvectors
// * to update the system.
// *
// * LDS (input) INTEGER
// * The leading dimension of S. LDS >= max(1,K).
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = 1, an eigenvalue did not converge
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Jeff Rutter, Computer Science Division, University of California
// * at Berkeley, USA
// * Modified by Francoise Tisseur, University of Tennessee.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if (K < 0)
{
INFO = -1;
}
else
{
if (N < K)
{
INFO = -2;
}
else
{
if (LDQ < Math.Max(1, N))
{
INFO = -6;
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DLAED3", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (K == 0)
{
return;
}
// *
// * Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
// * be computed with high relative accuracy (barring over/underflow).
// * This is a problem on machines without a guard digit in
// * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
// * The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
// * which on any of these machines zeros out the bottommost
// * bit of DLAMDA(I) if it is 1; this makes the subsequent
// * subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
// * occurs. On binary machines with a guard digit (almost all
// * machines) it does not change DLAMDA(I) at all. On hexadecimal
// * and decimal machines with a guard digit, it slightly
// * changes the bottommost bits of DLAMDA(I). It does not account
// * for hexadecimal or decimal machines without guard digits
// * (we know of none). We use a subroutine call to compute
// * 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
// * this code.
// *
for (I = 1; I <= K; I++)
{
DLAMDA[I + o_dlamda] = this._dlamc3.Run(DLAMDA[I + o_dlamda], DLAMDA[I + o_dlamda]) - DLAMDA[I + o_dlamda];
}
// *
for (J = 1; J <= K; J++)
{
this._dlaed4.Run(K, J, DLAMDA, offset_dlamda, W, offset_w, ref Q, 1 + J * LDQ + o_q, RHO
, ref D[J + o_d], ref INFO);
// *
// * If the zero finder fails, the computation is terminated.
// *
if (INFO != 0)
{
goto LABEL120;
}
}
// *
if (K == 1)
{
goto LABEL110;
}
if (K == 2)
{
for (J = 1; J <= K; J++)
{
W[1 + o_w] = Q[1 + J * LDQ + o_q];
W[2 + o_w] = Q[2 + J * LDQ + o_q];
II = INDX[1 + o_indx];
Q[1 + J * LDQ + o_q] = W[II + o_w];
II = INDX[2 + o_indx];
Q[2 + J * LDQ + o_q] = W[II + o_w];
}
goto LABEL110;
}
// *
// * Compute updated W.
// *
this._dcopy.Run(K, W, offset_w, 1, ref S, offset_s, 1);
// *
// * Initialize W(I) = Q(I,I)
// *
this._dcopy.Run(K, Q, offset_q, LDQ + 1, ref W, offset_w, 1);
for (J = 1; J <= K; J++)
{
Q_J = J * LDQ + o_q;
for (I = 1; I <= J - 1; I++)
{
W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda]));
}
Q_J = J * LDQ + o_q;
for (I = J + 1; I <= K; I++)
{
W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda]));
}
}
for (I = 1; I <= K; I++)
{
W[I + o_w] = FortranLib.Sign(Math.Sqrt(-W[I + o_w]), S[I + o_s]);
}
// *
// * Compute eigenvectors of the modified rank-1 modification.
// *
for (J = 1; J <= K; J++)
{
Q_J = J * LDQ + o_q;
for (I = 1; I <= K; I++)
{
S[I + o_s] = W[I + o_w] / Q[I + Q_J];
}
TEMP = this._dnrm2.Run(K, S, offset_s, 1);
Q_J = J * LDQ + o_q;
for (I = 1; I <= K; I++)
{
II = INDX[I + o_indx];
Q[I + Q_J] = S[II + o_s] / TEMP;
}
}
// *
// * Compute the updated eigenvectors.
// *
LABEL110 :;
// *
N2 = N - N1;
N12 = CTOT[1 + o_ctot] + CTOT[2 + o_ctot];
N23 = CTOT[2 + o_ctot] + CTOT[3 + o_ctot];
// *
this._dlacpy.Run("A", N23, K, Q, CTOT[1 + o_ctot] + 1 + 1 * LDQ + o_q, LDQ, ref S, offset_s
, N23);
IQ2 = N1 * N12 + 1;
if (N23 != 0)
{
this._dgemm.Run("N", "N", N2, K, N23, ONE
, Q2, IQ2 + o_q2, N2, S, offset_s, N23, ZERO, ref Q, N1 + 1 + 1 * LDQ + o_q
, LDQ);
}
else
{
this._dlaset.Run("A", N2, K, ZERO, ZERO, ref Q, N1 + 1 + 1 * LDQ + o_q
, LDQ);
}
// *
this._dlacpy.Run("A", N12, K, Q, offset_q, LDQ, ref S, offset_s
, N12);
if (N12 != 0)
{
this._dgemm.Run("N", "N", N1, K, N12, ONE
, Q2, offset_q2, N1, S, offset_s, N12, ZERO, ref Q, offset_q
, LDQ);
}
else
{
this._dlaset.Run("A", N1, K, ZERO, ZERO, ref Q, 1 + 1 * LDQ + o_q
, LDQ);
}
// *
// *
LABEL120 :;
return;
// *
// * End of DLAED3
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLASD3 finds all the square roots of the roots of the secular
/// equation, as defined by the values in D and Z. It makes the
/// appropriate calls to DLASD4 and then updates the singular
/// vectors by matrix multiplication.
///
/// This code makes very mild assumptions about floating point
/// arithmetic. It will work on machines with a guard digit in
/// add/subtract, or on those binary machines without guard digits
/// which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
/// It could conceivably fail on hexadecimal or decimal machines
/// without guard digits, but we know of none.
///
/// DLASD3 is called from DLASD1.
///
///</summary>
/// <param name="NL">
/// (input) INTEGER
/// The row dimension of the upper block. NL .GE. 1.
///</param>
/// <param name="NR">
/// (input) INTEGER
/// The row dimension of the lower block. NR .GE. 1.
///</param>
/// <param name="SQRE">
/// (input) INTEGER
/// = 0: the lower block is an NR-by-NR square matrix.
/// = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
///
/// The bidiagonal matrix has N = NL + NR + 1 rows and
/// M = N + SQRE .GE. N columns.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The size of the secular equation, 1 =.LT. K = .LT. N.
///</param>
/// <param name="D">
/// (output) DOUBLE PRECISION array, dimension(K)
/// On exit the square roots of the roots of the secular equation,
/// in ascending order.
///</param>
/// <param name="Q">
/// (workspace) DOUBLE PRECISION array,
/// dimension at least (LDQ,K).
///</param>
/// <param name="LDQ">
/// (input) INTEGER
/// The leading dimension of the array Q. LDQ .GE. K.
///</param>
/// <param name="DSIGMA">
/// (input) DOUBLE PRECISION array, dimension(K)
/// The first K elements of this array contain the old roots
/// of the deflated updating problem. These are the poles
/// of the secular equation.
///</param>
/// <param name="U">
/// (output) DOUBLE PRECISION array, dimension (LDU, N)
/// The last N - K columns of this matrix contain the deflated
/// left singular vectors.
///</param>
/// <param name="LDU">
/// (input) INTEGER
/// The leading dimension of the array U. LDU .GE. N.
///</param>
/// <param name="U2">
/// (input/output) DOUBLE PRECISION array, dimension (LDU2, N)
/// The first K columns of this matrix contain the non-deflated
/// left singular vectors for the split problem.
///</param>
/// <param name="LDU2">
/// (input) INTEGER
/// The leading dimension of the array U2. LDU2 .GE. N.
///</param>
/// <param name="VT">
/// (output) DOUBLE PRECISION array, dimension (LDVT, M)
/// The last M - K columns of VT' contain the deflated
/// right singular vectors.
///</param>
/// <param name="LDVT">
/// (input) INTEGER
/// The leading dimension of the array VT. LDVT .GE. N.
///</param>
/// <param name="VT2">
/// (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)
/// The first K columns of VT2' contain the non-deflated
/// right singular vectors for the split problem.
///</param>
/// <param name="LDVT2">
/// (input) INTEGER
/// The leading dimension of the array VT2. LDVT2 .GE. N.
///</param>
/// <param name="IDXC">
/// (input) INTEGER array, dimension ( N )
/// The permutation used to arrange the columns of U (and rows of
/// VT) into three groups: the first group contains non-zero
/// entries only at and above (or before) NL +1; the second
/// contains non-zero entries only at and below (or after) NL+2;
/// and the third is dense. The first column of U and the row of
/// VT are treated separately, however.
///
/// The rows of the singular vectors found by DLASD4
/// must be likewise permuted before the matrix multiplies can
/// take place.
///</param>
/// <param name="CTOT">
/// (input) INTEGER array, dimension ( 4 )
/// A count of the total number of the various types of columns
/// in U (or rows in VT), as described in IDXC. The fourth column
/// type is any column which has been deflated.
///</param>
/// <param name="Z">
/// (input) DOUBLE PRECISION array, dimension (K)
/// The first K elements of this array contain the components
/// of the deflation-adjusted updating row vector.
///</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 = 1, an singular value did not converge
///</param>
public void Run(int NL, int NR, int SQRE, int K, ref double[] D, int offset_d, ref double[] Q, int offset_q
, int LDQ, ref double[] DSIGMA, int offset_dsigma, ref double[] U, int offset_u, int LDU, double[] U2, int offset_u2, int LDU2
, ref double[] VT, int offset_vt, int LDVT, ref double[] VT2, int offset_vt2, int LDVT2, int[] IDXC, int offset_idxc, int[] CTOT, int offset_ctot
, ref double[] Z, int offset_z, ref int INFO)
{
#region Variables
int CTEMP = 0; int I = 0; int J = 0; int JC = 0; int KTEMP = 0; int M = 0; int N = 0; int NLP1 = 0; int NLP2 = 0;
int NRP1 = 0; double RHO = 0; double TEMP = 0;
#endregion
#region Implicit Variables
int U_1 = 0; int U2_1 = 0; int U_K = 0; int VT_K = 0; int VT_I = 0; int U_I = 0; int Q_I = 0; int Q_1 = 0;
int Q_KTEMP = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_q = -1 - LDQ + offset_q; int o_dsigma = -1 + offset_dsigma;
int o_u = -1 - LDU + offset_u; int o_u2 = -1 - LDU2 + offset_u2; int o_vt = -1 - LDVT + offset_vt;
int o_vt2 = -1 - LDVT2 + offset_vt2; int o_idxc = -1 + offset_idxc; int o_ctot = -1 + offset_ctot;
int o_z = -1 + offset_z;
#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
// * =======
// *
// * DLASD3 finds all the square roots of the roots of the secular
// * equation, as defined by the values in D and Z. It makes the
// * appropriate calls to DLASD4 and then updates the singular
// * vectors by matrix multiplication.
// *
// * This code makes very mild assumptions about floating point
// * arithmetic. It will work on machines with a guard digit in
// * add/subtract, or on those binary machines without guard digits
// * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
// * It could conceivably fail on hexadecimal or decimal machines
// * without guard digits, but we know of none.
// *
// * DLASD3 is called from DLASD1.
// *
// * Arguments
// * =========
// *
// * NL (input) INTEGER
// * The row dimension of the upper block. NL >= 1.
// *
// * NR (input) INTEGER
// * The row dimension of the lower block. NR >= 1.
// *
// * SQRE (input) INTEGER
// * = 0: the lower block is an NR-by-NR square matrix.
// * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
// *
// * The bidiagonal matrix has N = NL + NR + 1 rows and
// * M = N + SQRE >= N columns.
// *
// * K (input) INTEGER
// * The size of the secular equation, 1 =< K = < N.
// *
// * D (output) DOUBLE PRECISION array, dimension(K)
// * On exit the square roots of the roots of the secular equation,
// * in ascending order.
// *
// * Q (workspace) DOUBLE PRECISION array,
// * dimension at least (LDQ,K).
// *
// * LDQ (input) INTEGER
// * The leading dimension of the array Q. LDQ >= K.
// *
// * DSIGMA (input) DOUBLE PRECISION array, dimension(K)
// * The first K elements of this array contain the old roots
// * of the deflated updating problem. These are the poles
// * of the secular equation.
// *
// * U (output) DOUBLE PRECISION array, dimension (LDU, N)
// * The last N - K columns of this matrix contain the deflated
// * left singular vectors.
// *
// * LDU (input) INTEGER
// * The leading dimension of the array U. LDU >= N.
// *
// * U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)
// * The first K columns of this matrix contain the non-deflated
// * left singular vectors for the split problem.
// *
// * LDU2 (input) INTEGER
// * The leading dimension of the array U2. LDU2 >= N.
// *
// * VT (output) DOUBLE PRECISION array, dimension (LDVT, M)
// * The last M - K columns of VT' contain the deflated
// * right singular vectors.
// *
// * LDVT (input) INTEGER
// * The leading dimension of the array VT. LDVT >= N.
// *
// * VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)
// * The first K columns of VT2' contain the non-deflated
// * right singular vectors for the split problem.
// *
// * LDVT2 (input) INTEGER
// * The leading dimension of the array VT2. LDVT2 >= N.
// *
// * IDXC (input) INTEGER array, dimension ( N )
// * The permutation used to arrange the columns of U (and rows of
// * VT) into three groups: the first group contains non-zero
// * entries only at and above (or before) NL +1; the second
// * contains non-zero entries only at and below (or after) NL+2;
// * and the third is dense. The first column of U and the row of
// * VT are treated separately, however.
// *
// * The rows of the singular vectors found by DLASD4
// * must be likewise permuted before the matrix multiplies can
// * take place.
// *
// * CTOT (input) INTEGER array, dimension ( 4 )
// * A count of the total number of the various types of columns
// * in U (or rows in VT), as described in IDXC. The fourth column
// * type is any column which has been deflated.
// *
// * Z (input) DOUBLE PRECISION array, dimension (K)
// * The first K elements of this array contain the components
// * of the deflation-adjusted updating row vector.
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = 1, an singular value did not converge
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Ming Gu and Huan Ren, Computer Science Division, University of
// * California at Berkeley, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if (NL < 1)
{
INFO = -1;
}
else
{
if (NR < 1)
{
INFO = -2;
}
else
{
if ((SQRE != 1) && (SQRE != 0))
{
INFO = -3;
}
}
}
// *
N = NL + NR + 1;
M = N + SQRE;
NLP1 = NL + 1;
NLP2 = NL + 2;
// *
if ((K < 1) || (K > N))
{
INFO = -4;
}
else
{
if (LDQ < K)
{
INFO = -7;
}
else
{
if (LDU < N)
{
INFO = -10;
}
else
{
if (LDU2 < N)
{
INFO = -12;
}
else
{
if (LDVT < M)
{
INFO = -14;
}
else
{
if (LDVT2 < M)
{
INFO = -16;
}
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DLASD3", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (K == 1)
{
D[1 + o_d] = Math.Abs(Z[1 + o_z]);
this._dcopy.Run(M, VT2, 1 + 1 * LDVT2 + o_vt2, LDVT2, ref VT, 1 + 1 * LDVT + o_vt, LDVT);
if (Z[1 + o_z] > ZERO)
{
this._dcopy.Run(N, U2, 1 + 1 * LDU2 + o_u2, 1, ref U, 1 + 1 * LDU + o_u, 1);
}
else
{
U_1 = 1 * LDU + o_u;
U2_1 = 1 * LDU2 + o_u2;
for (I = 1; I <= N; I++)
{
U[I + U_1] = -U2[I + U2_1];
}
}
return;
}
// *
// * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
// * be computed with high relative accuracy (barring over/underflow).
// * This is a problem on machines without a guard digit in
// * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
// * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
// * which on any of these machines zeros out the bottommost
// * bit of DSIGMA(I) if it is 1; this makes the subsequent
// * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
// * occurs. On binary machines with a guard digit (almost all
// * machines) it does not change DSIGMA(I) at all. On hexadecimal
// * and decimal machines with a guard digit, it slightly
// * changes the bottommost bits of DSIGMA(I). It does not account
// * for hexadecimal or decimal machines without guard digits
// * (we know of none). We use a subroutine call to compute
// * 2*DSIGMA(I) to prevent optimizing compilers from eliminating
// * this code.
// *
for (I = 1; I <= K; I++)
{
DSIGMA[I + o_dsigma] = this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGMA[I + o_dsigma]) - DSIGMA[I + o_dsigma];
}
// *
// * Keep a copy of Z.
// *
this._dcopy.Run(K, Z, offset_z, 1, ref Q, offset_q, 1);
// *
// * Normalize Z.
// *
RHO = this._dnrm2.Run(K, Z, offset_z, 1);
this._dlascl.Run("G", 0, 0, RHO, ONE, K
, 1, ref Z, offset_z, K, ref INFO);
RHO *= RHO;
// *
// * Find the new singular values.
// *
for (J = 1; J <= K; J++)
{
this._dlasd4.Run(K, J, DSIGMA, offset_dsigma, Z, offset_z, ref U, 1 + J * LDU + o_u, RHO
, ref D[J + o_d], ref VT, 1 + J * LDVT + o_vt, ref INFO);
// *
// * If the zero finder fails, the computation is terminated.
// *
if (INFO != 0)
{
return;
}
}
// *
// * Compute updated Z.
// *
U_K = K * LDU + o_u;
VT_K = K * LDVT + o_vt;
for (I = 1; I <= K; I++)
{
Z[I + o_z] = U[I + U_K] * VT[I + VT_K];
for (J = 1; J <= I - 1; J++)
{
Z[I + o_z] = Z[I + o_z] * (U[I + J * LDU + o_u] * VT[I + J * LDVT + o_vt] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma]));
}
for (J = I; J <= K - 1; J++)
{
Z[I + o_z] = Z[I + o_z] * (U[I + J * LDU + o_u] * VT[I + J * LDVT + o_vt] / (DSIGMA[I + o_dsigma] - DSIGMA[J + 1 + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + 1 + o_dsigma]));
}
Z[I + o_z] = FortranLib.Sign(Math.Sqrt(Math.Abs(Z[I + o_z])), Q[I + 1 * LDQ + o_q]);
}
// *
// * Compute left singular vectors of the modified diagonal matrix,
// * and store related information for the right singular vectors.
// *
for (I = 1; I <= K; I++)
{
VT[1 + I * LDVT + o_vt] = Z[1 + o_z] / U[1 + I * LDU + o_u] / VT[1 + I * LDVT + o_vt];
U[1 + I * LDU + o_u] = NEGONE;
VT_I = I * LDVT + o_vt;
U_I = I * LDU + o_u;
for (J = 2; J <= K; J++)
{
VT[J + VT_I] = Z[J + o_z] / U[J + U_I] / VT[J + VT_I];
U[J + U_I] = DSIGMA[J + o_dsigma] * VT[J + VT_I];
}
TEMP = this._dnrm2.Run(K, U, 1 + I * LDU + o_u, 1);
Q[1 + I * LDQ + o_q] = U[1 + I * LDU + o_u] / TEMP;
Q_I = I * LDQ + o_q;
for (J = 2; J <= K; J++)
{
JC = IDXC[J + o_idxc];
Q[J + Q_I] = U[JC + I * LDU + o_u] / TEMP;
}
}
// *
// * Update the left singular vector matrix.
// *
if (K == 2)
{
this._dgemm.Run("N", "N", N, K, K, ONE
, U2, offset_u2, LDU2, Q, offset_q, LDQ, ZERO, ref U, offset_u
, LDU);
goto LABEL100;
}
if (CTOT[1 + o_ctot] > 0)
{
this._dgemm.Run("N", "N", NL, K, CTOT[1 + o_ctot], ONE
, U2, 1 + 2 * LDU2 + o_u2, LDU2, Q, 2 + 1 * LDQ + o_q, LDQ, ZERO, ref U, 1 + 1 * LDU + o_u
, LDU);
if (CTOT[3 + o_ctot] > 0)
{
KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot];
this._dgemm.Run("N", "N", NL, K, CTOT[3 + o_ctot], ONE
, U2, 1 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ONE, ref U, 1 + 1 * LDU + o_u
, LDU);
}
}
else
{
if (CTOT[3 + o_ctot] > 0)
{
KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot];
this._dgemm.Run("N", "N", NL, K, CTOT[3 + o_ctot], ONE
, U2, 1 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ZERO, ref U, 1 + 1 * LDU + o_u
, LDU);
}
else
{
this._dlacpy.Run("F", NL, K, U2, offset_u2, LDU2, ref U, offset_u
, LDU);
}
}
this._dcopy.Run(K, Q, 1 + 1 * LDQ + o_q, LDQ, ref U, NLP1 + 1 * LDU + o_u, LDU);
KTEMP = 2 + CTOT[1 + o_ctot];
CTEMP = CTOT[2 + o_ctot] + CTOT[3 + o_ctot];
this._dgemm.Run("N", "N", NR, K, CTEMP, ONE
, U2, NLP2 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ZERO, ref U, NLP2 + 1 * LDU + o_u
, LDU);
// *
// * Generate the right singular vectors.
// *
LABEL100 :;
Q_1 = 1 * LDQ + o_q;
for (I = 1; I <= K; I++)
{
TEMP = this._dnrm2.Run(K, VT, 1 + I * LDVT + o_vt, 1);
Q[I + Q_1] = VT[1 + I * LDVT + o_vt] / TEMP;
for (J = 2; J <= K; J++)
{
JC = IDXC[J + o_idxc];
Q[I + J * LDQ + o_q] = VT[JC + I * LDVT + o_vt] / TEMP;
}
}
// *
// * Update the right singular vector matrix.
// *
if (K == 2)
{
this._dgemm.Run("N", "N", K, M, K, ONE
, Q, offset_q, LDQ, VT2, offset_vt2, LDVT2, ZERO, ref VT, offset_vt
, LDVT);
return;
}
KTEMP = 1 + CTOT[1 + o_ctot];
this._dgemm.Run("N", "N", K, NLP1, KTEMP, ONE
, Q, 1 + 1 * LDQ + o_q, LDQ, VT2, 1 + 1 * LDVT2 + o_vt2, LDVT2, ZERO, ref VT, 1 + 1 * LDVT + o_vt
, LDVT);
KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot];
if (KTEMP <= LDVT2)
{
this._dgemm.Run("N", "N", K, NLP1, CTOT[3 + o_ctot], ONE
, Q, 1 + KTEMP * LDQ + o_q, LDQ, VT2, KTEMP + 1 * LDVT2 + o_vt2, LDVT2, ONE, ref VT, 1 + 1 * LDVT + o_vt
, LDVT);
}
// *
KTEMP = CTOT[1 + o_ctot] + 1;
NRP1 = NR + SQRE;
if (KTEMP > 1)
{
Q_KTEMP = KTEMP * LDQ + o_q;
Q_1 = 1 * LDQ + o_q;
for (I = 1; I <= K; I++)
{
Q[I + Q_KTEMP] = Q[I + Q_1];
}
for (I = NLP2; I <= M; I++)
{
VT2[KTEMP + I * LDVT2 + o_vt2] = VT2[1 + I * LDVT2 + o_vt2];
}
}
CTEMP = 1 + CTOT[2 + o_ctot] + CTOT[3 + o_ctot];
this._dgemm.Run("N", "N", K, NRP1, CTEMP, ONE
, Q, 1 + KTEMP * LDQ + o_q, LDQ, VT2, KTEMP + NLP2 * LDVT2 + o_vt2, LDVT2, ZERO, ref VT, 1 + NLP2 * LDVT + o_vt
, LDVT);
// *
return;
// *
// * End of DLASD3
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLASD8 finds the square roots of the roots of the secular equation,
/// as defined by the values in DSIGMA and Z. It makes the appropriate
/// calls to DLASD4, and stores, for each element in D, the distance
/// to its two nearest poles (elements in DSIGMA). It also updates
/// the arrays VF and VL, the first and last components of all the
/// right singular vectors of the original bidiagonal matrix.
///
/// DLASD8 is called from DLASD6.
///
///</summary>
/// <param name="ICOMPQ">
/// (input) INTEGER
/// Specifies whether singular vectors are to be computed in
/// factored form in the calling routine:
/// = 0: Compute singular values only.
/// = 1: Compute singular vectors in factored form as well.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The number of terms in the rational function to be solved
/// by DLASD4. K .GE. 1.
///</param>
/// <param name="D">
/// (output) DOUBLE PRECISION array, dimension ( K )
/// On output, D contains the updated singular values.
///</param>
/// <param name="Z">
/// (input) DOUBLE PRECISION array, dimension ( K )
/// The first K elements of this array contain the components
/// of the deflation-adjusted updating row vector.
///</param>
/// <param name="VF">
/// (input/output) DOUBLE PRECISION array, dimension ( K )
/// On entry, VF contains information passed through DBEDE8.
/// On exit, VF contains the first K components of the first
/// components of all right singular vectors of the bidiagonal
/// matrix.
///</param>
/// <param name="VL">
/// (input/output) DOUBLE PRECISION array, dimension ( K )
/// On entry, VL contains information passed through DBEDE8.
/// On exit, VL contains the first K components of the last
/// components of all right singular vectors of the bidiagonal
/// matrix.
///</param>
/// <param name="DIFL">
/// (output) DOUBLE PRECISION array, dimension ( K )
/// On exit, DIFL(I) = D(I) - DSIGMA(I).
///</param>
/// <param name="DIFR">
/// (output) DOUBLE PRECISION array,
/// dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
/// dimension ( K ) if ICOMPQ = 0.
/// On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
/// defined and will not be referenced.
///
/// If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
/// normalizing factors for the right singular vector matrix.
///</param>
/// <param name="LDDIFR">
/// (input) INTEGER
/// The leading dimension of DIFR, must be at least K.
///</param>
/// <param name="DSIGMA">
/// (input) DOUBLE PRECISION array, dimension ( K )
/// The first K elements of this array contain the old roots
/// of the deflated updating problem. These are the poles
/// of the secular equation.
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension at least 3 * K
///</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 = 1, an singular value did not converge
///</param>
public void Run(int ICOMPQ, int K, ref double[] D, int offset_d, ref double[] Z, int offset_z, ref double[] VF, int offset_vf, ref double[] VL, int offset_vl
, ref double[] DIFL, int offset_difl, ref double[] DIFR, int offset_difr, int LDDIFR, ref double[] DSIGMA, int offset_dsigma, ref double[] WORK, int offset_work, ref int INFO)
{
#region Variables
int I = 0; int IWK1 = 0; int IWK2 = 0; int IWK2I = 0; int IWK3 = 0; int IWK3I = 0; int J = 0; double DIFLJ = 0;
double DIFRJ = 0; double DJ = 0; double DSIGJ = 0; double DSIGJP = 0; double RHO = 0; double TEMP = 0;
#endregion
#region Implicit Variables
int DIFR_1 = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_z = -1 + offset_z; int o_vf = -1 + offset_vf; int o_vl = -1 + offset_vl;
int o_difl = -1 + offset_difl; int o_difr = -1 - LDDIFR + offset_difr; int o_dsigma = -1 + offset_dsigma;
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
// * =======
// *
// * DLASD8 finds the square roots of the roots of the secular equation,
// * as defined by the values in DSIGMA and Z. It makes the appropriate
// * calls to DLASD4, and stores, for each element in D, the distance
// * to its two nearest poles (elements in DSIGMA). It also updates
// * the arrays VF and VL, the first and last components of all the
// * right singular vectors of the original bidiagonal matrix.
// *
// * DLASD8 is called from DLASD6.
// *
// * Arguments
// * =========
// *
// * ICOMPQ (input) INTEGER
// * Specifies whether singular vectors are to be computed in
// * factored form in the calling routine:
// * = 0: Compute singular values only.
// * = 1: Compute singular vectors in factored form as well.
// *
// * K (input) INTEGER
// * The number of terms in the rational function to be solved
// * by DLASD4. K >= 1.
// *
// * D (output) DOUBLE PRECISION array, dimension ( K )
// * On output, D contains the updated singular values.
// *
// * Z (input) DOUBLE PRECISION array, dimension ( K )
// * The first K elements of this array contain the components
// * of the deflation-adjusted updating row vector.
// *
// * VF (input/output) DOUBLE PRECISION array, dimension ( K )
// * On entry, VF contains information passed through DBEDE8.
// * On exit, VF contains the first K components of the first
// * components of all right singular vectors of the bidiagonal
// * matrix.
// *
// * VL (input/output) DOUBLE PRECISION array, dimension ( K )
// * On entry, VL contains information passed through DBEDE8.
// * On exit, VL contains the first K components of the last
// * components of all right singular vectors of the bidiagonal
// * matrix.
// *
// * DIFL (output) DOUBLE PRECISION array, dimension ( K )
// * On exit, DIFL(I) = D(I) - DSIGMA(I).
// *
// * DIFR (output) DOUBLE PRECISION array,
// * dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
// * dimension ( K ) if ICOMPQ = 0.
// * On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
// * defined and will not be referenced.
// *
// * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
// * normalizing factors for the right singular vector matrix.
// *
// * LDDIFR (input) INTEGER
// * The leading dimension of DIFR, must be at least K.
// *
// * DSIGMA (input) DOUBLE PRECISION array, dimension ( K )
// * The first K elements of this array contain the old roots
// * of the deflated updating problem. These are the poles
// * of the secular equation.
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = 1, an singular value did not converge
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Ming Gu and Huan Ren, Computer Science Division, University of
// * California at Berkeley, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. External Functions ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if ((ICOMPQ < 0) || (ICOMPQ > 1))
{
INFO = -1;
}
else
{
if (K < 1)
{
INFO = -2;
}
else
{
if (LDDIFR < K)
{
INFO = -9;
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DLASD8", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (K == 1)
{
D[1 + o_d] = Math.Abs(Z[1 + o_z]);
DIFL[1 + o_difl] = D[1 + o_d];
if (ICOMPQ == 1)
{
DIFL[2 + o_difl] = ONE;
DIFR[1 + 2 * LDDIFR + o_difr] = ONE;
}
return;
}
// *
// * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
// * be computed with high relative accuracy (barring over/underflow).
// * This is a problem on machines without a guard digit in
// * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
// * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
// * which on any of these machines zeros out the bottommost
// * bit of DSIGMA(I) if it is 1; this makes the subsequent
// * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
// * occurs. On binary machines with a guard digit (almost all
// * machines) it does not change DSIGMA(I) at all. On hexadecimal
// * and decimal machines with a guard digit, it slightly
// * changes the bottommost bits of DSIGMA(I). It does not account
// * for hexadecimal or decimal machines without guard digits
// * (we know of none). We use a subroutine call to compute
// * 2*DSIGMA(I) to prevent optimizing compilers from eliminating
// * this code.
// *
for (I = 1; I <= K; I++)
{
DSIGMA[I + o_dsigma] = this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGMA[I + o_dsigma]) - DSIGMA[I + o_dsigma];
}
// *
// * Book keeping.
// *
IWK1 = 1;
IWK2 = IWK1 + K;
IWK3 = IWK2 + K;
IWK2I = IWK2 - 1;
IWK3I = IWK3 - 1;
// *
// * Normalize Z.
// *
RHO = this._dnrm2.Run(K, Z, offset_z, 1);
this._dlascl.Run("G", 0, 0, RHO, ONE, K
, 1, ref Z, offset_z, K, ref INFO);
RHO *= RHO;
// *
// * Initialize WORK(IWK3).
// *
this._dlaset.Run("A", K, 1, ONE, ONE, ref WORK, IWK3 + o_work
, K);
// *
// * Compute the updated singular values, the arrays DIFL, DIFR,
// * and the updated Z.
// *
DIFR_1 = 1 * LDDIFR + o_difr;
for (J = 1; J <= K; J++)
{
this._dlasd4.Run(K, J, DSIGMA, offset_dsigma, Z, offset_z, ref WORK, IWK1 + o_work, RHO
, ref D[J + o_d], ref WORK, IWK2 + o_work, ref INFO);
// *
// * If the root finder fails, the computation is terminated.
// *
if (INFO != 0)
{
return;
}
WORK[IWK3I + J + o_work] = WORK[IWK3I + J + o_work] * WORK[J + o_work] * WORK[IWK2I + J + o_work];
DIFL[J + o_difl] = -WORK[J + o_work];
DIFR[J + DIFR_1] = -WORK[J + 1 + o_work];
for (I = 1; I <= J - 1; I++)
{
WORK[IWK3I + I + o_work] = WORK[IWK3I + I + o_work] * WORK[I + o_work] * WORK[IWK2I + I + o_work] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma]);
}
for (I = J + 1; I <= K; I++)
{
WORK[IWK3I + I + o_work] = WORK[IWK3I + I + o_work] * WORK[I + o_work] * WORK[IWK2I + I + o_work] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma]);
}
}
// *
// * Compute updated Z.
// *
for (I = 1; I <= K; I++)
{
Z[I + o_z] = FortranLib.Sign(Math.Sqrt(Math.Abs(WORK[IWK3I + I + o_work])), Z[I + o_z]);
}
// *
// * Update VF and VL.
// *
for (J = 1; J <= K; J++)
{
DIFLJ = DIFL[J + o_difl];
DJ = D[J + o_d];
DSIGJ = -DSIGMA[J + o_dsigma];
if (J < K)
{
DIFRJ = -DIFR[J + 1 * LDDIFR + o_difr];
DSIGJP = -DSIGMA[J + 1 + o_dsigma];
}
WORK[J + o_work] = -Z[J + o_z] / DIFLJ / (DSIGMA[J + o_dsigma] + DJ);
for (I = 1; I <= J - 1; I++)
{
WORK[I + o_work] = Z[I + o_z] / (this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGJ) - DIFLJ) / (DSIGMA[I + o_dsigma] + DJ);
}
for (I = J + 1; I <= K; I++)
{
WORK[I + o_work] = Z[I + o_z] / (this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGJP) + DIFRJ) / (DSIGMA[I + o_dsigma] + DJ);
}
TEMP = this._dnrm2.Run(K, WORK, offset_work, 1);
WORK[IWK2I + J + o_work] = this._ddot.Run(K, WORK, offset_work, 1, VF, offset_vf, 1) / TEMP;
WORK[IWK3I + J + o_work] = this._ddot.Run(K, WORK, offset_work, 1, VL, offset_vl, 1) / TEMP;
if (ICOMPQ == 1)
{
DIFR[J + 2 * LDDIFR + o_difr] = TEMP;
}
}
// *
this._dcopy.Run(K, WORK, IWK2 + o_work, 1, ref VF, offset_vf, 1);
this._dcopy.Run(K, WORK, IWK3 + o_work, 1, ref VL, offset_vl, 1);
// *
return;
// *
// * End of DLASD8
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
/// symmetric tridiagonal matrix using the implicit QL or QR method.
/// The eigenvectors of a full or band symmetric matrix can also be found
/// if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
/// tridiagonal form.
///
///</summary>
/// <param name="COMPZ">
/// (input) CHARACTER*1
/// = 'N': Compute eigenvalues only.
/// = 'V': Compute eigenvalues and eigenvectors of the original
/// symmetric matrix. On entry, Z must contain the
/// orthogonal matrix used to reduce the original matrix
/// to tridiagonal form.
/// = 'I': Compute eigenvalues and eigenvectors of the
/// tridiagonal matrix. Z is initialized to the identity
/// matrix.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix. N .GE. 0.
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On entry, the diagonal elements of the tridiagonal matrix.
/// On exit, if INFO = 0, the eigenvalues in ascending order.
///</param>
/// <param name="E">
/// (input/output) DOUBLE PRECISION array, dimension (N-1)
/// On entry, the (n-1) subdiagonal elements of the tridiagonal
/// matrix.
/// On exit, E has been destroyed.
///</param>
/// <param name="Z">
/// (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
/// On entry, if COMPZ = 'V', then Z contains the orthogonal
/// matrix used in the reduction to tridiagonal form.
/// On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
/// orthonormal eigenvectors of the original symmetric matrix,
/// and if COMPZ = 'I', Z contains the orthonormal eigenvectors
/// of the symmetric tridiagonal matrix.
/// If COMPZ = 'N', then Z is not referenced.
///</param>
/// <param name="LDZ">
/// (input) INTEGER
/// The leading dimension of the array Z. LDZ .GE. 1, and if
/// eigenvectors are desired, then LDZ .GE. max(1,N).
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
/// If COMPZ = 'N', then WORK is not referenced.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
/// .GT. 0: the algorithm has failed to find all the eigenvalues in
/// a total of 30*N iterations; if INFO = i, then i
/// elements of E have not converged to zero; on exit, D
/// and E contain the elements of a symmetric tridiagonal
/// matrix which is orthogonally similar to the original
/// matrix.
///</param>
public void Run(string COMPZ, int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref double[] Z, int offset_z, int LDZ
, ref double[] WORK, int offset_work, ref int INFO)
{
#region Variables
int I = 0; int ICOMPZ = 0; int II = 0; int ISCALE = 0; int J = 0; int JTOT = 0; int K = 0; int L = 0; int L1 = 0;
int LEND = 0; int LENDM1 = 0; int LENDP1 = 0; int LENDSV = 0; int LM1 = 0; int LSV = 0; int M = 0; int MM = 0;
int MM1 = 0; int NM1 = 0; int NMAXIT = 0; double ANORM = 0; double B = 0; double C = 0; double EPS = 0;
double EPS2 = 0; double F = 0; double G = 0; double P = 0; double R = 0; double RT1 = 0; double RT2 = 0; double S = 0;
double SAFMAX = 0; double SAFMIN = 0; double SSFMAX = 0; double SSFMIN = 0; double TST = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work;
#endregion
#region Strings
COMPZ = COMPZ.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
// * =======
// *
// * DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
// * symmetric tridiagonal matrix using the implicit QL or QR method.
// * The eigenvectors of a full or band symmetric matrix can also be found
// * if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
// * tridiagonal form.
// *
// * Arguments
// * =========
// *
// * COMPZ (input) CHARACTER*1
// * = 'N': Compute eigenvalues only.
// * = 'V': Compute eigenvalues and eigenvectors of the original
// * symmetric matrix. On entry, Z must contain the
// * orthogonal matrix used to reduce the original matrix
// * to tridiagonal form.
// * = 'I': Compute eigenvalues and eigenvectors of the
// * tridiagonal matrix. Z is initialized to the identity
// * matrix.
// *
// * N (input) INTEGER
// * The order of the matrix. N >= 0.
// *
// * D (input/output) DOUBLE PRECISION array, dimension (N)
// * On entry, the diagonal elements of the tridiagonal matrix.
// * On exit, if INFO = 0, the eigenvalues in ascending order.
// *
// * E (input/output) DOUBLE PRECISION array, dimension (N-1)
// * On entry, the (n-1) subdiagonal elements of the tridiagonal
// * matrix.
// * On exit, E has been destroyed.
// *
// * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
// * On entry, if COMPZ = 'V', then Z contains the orthogonal
// * matrix used in the reduction to tridiagonal form.
// * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
// * orthonormal eigenvectors of the original symmetric matrix,
// * and if COMPZ = 'I', Z contains the orthonormal eigenvectors
// * of the symmetric tridiagonal matrix.
// * If COMPZ = 'N', then Z is not referenced.
// *
// * LDZ (input) INTEGER
// * The leading dimension of the array Z. LDZ >= 1, and if
// * eigenvectors are desired, then LDZ >= max(1,N).
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
// * If COMPZ = 'N', then WORK is not referenced.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// * > 0: the algorithm has failed to find all the eigenvalues in
// * a total of 30*N iterations; if INFO = i, then i
// * elements of E have not converged to zero; on exit, D
// * and E contain the elements of a symmetric tridiagonal
// * matrix which is orthogonally similar to the original
// * matrix.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, MAX, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if (this._lsame.Run(COMPZ, "N"))
{
ICOMPZ = 0;
}
else
{
if (this._lsame.Run(COMPZ, "V"))
{
ICOMPZ = 1;
}
else
{
if (this._lsame.Run(COMPZ, "I"))
{
ICOMPZ = 2;
}
else
{
ICOMPZ = -1;
}
}
}
if (ICOMPZ < 0)
{
INFO = -1;
}
else
{
if (N < 0)
{
INFO = -2;
}
else
{
if ((LDZ < 1) || (ICOMPZ > 0 && LDZ < Math.Max(1, N)))
{
INFO = -6;
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DSTEQR", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (N == 0)
{
return;
}
// *
if (N == 1)
{
if (ICOMPZ == 2)
{
Z[1 + 1 * LDZ + o_z] = ONE;
}
return;
}
// *
// * Determine the unit roundoff and over/underflow thresholds.
// *
EPS = this._dlamch.Run("E");
EPS2 = Math.Pow(EPS, 2);
SAFMIN = this._dlamch.Run("S");
SAFMAX = ONE / SAFMIN;
SSFMAX = Math.Sqrt(SAFMAX) / THREE;
SSFMIN = Math.Sqrt(SAFMIN) / EPS2;
// *
// * Compute the eigenvalues and eigenvectors of the tridiagonal
// * matrix.
// *
if (ICOMPZ == 2)
{
this._dlaset.Run("Full", N, N, ZERO, ONE, ref Z, offset_z
, LDZ);
}
// *
NMAXIT = N * MAXIT;
JTOT = 0;
// *
// * Determine where the matrix splits and choose QL or QR iteration
// * for each block, according to whether top or bottom diagonal
// * element is smaller.
// *
L1 = 1;
NM1 = N - 1;
// *
LABEL10 :;
if (L1 > N)
{
goto LABEL160;
}
if (L1 > 1)
{
E[L1 - 1 + o_e] = ZERO;
}
if (L1 <= NM1)
{
for (M = L1; M <= NM1; M++)
{
TST = Math.Abs(E[M + o_e]);
if (TST == ZERO)
{
goto LABEL30;
}
if (TST <= (Math.Sqrt(Math.Abs(D[M + o_d])) * Math.Sqrt(Math.Abs(D[M + 1 + o_d]))) * EPS)
{
E[M + o_e] = ZERO;
goto LABEL30;
}
}
}
M = N;
// *
LABEL30 :;
L = L1;
LSV = L;
LEND = M;
LENDSV = LEND;
L1 = M + 1;
if (LEND == L)
{
goto LABEL10;
}
// *
// * Scale submatrix in rows and columns L to LEND
// *
ANORM = this._dlanst.Run("I", LEND - L + 1, D, L + o_d, E, L + o_e);
ISCALE = 0;
if (ANORM == ZERO)
{
goto LABEL10;
}
if (ANORM > SSFMAX)
{
ISCALE = 1;
this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L + 1
, 1, ref D, L + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L
, 1, ref E, L + o_e, N, ref INFO);
}
else
{
if (ANORM < SSFMIN)
{
ISCALE = 2;
this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L + 1
, 1, ref D, L + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L
, 1, ref E, L + o_e, N, ref INFO);
}
}
// *
// * Choose between QL and QR iteration
// *
if (Math.Abs(D[LEND + o_d]) < Math.Abs(D[L + o_d]))
{
LEND = LSV;
L = LENDSV;
}
// *
if (LEND > L)
{
// *
// * QL Iteration
// *
// * Look for small subdiagonal element.
// *
LABEL40 :;
if (L != LEND)
{
LENDM1 = LEND - 1;
for (M = L; M <= LENDM1; M++)
{
TST = Math.Pow(Math.Abs(E[M + o_e]), 2);
if (TST <= (EPS2 * Math.Abs(D[M + o_d])) * Math.Abs(D[M + 1 + o_d]) + SAFMIN)
{
goto LABEL60;
}
}
}
// *
M = LEND;
// *
LABEL60 :;
if (M < LEND)
{
E[M + o_e] = ZERO;
}
P = D[L + o_d];
if (M == L)
{
goto LABEL80;
}
// *
// * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
// * to compute its eigensystem.
// *
if (M == L + 1)
{
if (ICOMPZ > 0)
{
this._dlaev2.Run(D[L + o_d], E[L + o_e], D[L + 1 + o_d], ref RT1, ref RT2, ref C
, ref S);
WORK[L + o_work] = C;
WORK[N - 1 + L + o_work] = S;
this._dlasr.Run("R", "V", "B", N, 2, WORK, L + o_work
, WORK, N - 1 + L + o_work, ref Z, 1 + L * LDZ + o_z, LDZ);
}
else
{
this._dlae2.Run(D[L + o_d], E[L + o_e], D[L + 1 + o_d], ref RT1, ref RT2);
}
D[L + o_d] = RT1;
D[L + 1 + o_d] = RT2;
E[L + o_e] = ZERO;
L += 2;
if (L <= LEND)
{
goto LABEL40;
}
goto LABEL140;
}
// *
if (JTOT == NMAXIT)
{
goto LABEL140;
}
JTOT += 1;
// *
// * Form shift.
// *
G = (D[L + 1 + o_d] - P) / (TWO * E[L + o_e]);
R = this._dlapy2.Run(G, ONE);
G = D[M + o_d] - P + (E[L + o_e] / (G + FortranLib.Sign(R, G)));
// *
S = ONE;
C = ONE;
P = ZERO;
// *
// * Inner loop
// *
MM1 = M - 1;
for (I = MM1; I >= L; I += -1)
{
F = S * E[I + o_e];
B = C * E[I + o_e];
this._dlartg.Run(G, F, ref C, ref S, ref R);
if (I != M - 1)
{
E[I + 1 + o_e] = R;
}
G = D[I + 1 + o_d] - P;
R = (D[I + o_d] - G) * S + TWO * C * B;
P = S * R;
D[I + 1 + o_d] = G + P;
G = C * R - B;
// *
// * If eigenvectors are desired, then save rotations.
// *
if (ICOMPZ > 0)
{
WORK[I + o_work] = C;
WORK[N - 1 + I + o_work] = -S;
}
// *
}
// *
// * If eigenvectors are desired, then apply saved rotations.
// *
if (ICOMPZ > 0)
{
MM = M - L + 1;
this._dlasr.Run("R", "V", "B", N, MM, WORK, L + o_work
, WORK, N - 1 + L + o_work, ref Z, 1 + L * LDZ + o_z, LDZ);
}
// *
D[L + o_d] -= P;
E[L + o_e] = G;
goto LABEL40;
// *
// * Eigenvalue found.
// *
LABEL80 :;
D[L + o_d] = P;
// *
L += 1;
if (L <= LEND)
{
goto LABEL40;
}
goto LABEL140;
// *
}
else
{
// *
// * QR Iteration
// *
// * Look for small superdiagonal element.
// *
LABEL90 :;
if (L != LEND)
{
LENDP1 = LEND + 1;
for (M = L; M >= LENDP1; M += -1)
{
TST = Math.Pow(Math.Abs(E[M - 1 + o_e]), 2);
if (TST <= (EPS2 * Math.Abs(D[M + o_d])) * Math.Abs(D[M - 1 + o_d]) + SAFMIN)
{
goto LABEL110;
}
}
}
// *
M = LEND;
// *
LABEL110 :;
if (M > LEND)
{
E[M - 1 + o_e] = ZERO;
}
P = D[L + o_d];
if (M == L)
{
goto LABEL130;
}
// *
// * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
// * to compute its eigensystem.
// *
if (M == L - 1)
{
if (ICOMPZ > 0)
{
this._dlaev2.Run(D[L - 1 + o_d], E[L - 1 + o_e], D[L + o_d], ref RT1, ref RT2, ref C
, ref S);
WORK[M + o_work] = C;
WORK[N - 1 + M + o_work] = S;
this._dlasr.Run("R", "V", "F", N, 2, WORK, M + o_work
, WORK, N - 1 + M + o_work, ref Z, 1 + (L - 1) * LDZ + o_z, LDZ);
}
else
{
this._dlae2.Run(D[L - 1 + o_d], E[L - 1 + o_e], D[L + o_d], ref RT1, ref RT2);
}
D[L - 1 + o_d] = RT1;
D[L + o_d] = RT2;
E[L - 1 + o_e] = ZERO;
L -= 2;
if (L >= LEND)
{
goto LABEL90;
}
goto LABEL140;
}
// *
if (JTOT == NMAXIT)
{
goto LABEL140;
}
JTOT += 1;
// *
// * Form shift.
// *
G = (D[L - 1 + o_d] - P) / (TWO * E[L - 1 + o_e]);
R = this._dlapy2.Run(G, ONE);
G = D[M + o_d] - P + (E[L - 1 + o_e] / (G + FortranLib.Sign(R, G)));
// *
S = ONE;
C = ONE;
P = ZERO;
// *
// * Inner loop
// *
LM1 = L - 1;
for (I = M; I <= LM1; I++)
{
F = S * E[I + o_e];
B = C * E[I + o_e];
this._dlartg.Run(G, F, ref C, ref S, ref R);
if (I != M)
{
E[I - 1 + o_e] = R;
}
G = D[I + o_d] - P;
R = (D[I + 1 + o_d] - G) * S + TWO * C * B;
P = S * R;
D[I + o_d] = G + P;
G = C * R - B;
// *
// * If eigenvectors are desired, then save rotations.
// *
if (ICOMPZ > 0)
{
WORK[I + o_work] = C;
WORK[N - 1 + I + o_work] = S;
}
// *
}
// *
// * If eigenvectors are desired, then apply saved rotations.
// *
if (ICOMPZ > 0)
{
MM = L - M + 1;
this._dlasr.Run("R", "V", "F", N, MM, WORK, M + o_work
, WORK, N - 1 + M + o_work, ref Z, 1 + M * LDZ + o_z, LDZ);
}
// *
D[L + o_d] -= P;
E[LM1 + o_e] = G;
goto LABEL90;
// *
// * Eigenvalue found.
// *
LABEL130 :;
D[L + o_d] = P;
// *
L -= 1;
if (L >= LEND)
{
goto LABEL90;
}
goto LABEL140;
// *
}
// *
// * Undo scaling if necessary
// *
LABEL140 :;
if (ISCALE == 1)
{
this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV + 1
, 1, ref D, LSV + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV
, 1, ref E, LSV + o_e, N, ref INFO);
}
else
{
if (ISCALE == 2)
{
this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV + 1
, 1, ref D, LSV + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV
, 1, ref E, LSV + o_e, N, ref INFO);
}
}
// *
// * Check for no convergence to an eigenvalue after a total
// * of N*MAXIT iterations.
// *
if (JTOT < NMAXIT)
{
goto LABEL10;
}
for (I = 1; I <= N - 1; I++)
{
if (E[I + o_e] != ZERO)
{
INFO += 1;
}
}
goto LABEL190;
// *
// * Order eigenvalues and eigenvectors.
// *
LABEL160 :;
if (ICOMPZ == 0)
{
// *
// * Use Quick Sort
// *
this._dlasrt.Run("I", N, ref D, offset_d, ref INFO);
// *
}
else
{
// *
// * Use Selection Sort to minimize swaps of eigenvectors
// *
for (II = 2; II <= N; II++)
{
I = II - 1;
K = I;
P = D[I + o_d];
for (J = II; J <= N; J++)
{
if (D[J + o_d] < P)
{
K = J;
P = D[J + o_d];
}
}
if (K != I)
{
D[K + o_d] = D[I + o_d];
D[I + o_d] = P;
this._dswap.Run(N, ref Z, 1 + I * LDZ + o_z, 1, ref Z, 1 + K * LDZ + o_z, 1);
}
}
}
// *
LABEL190 :;
return;
// *
// * End of DSTEQR
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
/// using the Pal-Walker-Kahan variant of the QL or QR algorithm.
///
///</summary>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix. N .GE. 0.
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On entry, the n diagonal elements of the tridiagonal matrix.
/// On exit, if INFO = 0, the eigenvalues in ascending order.
///</param>
/// <param name="E">
/// (input/output) DOUBLE PRECISION array, dimension (N-1)
/// On entry, the (n-1) subdiagonal elements of the tridiagonal
/// matrix.
/// On exit, E has been destroyed.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
/// .GT. 0: the algorithm failed to find all of the eigenvalues in
/// a total of 30*N iterations; if INFO = i, then i
/// elements of E have not converged to zero.
///</param>
public void Run(int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref int INFO)
{
#region Variables
int I = 0; int ISCALE = 0; int JTOT = 0; int L = 0; int L1 = 0; int LEND = 0; int LENDSV = 0; int LSV = 0; int M = 0;
int NMAXIT = 0; double ALPHA = 0; double ANORM = 0; double BB = 0; double C = 0; double EPS = 0; double EPS2 = 0;
double GAMMA = 0; double OLDC = 0; double OLDGAM = 0; double P = 0; double R = 0; double RT1 = 0; double RT2 = 0;
double RTE = 0; double S = 0; double SAFMAX = 0; double SAFMIN = 0; double SIGMA = 0; double SSFMAX = 0;
double SSFMIN = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_e = -1 + offset_e;
#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
// * =======
// *
// * DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
// * using the Pal-Walker-Kahan variant of the QL or QR algorithm.
// *
// * Arguments
// * =========
// *
// * N (input) INTEGER
// * The order of the matrix. N >= 0.
// *
// * D (input/output) DOUBLE PRECISION array, dimension (N)
// * On entry, the n diagonal elements of the tridiagonal matrix.
// * On exit, if INFO = 0, the eigenvalues in ascending order.
// *
// * E (input/output) DOUBLE PRECISION array, dimension (N-1)
// * On entry, the (n-1) subdiagonal elements of the tridiagonal
// * matrix.
// * On exit, E has been destroyed.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// * > 0: the algorithm failed to find all of the eigenvalues in
// * a total of 30*N iterations; if INFO = i, then i
// * elements of E have not converged to zero.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
// * Quick return if possible
// *
if (N < 0)
{
INFO = -1;
this._xerbla.Run("DSTERF", -INFO);
return;
}
if (N <= 1)
{
return;
}
// *
// * Determine the unit roundoff for this environment.
// *
EPS = this._dlamch.Run("E");
EPS2 = Math.Pow(EPS, 2);
SAFMIN = this._dlamch.Run("S");
SAFMAX = ONE / SAFMIN;
SSFMAX = Math.Sqrt(SAFMAX) / THREE;
SSFMIN = Math.Sqrt(SAFMIN) / EPS2;
// *
// * Compute the eigenvalues of the tridiagonal matrix.
// *
NMAXIT = N * MAXIT;
SIGMA = ZERO;
JTOT = 0;
// *
// * Determine where the matrix splits and choose QL or QR iteration
// * for each block, according to whether top or bottom diagonal
// * element is smaller.
// *
L1 = 1;
// *
LABEL10 :;
if (L1 > N)
{
goto LABEL170;
}
if (L1 > 1)
{
E[L1 - 1 + o_e] = ZERO;
}
for (M = L1; M <= N - 1; M++)
{
if (Math.Abs(E[M + o_e]) <= (Math.Sqrt(Math.Abs(D[M + o_d])) * Math.Sqrt(Math.Abs(D[M + 1 + o_d]))) * EPS)
{
E[M + o_e] = ZERO;
goto LABEL30;
}
}
M = N;
// *
LABEL30 :;
L = L1;
LSV = L;
LEND = M;
LENDSV = LEND;
L1 = M + 1;
if (LEND == L)
{
goto LABEL10;
}
// *
// * Scale submatrix in rows and columns L to LEND
// *
ANORM = this._dlanst.Run("I", LEND - L + 1, D, L + o_d, E, L + o_e);
ISCALE = 0;
if (ANORM > SSFMAX)
{
ISCALE = 1;
this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L + 1
, 1, ref D, L + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L
, 1, ref E, L + o_e, N, ref INFO);
}
else
{
if (ANORM < SSFMIN)
{
ISCALE = 2;
this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L + 1
, 1, ref D, L + o_d, N, ref INFO);
this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L
, 1, ref E, L + o_e, N, ref INFO);
}
}
// *
for (I = L; I <= LEND - 1; I++)
{
E[I + o_e] = Math.Pow(E[I + o_e], 2);
}
// *
// * Choose between QL and QR iteration
// *
if (Math.Abs(D[LEND + o_d]) < Math.Abs(D[L + o_d]))
{
LEND = LSV;
L = LENDSV;
}
// *
if (LEND >= L)
{
// *
// * QL Iteration
// *
// * Look for small subdiagonal element.
// *
LABEL50 :;
if (L != LEND)
{
for (M = L; M <= LEND - 1; M++)
{
if (Math.Abs(E[M + o_e]) <= EPS2 * Math.Abs(D[M + o_d] * D[M + 1 + o_d]))
{
goto LABEL70;
}
}
}
M = LEND;
// *
LABEL70 :;
if (M < LEND)
{
E[M + o_e] = ZERO;
}
P = D[L + o_d];
if (M == L)
{
goto LABEL90;
}
// *
// * If remaining matrix is 2 by 2, use DLAE2 to compute its
// * eigenvalues.
// *
if (M == L + 1)
{
RTE = Math.Sqrt(E[L + o_e]);
this._dlae2.Run(D[L + o_d], RTE, D[L + 1 + o_d], ref RT1, ref RT2);
D[L + o_d] = RT1;
D[L + 1 + o_d] = RT2;
E[L + o_e] = ZERO;
L += 2;
if (L <= LEND)
{
goto LABEL50;
}
goto LABEL150;
}
// *
if (JTOT == NMAXIT)
{
goto LABEL150;
}
JTOT += 1;
// *
// * Form shift.
// *
RTE = Math.Sqrt(E[L + o_e]);
SIGMA = (D[L + 1 + o_d] - P) / (TWO * RTE);
R = this._dlapy2.Run(SIGMA, ONE);
SIGMA = P - (RTE / (SIGMA + FortranLib.Sign(R, SIGMA)));
// *
C = ONE;
S = ZERO;
GAMMA = D[M + o_d] - SIGMA;
P = GAMMA * GAMMA;
// *
// * Inner loop
// *
for (I = M - 1; I >= L; I += -1)
{
BB = E[I + o_e];
R = P + BB;
if (I != M - 1)
{
E[I + 1 + o_e] = S * R;
}
OLDC = C;
C = P / R;
S = BB / R;
OLDGAM = GAMMA;
ALPHA = D[I + o_d];
GAMMA = C * (ALPHA - SIGMA) - S * OLDGAM;
D[I + 1 + o_d] = OLDGAM + (ALPHA - GAMMA);
if (C != ZERO)
{
P = (GAMMA * GAMMA) / C;
}
else
{
P = OLDC * BB;
}
}
// *
E[L + o_e] = S * P;
D[L + o_d] = SIGMA + GAMMA;
goto LABEL50;
// *
// * Eigenvalue found.
// *
LABEL90 :;
D[L + o_d] = P;
// *
L += 1;
if (L <= LEND)
{
goto LABEL50;
}
goto LABEL150;
// *
}
else
{
// *
// * QR Iteration
// *
// * Look for small superdiagonal element.
// *
LABEL100 :;
for (M = L; M >= LEND + 1; M += -1)
{
if (Math.Abs(E[M - 1 + o_e]) <= EPS2 * Math.Abs(D[M + o_d] * D[M - 1 + o_d]))
{
goto LABEL120;
}
}
M = LEND;
// *
LABEL120 :;
if (M > LEND)
{
E[M - 1 + o_e] = ZERO;
}
P = D[L + o_d];
if (M == L)
{
goto LABEL140;
}
// *
// * If remaining matrix is 2 by 2, use DLAE2 to compute its
// * eigenvalues.
// *
if (M == L - 1)
{
RTE = Math.Sqrt(E[L - 1 + o_e]);
this._dlae2.Run(D[L + o_d], RTE, D[L - 1 + o_d], ref RT1, ref RT2);
D[L + o_d] = RT1;
D[L - 1 + o_d] = RT2;
E[L - 1 + o_e] = ZERO;
L -= 2;
if (L >= LEND)
{
goto LABEL100;
}
goto LABEL150;
}
// *
if (JTOT == NMAXIT)
{
goto LABEL150;
}
JTOT += 1;
// *
// * Form shift.
// *
RTE = Math.Sqrt(E[L - 1 + o_e]);
SIGMA = (D[L - 1 + o_d] - P) / (TWO * RTE);
R = this._dlapy2.Run(SIGMA, ONE);
SIGMA = P - (RTE / (SIGMA + FortranLib.Sign(R, SIGMA)));
// *
C = ONE;
S = ZERO;
GAMMA = D[M + o_d] - SIGMA;
P = GAMMA * GAMMA;
// *
// * Inner loop
// *
for (I = M; I <= L - 1; I++)
{
BB = E[I + o_e];
R = P + BB;
if (I != M)
{
E[I - 1 + o_e] = S * R;
}
OLDC = C;
C = P / R;
S = BB / R;
OLDGAM = GAMMA;
ALPHA = D[I + 1 + o_d];
GAMMA = C * (ALPHA - SIGMA) - S * OLDGAM;
D[I + o_d] = OLDGAM + (ALPHA - GAMMA);
if (C != ZERO)
{
P = (GAMMA * GAMMA) / C;
}
else
{
P = OLDC * BB;
}
}
// *
E[L - 1 + o_e] = S * P;
D[L + o_d] = SIGMA + GAMMA;
goto LABEL100;
// *
// * Eigenvalue found.
// *
LABEL140 :;
D[L + o_d] = P;
// *
L -= 1;
if (L >= LEND)
{
goto LABEL100;
}
goto LABEL150;
// *
}
// *
// * Undo scaling if necessary
// *
LABEL150 :;
if (ISCALE == 1)
{
this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV + 1
, 1, ref D, LSV + o_d, N, ref INFO);
}
if (ISCALE == 2)
{
this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV + 1
, 1, ref D, LSV + o_d, N, ref INFO);
}
// *
// * Check for no convergence to an eigenvalue after a total
// * of N*MAXIT iterations.
// *
if (JTOT < NMAXIT)
{
goto LABEL10;
}
for (I = 1; I <= N - 1; I++)
{
if (E[I + o_e] != ZERO)
{
INFO += 1;
}
}
goto LABEL180;
// *
// * Sort eigenvalues in increasing order.
// *
LABEL170 :;
this._dlasrt.Run("I", N, ref D, offset_d, ref INFO);
// *
LABEL180 :;
return;
// *
// * End of DSTERF
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLAED9 finds the roots of the secular equation, as defined by the
/// values in D, Z, and RHO, between KSTART and KSTOP. It makes the
/// appropriate calls to DLAED4 and then stores the new matrix of
/// eigenvectors for use in calculating the next level of Z vectors.
///
///</summary>
/// <param name="K">
/// (input) INTEGER
/// The number of terms in the rational function to be solved by
/// DLAED4. K .GE. 0.
///</param>
/// <param name="KSTART">
/// (input) INTEGER
///</param>
/// <param name="KSTOP">
/// (input) INTEGER
/// The updated eigenvalues Lambda(I), KSTART .LE. I .LE. KSTOP
/// are to be computed. 1 .LE. KSTART .LE. KSTOP .LE. K.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of rows and columns in the Q matrix.
/// N .GE. K (delation may result in N .GT. K).
///</param>
/// <param name="D">
/// (output) DOUBLE PRECISION array, dimension (N)
/// D(I) contains the updated eigenvalues
/// for KSTART .LE. I .LE. KSTOP.
///</param>
/// <param name="Q">
/// (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
///</param>
/// <param name="LDQ">
/// (input) INTEGER
/// The leading dimension of the array Q. LDQ .GE. max( 1, N ).
///</param>
/// <param name="RHO">
/// (input) DOUBLE PRECISION
/// The value of the parameter in the rank one update equation.
/// RHO .GE. 0 required.
///</param>
/// <param name="DLAMDA">
/// (input) DOUBLE PRECISION array, dimension (K)
/// The first K elements of this array contain the old roots
/// of the deflated updating problem. These are the poles
/// of the secular equation.
///</param>
/// <param name="W">
/// (input) DOUBLE PRECISION array, dimension (K)
/// The first K elements of this array contain the components
/// of the deflation-adjusted updating vector.
///</param>
/// <param name="S">
/// (output) DOUBLE PRECISION array, dimension (LDS, K)
/// Will contain the eigenvectors of the repaired matrix which
/// will be stored for subsequent Z vector calculation and
/// multiplied by the previously accumulated eigenvectors
/// to update the system.
///</param>
/// <param name="LDS">
/// (input) INTEGER
/// The leading dimension of S. LDS .GE. max( 1, K ).
///</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 = 1, an eigenvalue did not converge
///</param>
public void Run(int K, int KSTART, int KSTOP, int N, ref double[] D, int offset_d, ref double[] Q, int offset_q
, int LDQ, double RHO, ref double[] DLAMDA, int offset_dlamda, ref double[] W, int offset_w, ref double[] S, int offset_s, int LDS
, ref int INFO)
{
#region Variables
int I = 0; int J = 0; double TEMP = 0;
#endregion
#region Implicit Variables
int S_I = 0; int Q_I = 0; int Q_J = 0; int S_J = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_q = -1 - LDQ + offset_q; int o_dlamda = -1 + offset_dlamda;
int o_w = -1 + offset_w; int o_s = -1 - LDS + offset_s;
#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
// * =======
// *
// * DLAED9 finds the roots of the secular equation, as defined by the
// * values in D, Z, and RHO, between KSTART and KSTOP. It makes the
// * appropriate calls to DLAED4 and then stores the new matrix of
// * eigenvectors for use in calculating the next level of Z vectors.
// *
// * Arguments
// * =========
// *
// * K (input) INTEGER
// * The number of terms in the rational function to be solved by
// * DLAED4. K >= 0.
// *
// * KSTART (input) INTEGER
// * KSTOP (input) INTEGER
// * The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
// * are to be computed. 1 <= KSTART <= KSTOP <= K.
// *
// * N (input) INTEGER
// * The number of rows and columns in the Q matrix.
// * N >= K (delation may result in N > K).
// *
// * D (output) DOUBLE PRECISION array, dimension (N)
// * D(I) contains the updated eigenvalues
// * for KSTART <= I <= KSTOP.
// *
// * Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
// *
// * LDQ (input) INTEGER
// * The leading dimension of the array Q. LDQ >= max( 1, N ).
// *
// * RHO (input) DOUBLE PRECISION
// * The value of the parameter in the rank one update equation.
// * RHO >= 0 required.
// *
// * DLAMDA (input) DOUBLE PRECISION array, dimension (K)
// * The first K elements of this array contain the old roots
// * of the deflated updating problem. These are the poles
// * of the secular equation.
// *
// * W (input) DOUBLE PRECISION array, dimension (K)
// * The first K elements of this array contain the components
// * of the deflation-adjusted updating vector.
// *
// * S (output) DOUBLE PRECISION array, dimension (LDS, K)
// * Will contain the eigenvectors of the repaired matrix which
// * will be stored for subsequent Z vector calculation and
// * multiplied by the previously accumulated eigenvectors
// * to update the system.
// *
// * LDS (input) INTEGER
// * The leading dimension of S. LDS >= max( 1, K ).
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = 1, an eigenvalue did not converge
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Jeff Rutter, Computer Science Division, University of California
// * at Berkeley, USA
// *
// * =====================================================================
// *
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
if (K < 0)
{
INFO = -1;
}
else
{
if (KSTART < 1 || KSTART > Math.Max(1, K))
{
INFO = -2;
}
else
{
if (Math.Max(1, KSTOP) < KSTART || KSTOP > Math.Max(1, K))
{
INFO = -3;
}
else
{
if (N < K)
{
INFO = -4;
}
else
{
if (LDQ < Math.Max(1, K))
{
INFO = -7;
}
else
{
if (LDS < Math.Max(1, K))
{
INFO = -12;
}
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DLAED9", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (K == 0)
{
return;
}
// *
// * Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
// * be computed with high relative accuracy (barring over/underflow).
// * This is a problem on machines without a guard digit in
// * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
// * The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
// * which on any of these machines zeros out the bottommost
// * bit of DLAMDA(I) if it is 1; this makes the subsequent
// * subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
// * occurs. On binary machines with a guard digit (almost all
// * machines) it does not change DLAMDA(I) at all. On hexadecimal
// * and decimal machines with a guard digit, it slightly
// * changes the bottommost bits of DLAMDA(I). It does not account
// * for hexadecimal or decimal machines without guard digits
// * (we know of none). We use a subroutine call to compute
// * 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
// * this code.
// *
for (I = 1; I <= N; I++)
{
DLAMDA[I + o_dlamda] = this._dlamc3.Run(DLAMDA[I + o_dlamda], DLAMDA[I + o_dlamda]) - DLAMDA[I + o_dlamda];
}
// *
for (J = KSTART; J <= KSTOP; J++)
{
this._dlaed4.Run(K, J, DLAMDA, offset_dlamda, W, offset_w, ref Q, 1 + J * LDQ + o_q, RHO
, ref D[J + o_d], ref INFO);
// *
// * If the zero finder fails, the computation is terminated.
// *
if (INFO != 0)
{
goto LABEL120;
}
}
// *
if (K == 1 || K == 2)
{
for (I = 1; I <= K; I++)
{
S_I = I * LDS + o_s;
Q_I = I * LDQ + o_q;
for (J = 1; J <= K; J++)
{
S[J + S_I] = Q[J + Q_I];
}
}
goto LABEL120;
}
// *
// * Compute updated W.
// *
this._dcopy.Run(K, W, offset_w, 1, ref S, offset_s, 1);
// *
// * Initialize W(I) = Q(I,I)
// *
this._dcopy.Run(K, Q, offset_q, LDQ + 1, ref W, offset_w, 1);
for (J = 1; J <= K; J++)
{
Q_J = J * LDQ + o_q;
for (I = 1; I <= J - 1; I++)
{
W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda]));
}
Q_J = J * LDQ + o_q;
for (I = J + 1; I <= K; I++)
{
W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda]));
}
}
for (I = 1; I <= K; I++)
{
W[I + o_w] = FortranLib.Sign(Math.Sqrt(-W[I + o_w]), S[I + 1 * LDS + o_s]);
}
// *
// * Compute eigenvectors of the modified rank-1 modification.
// *
for (J = 1; J <= K; J++)
{
Q_J = J * LDQ + o_q;
for (I = 1; I <= K; I++)
{
Q[I + Q_J] = W[I + o_w] / Q[I + Q_J];
}
TEMP = this._dnrm2.Run(K, Q, 1 + J * LDQ + o_q, 1);
S_J = J * LDS + o_s;
Q_J = J * LDQ + o_q;
for (I = 1; I <= K; I++)
{
S[I + S_J] = Q[I + Q_J] / TEMP;
}
}
// *
LABEL120 :;
return;
// *
// * End of DLAED9
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
/// matrix in standard form:
///
/// [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
/// [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
///
/// where either
/// 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
/// 2) AA = DD and BB*CC .LT. 0, so that AA + or - sqrt(BB*CC) are complex
/// conjugate eigenvalues.
///
///</summary>
/// <param name="A">
/// (input/output) DOUBLE PRECISION
///</param>
/// <param name="B">
/// (input/output) DOUBLE PRECISION
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION
/// On entry, the elements of the input matrix.
/// On exit, they are overwritten by the elements of the
/// standardised Schur form.
///</param>
/// <param name="RT1R">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="RT1I">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="RT2R">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="RT2I">
/// (output) DOUBLE PRECISION
/// The real and imaginary parts of the eigenvalues. If the
/// eigenvalues are a complex conjugate pair, RT1I .GT. 0.
///</param>
/// <param name="CS">
/// (output) DOUBLE PRECISION
///</param>
/// <param name="SN">
/// (output) DOUBLE PRECISION
/// Parameters of the rotation matrix.
///</param>
public void Run(ref double A, ref double B, ref double C, ref double D, ref double RT1R, ref double RT1I
, ref double RT2R, ref double RT2I, ref double CS, ref double SN)
{
#region Variables
double AA = 0; double BB = 0; double BCMAX = 0; double BCMIS = 0; double CC = 0; double CS1 = 0; double DD = 0;
double EPS = 0; double P = 0; double SAB = 0; double SAC = 0; double SCALE = 0; double SIGMA = 0; double SN1 = 0;
double TAU = 0; double TEMP = 0; double Z = 0;
#endregion
#region Prolog
// *
// * -- LAPACK driver routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
// * matrix in standard form:
// *
// * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
// * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
// *
// * where either
// * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
// * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
// * conjugate eigenvalues.
// *
// * Arguments
// * =========
// *
// * A (input/output) DOUBLE PRECISION
// * B (input/output) DOUBLE PRECISION
// * C (input/output) DOUBLE PRECISION
// * D (input/output) DOUBLE PRECISION
// * On entry, the elements of the input matrix.
// * On exit, they are overwritten by the elements of the
// * standardised Schur form.
// *
// * RT1R (output) DOUBLE PRECISION
// * RT1I (output) DOUBLE PRECISION
// * RT2R (output) DOUBLE PRECISION
// * RT2I (output) DOUBLE PRECISION
// * The real and imaginary parts of the eigenvalues. If the
// * eigenvalues are a complex conjugate pair, RT1I > 0.
// *
// * CS (output) DOUBLE PRECISION
// * SN (output) DOUBLE PRECISION
// * Parameters of the rotation matrix.
// *
// * Further Details
// * ===============
// *
// * Modified by V. Sima, Research Institute for Informatics, Bucharest,
// * Romania, to reduce the risk of cancellation errors,
// * when computing real eigenvalues, and to ensure, if possible, that
// * abs(RT1R) >= abs(RT2R).
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, MAX, MIN, SIGN, SQRT;
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
EPS = this._dlamch.Run("P");
if (C == ZERO)
{
CS = ONE;
SN = ZERO;
goto LABEL10;
// *
}
else
{
if (B == ZERO)
{
// *
// * Swap rows and columns
// *
CS = ZERO;
SN = ONE;
TEMP = D;
D = A;
A = TEMP;
B = -C;
C = ZERO;
goto LABEL10;
}
else
{
if ((A - D) == ZERO && FortranLib.Sign(ONE, B) != FortranLib.Sign(ONE, C))
{
CS = ONE;
SN = ZERO;
goto LABEL10;
}
else
{
// *
TEMP = A - D;
P = HALF * TEMP;
BCMAX = Math.Max(Math.Abs(B), Math.Abs(C));
BCMIS = Math.Min(Math.Abs(B), Math.Abs(C)) * FortranLib.Sign(ONE, B) * FortranLib.Sign(ONE, C);
SCALE = Math.Max(Math.Abs(P), BCMAX);
Z = (P / SCALE) * P + (BCMAX / SCALE) * BCMIS;
// *
// * If Z is of the order of the machine accuracy, postpone the
// * decision on the nature of eigenvalues
// *
if (Z >= MULTPL * EPS)
{
// *
// * Real eigenvalues. Compute A and D.
// *
Z = P + FortranLib.Sign(Math.Sqrt(SCALE) * Math.Sqrt(Z), P);
A = D + Z;
D += -(BCMAX / Z) * BCMIS;
// *
// * Compute B and the rotation matrix
// *
TAU = this._dlapy2.Run(C, Z);
CS = Z / TAU;
SN = C / TAU;
B -= C;
C = ZERO;
}
else
{
// *
// * Complex eigenvalues, or real (almost) equal eigenvalues.
// * Make diagonal elements equal.
// *
SIGMA = B + C;
TAU = this._dlapy2.Run(SIGMA, TEMP);
CS = Math.Sqrt(HALF * (ONE + Math.Abs(SIGMA) / TAU));
SN = -(P / (TAU * CS)) * FortranLib.Sign(ONE, SIGMA);
// *
// * Compute [ AA BB ] = [ A B ] [ CS -SN ]
// * [ CC DD ] [ C D ] [ SN CS ]
// *
AA = A * CS + B * SN;
BB = -A * SN + B * CS;
CC = C * CS + D * SN;
DD = -C * SN + D * CS;
// *
// * Compute [ A B ] = [ CS SN ] [ AA BB ]
// * [ C D ] [-SN CS ] [ CC DD ]
// *
A = AA * CS + CC * SN;
B = BB * CS + DD * SN;
C = -AA * SN + CC * CS;
D = -BB * SN + DD * CS;
// *
TEMP = HALF * (A + D);
A = TEMP;
D = TEMP;
// *
if (C != ZERO)
{
if (B != ZERO)
{
if (FortranLib.Sign(ONE, B) == FortranLib.Sign(ONE, C))
{
// *
// * Real eigenvalues: reduce to upper triangular form
// *
SAB = Math.Sqrt(Math.Abs(B));
SAC = Math.Sqrt(Math.Abs(C));
P = FortranLib.Sign(SAB * SAC, C);
TAU = ONE / Math.Sqrt(Math.Abs(B + C));
A = TEMP + P;
D = TEMP - P;
B -= C;
C = ZERO;
CS1 = SAB * TAU;
SN1 = SAC * TAU;
TEMP = CS * CS1 - SN * SN1;
SN = CS * SN1 + SN * CS1;
CS = TEMP;
}
}
else
{
B = -C;
C = ZERO;
TEMP = CS;
CS = -SN;
SN = TEMP;
}
}
}
// *
}
}
}
// *
LABEL10 :;
// *
// * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
// *
RT1R = A;
RT2R = D;
if (C == ZERO)
{
RT1I = ZERO;
RT2I = ZERO;
}
else
{
RT1I = Math.Sqrt(Math.Abs(B)) * Math.Sqrt(Math.Abs(C));
RT2I = -RT1I;
}
return;
// *
// * End of DLANV2
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DBDSDC computes the singular value decomposition (SVD) of a real
/// N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
/// using a divide and conquer method, where S is a diagonal matrix
/// with non-negative diagonal elements (the singular values of B), and
/// U and VT are orthogonal matrices of left and right singular vectors,
/// respectively. DBDSDC can be used to compute all singular values,
/// and optionally, singular vectors or singular vectors in compact form.
///
/// This code makes very mild assumptions about floating point
/// arithmetic. It will work on machines with a guard digit in
/// add/subtract, or on those binary machines without guard digits
/// which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
/// It could conceivably fail on hexadecimal or decimal machines
/// without guard digits, but we know of none. See DLASD3 for details.
///
/// The code currently calls DLASDQ if singular values only are desired.
/// However, it can be slightly modified to compute singular values
/// using the divide and conquer method.
///
///</summary>
/// <param name="UPLO">
/// (input) CHARACTER*1
/// = 'U': B is upper bidiagonal.
/// = 'L': B is lower bidiagonal.
///</param>
/// <param name="COMPQ">
/// (input) CHARACTER*1
/// Specifies whether singular vectors are to be computed
/// as follows:
/// = 'N': Compute singular values only;
/// = 'P': Compute singular values and compute singular
/// vectors in compact form;
/// = 'I': Compute singular values and singular vectors.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix B. N .GE. 0.
///</param>
/// <param name="D">
/// (input/output) DOUBLE PRECISION array, dimension (N)
/// On entry, the n diagonal elements of the bidiagonal matrix B.
/// On exit, if INFO=0, the singular values of B.
///</param>
/// <param name="E">
/// (input/output) DOUBLE PRECISION array, dimension (N-1)
/// On entry, the elements of E contain the offdiagonal
/// elements of the bidiagonal matrix whose SVD is desired.
/// On exit, E has been destroyed.
///</param>
/// <param name="U">
/// (output) DOUBLE PRECISION array, dimension (LDU,N)
/// If COMPQ = 'I', then:
/// On exit, if INFO = 0, U contains the left singular vectors
/// of the bidiagonal matrix.
/// For other values of COMPQ, U is not referenced.
///</param>
/// <param name="LDU">
/// (input) INTEGER
/// The leading dimension of the array U. LDU .GE. 1.
/// If singular vectors are desired, then LDU .GE. max( 1, N ).
///</param>
/// <param name="VT">
/// (output) DOUBLE PRECISION array, dimension (LDVT,N)
/// If COMPQ = 'I', then:
/// On exit, if INFO = 0, VT' contains the right singular
/// vectors of the bidiagonal matrix.
/// For other values of COMPQ, VT is not referenced.
///</param>
/// <param name="LDVT">
/// (input) INTEGER
/// The leading dimension of the array VT. LDVT .GE. 1.
/// If singular vectors are desired, then LDVT .GE. max( 1, N ).
///</param>
/// <param name="Q">
/// (output) DOUBLE PRECISION array, dimension (LDQ)
/// If COMPQ = 'P', then:
/// On exit, if INFO = 0, Q and IQ contain the left
/// and right singular vectors in a compact form,
/// requiring O(N log N) space instead of 2*N**2.
/// In particular, Q contains all the DOUBLE PRECISION data in
/// LDQ .GE. N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
/// words of memory, where SMLSIZ is returned by ILAENV and
/// is equal to the maximum size of the subproblems at the
/// bottom of the computation tree (usually about 25).
/// For other values of COMPQ, Q is not referenced.
///</param>
/// <param name="IQ">
/// (output) INTEGER array, dimension (LDIQ)
/// If COMPQ = 'P', then:
/// On exit, if INFO = 0, Q and IQ contain the left
/// and right singular vectors in a compact form,
/// requiring O(N log N) space instead of 2*N**2.
/// In particular, IQ contains all INTEGER data in
/// LDIQ .GE. N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
/// words of memory, where SMLSIZ is returned by ILAENV and
/// is equal to the maximum size of the subproblems at the
/// bottom of the computation tree (usually about 25).
/// For other values of COMPQ, IQ is not referenced.
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// If COMPQ = 'N' then LWORK .GE. (4 * N).
/// If COMPQ = 'P' then LWORK .GE. (6 * N).
/// If COMPQ = 'I' then LWORK .GE. (3 * N**2 + 4 * N).
///</param>
/// <param name="IWORK">
/// (workspace) INTEGER array, dimension (8*N)
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit.
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value.
/// .GT. 0: The algorithm failed to compute an singular value.
/// The update process of divide and conquer failed.
///</param>
public void Run(string UPLO, string COMPQ, int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref double[] U, int offset_u
, int LDU, ref double[] VT, int offset_vt, int LDVT, ref double[] Q, int offset_q, ref int[] IQ, int offset_iq, ref double[] WORK, int offset_work
, ref int[] IWORK, int offset_iwork, ref int INFO)
{
#region Variables
int DIFL = 0; int DIFR = 0; int GIVCOL = 0; int GIVNUM = 0; int GIVPTR = 0; int I = 0; int IC = 0; int ICOMPQ = 0;
int IERR = 0; int II = 0; int IS = 0; int IU = 0; int IUPLO = 0; int IVT = 0; int J = 0; int K = 0; int KK = 0;
int MLVL = 0; int NM1 = 0; int NSIZE = 0; int PERM = 0; int POLES = 0; int QSTART = 0; int SMLSIZ = 0; int SMLSZP = 0;
int SQRE = 0; int START = 0; int WSTART = 0; int Z = 0; double CS = 0; double EPS = 0; double ORGNRM = 0; double P = 0;
double R = 0; double SN = 0;
#endregion
#region Array Index Correction
int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_u = -1 - LDU + offset_u; int o_vt = -1 - LDVT + offset_vt;
int o_q = -1 + offset_q; int o_iq = -1 + offset_iq; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork;
#endregion
#region Strings
UPLO = UPLO.Substring(0, 1); COMPQ = COMPQ.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
// * =======
// *
// * DBDSDC computes the singular value decomposition (SVD) of a real
// * N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
// * using a divide and conquer method, where S is a diagonal matrix
// * with non-negative diagonal elements (the singular values of B), and
// * U and VT are orthogonal matrices of left and right singular vectors,
// * respectively. DBDSDC can be used to compute all singular values,
// * and optionally, singular vectors or singular vectors in compact form.
// *
// * This code makes very mild assumptions about floating point
// * arithmetic. It will work on machines with a guard digit in
// * add/subtract, or on those binary machines without guard digits
// * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
// * It could conceivably fail on hexadecimal or decimal machines
// * without guard digits, but we know of none. See DLASD3 for details.
// *
// * The code currently calls DLASDQ if singular values only are desired.
// * However, it can be slightly modified to compute singular values
// * using the divide and conquer method.
// *
// * Arguments
// * =========
// *
// * UPLO (input) CHARACTER*1
// * = 'U': B is upper bidiagonal.
// * = 'L': B is lower bidiagonal.
// *
// * COMPQ (input) CHARACTER*1
// * Specifies whether singular vectors are to be computed
// * as follows:
// * = 'N': Compute singular values only;
// * = 'P': Compute singular values and compute singular
// * vectors in compact form;
// * = 'I': Compute singular values and singular vectors.
// *
// * N (input) INTEGER
// * The order of the matrix B. N >= 0.
// *
// * D (input/output) DOUBLE PRECISION array, dimension (N)
// * On entry, the n diagonal elements of the bidiagonal matrix B.
// * On exit, if INFO=0, the singular values of B.
// *
// * E (input/output) DOUBLE PRECISION array, dimension (N-1)
// * On entry, the elements of E contain the offdiagonal
// * elements of the bidiagonal matrix whose SVD is desired.
// * On exit, E has been destroyed.
// *
// * U (output) DOUBLE PRECISION array, dimension (LDU,N)
// * If COMPQ = 'I', then:
// * On exit, if INFO = 0, U contains the left singular vectors
// * of the bidiagonal matrix.
// * For other values of COMPQ, U is not referenced.
// *
// * LDU (input) INTEGER
// * The leading dimension of the array U. LDU >= 1.
// * If singular vectors are desired, then LDU >= max( 1, N ).
// *
// * VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
// * If COMPQ = 'I', then:
// * On exit, if INFO = 0, VT' contains the right singular
// * vectors of the bidiagonal matrix.
// * For other values of COMPQ, VT is not referenced.
// *
// * LDVT (input) INTEGER
// * The leading dimension of the array VT. LDVT >= 1.
// * If singular vectors are desired, then LDVT >= max( 1, N ).
// *
// * Q (output) DOUBLE PRECISION array, dimension (LDQ)
// * If COMPQ = 'P', then:
// * On exit, if INFO = 0, Q and IQ contain the left
// * and right singular vectors in a compact form,
// * requiring O(N log N) space instead of 2*N**2.
// * In particular, Q contains all the DOUBLE PRECISION data in
// * LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
// * words of memory, where SMLSIZ is returned by ILAENV and
// * is equal to the maximum size of the subproblems at the
// * bottom of the computation tree (usually about 25).
// * For other values of COMPQ, Q is not referenced.
// *
// * IQ (output) INTEGER array, dimension (LDIQ)
// * If COMPQ = 'P', then:
// * On exit, if INFO = 0, Q and IQ contain the left
// * and right singular vectors in a compact form,
// * requiring O(N log N) space instead of 2*N**2.
// * In particular, IQ contains all INTEGER data in
// * LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
// * words of memory, where SMLSIZ is returned by ILAENV and
// * is equal to the maximum size of the subproblems at the
// * bottom of the computation tree (usually about 25).
// * For other values of COMPQ, IQ is not referenced.
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * If COMPQ = 'N' then LWORK >= (4 * N).
// * If COMPQ = 'P' then LWORK >= (6 * N).
// * If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
// *
// * IWORK (workspace) INTEGER array, dimension (8*N)
// *
// * INFO (output) INTEGER
// * = 0: successful exit.
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: The algorithm failed to compute an singular value.
// * The update process of divide and conquer failed.
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * Ming Gu and Huan Ren, Computer Science Division, University of
// * California at Berkeley, USA
// *
// * =====================================================================
// * Changed dimension statement in comment describing E from (N) to
// * (N-1). Sven, 17 Feb 05.
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, INT, LOG, SIGN;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
// *
IUPLO = 0;
if (this._lsame.Run(UPLO, "U"))
{
IUPLO = 1;
}
if (this._lsame.Run(UPLO, "L"))
{
IUPLO = 2;
}
if (this._lsame.Run(COMPQ, "N"))
{
ICOMPQ = 0;
}
else
{
if (this._lsame.Run(COMPQ, "P"))
{
ICOMPQ = 1;
}
else
{
if (this._lsame.Run(COMPQ, "I"))
{
ICOMPQ = 2;
}
else
{
ICOMPQ = -1;
}
}
}
if (IUPLO == 0)
{
INFO = -1;
}
else
{
if (ICOMPQ < 0)
{
INFO = -2;
}
else
{
if (N < 0)
{
INFO = -3;
}
else
{
if ((LDU < 1) || ((ICOMPQ == 2) && (LDU < N)))
{
INFO = -7;
}
else
{
if ((LDVT < 1) || ((ICOMPQ == 2) && (LDVT < N)))
{
INFO = -9;
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DBDSDC", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (N == 0)
{
return;
}
SMLSIZ = this._ilaenv.Run(9, "DBDSDC", " ", 0, 0, 0, 0);
if (N == 1)
{
if (ICOMPQ == 1)
{
Q[1 + o_q] = FortranLib.Sign(ONE, D[1 + o_d]);
Q[1 + SMLSIZ * N + o_q] = ONE;
}
else
{
if (ICOMPQ == 2)
{
U[1 + 1 * LDU + o_u] = FortranLib.Sign(ONE, D[1 + o_d]);
VT[1 + 1 * LDVT + o_vt] = ONE;
}
}
D[1 + o_d] = Math.Abs(D[1 + o_d]);
return;
}
NM1 = N - 1;
// *
// * If matrix lower bidiagonal, rotate to be upper bidiagonal
// * by applying Givens rotations on the left
// *
WSTART = 1;
QSTART = 3;
if (ICOMPQ == 1)
{
this._dcopy.Run(N, D, offset_d, 1, ref Q, 1 + o_q, 1);
this._dcopy.Run(N - 1, E, offset_e, 1, ref Q, N + 1 + o_q, 1);
}
if (IUPLO == 2)
{
QSTART = 5;
WSTART = 2 * N - 1;
for (I = 1; I <= N - 1; I++)
{
this._dlartg.Run(D[I + o_d], E[I + o_e], ref CS, ref SN, ref R);
D[I + o_d] = R;
E[I + o_e] = SN * D[I + 1 + o_d];
D[I + 1 + o_d] *= CS;
if (ICOMPQ == 1)
{
Q[I + 2 * N + o_q] = CS;
Q[I + 3 * N + o_q] = SN;
}
else
{
if (ICOMPQ == 2)
{
WORK[I + o_work] = CS;
WORK[NM1 + I + o_work] = -SN;
}
}
}
}
// *
// * If ICOMPQ = 0, use DLASDQ to compute the singular values.
// *
if (ICOMPQ == 0)
{
this._dlasdq.Run("U", 0, N, 0, 0, 0
, ref D, offset_d, ref E, offset_e, ref VT, offset_vt, LDVT, ref U, offset_u, LDU
, ref U, offset_u, LDU, ref WORK, WSTART + o_work, ref INFO);
goto LABEL40;
}
// *
// * If N is smaller than the minimum divide size SMLSIZ, then solve
// * the problem with another solver.
// *
if (N <= SMLSIZ)
{
if (ICOMPQ == 2)
{
this._dlaset.Run("A", N, N, ZERO, ONE, ref U, offset_u
, LDU);
this._dlaset.Run("A", N, N, ZERO, ONE, ref VT, offset_vt
, LDVT);
this._dlasdq.Run("U", 0, N, N, N, 0
, ref D, offset_d, ref E, offset_e, ref VT, offset_vt, LDVT, ref U, offset_u, LDU
, ref U, offset_u, LDU, ref WORK, WSTART + o_work, ref INFO);
}
else
{
if (ICOMPQ == 1)
{
IU = 1;
IVT = IU + N;
this._dlaset.Run("A", N, N, ZERO, ONE, ref Q, IU + (QSTART - 1) * N + o_q
, N);
this._dlaset.Run("A", N, N, ZERO, ONE, ref Q, IVT + (QSTART - 1) * N + o_q
, N);
this._dlasdq.Run("U", 0, N, N, N, 0
, ref D, offset_d, ref E, offset_e, ref Q, IVT + (QSTART - 1) * N + o_q, N, ref Q, IU + (QSTART - 1) * N + o_q, N
, ref Q, IU + (QSTART - 1) * N + o_q, N, ref WORK, WSTART + o_work, ref INFO);
}
}
goto LABEL40;
}
// *
if (ICOMPQ == 2)
{
this._dlaset.Run("A", N, N, ZERO, ONE, ref U, offset_u
, LDU);
this._dlaset.Run("A", N, N, ZERO, ONE, ref VT, offset_vt
, LDVT);
}
// *
// * Scale.
// *
ORGNRM = this._dlanst.Run("M", N, D, offset_d, E, offset_e);
if (ORGNRM == ZERO)
{
return;
}
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N
, 1, ref D, offset_d, N, ref IERR);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, NM1
, 1, ref E, offset_e, NM1, ref IERR);
// *
EPS = this._dlamch.Run("Epsilon");
// *
MLVL = Convert.ToInt32(Math.Truncate(Math.Log(Convert.ToDouble(N) / Convert.ToDouble(SMLSIZ + 1)) / Math.Log(TWO))) + 1;
SMLSZP = SMLSIZ + 1;
// *
if (ICOMPQ == 1)
{
IU = 1;
IVT = 1 + SMLSIZ;
DIFL = IVT + SMLSZP;
DIFR = DIFL + MLVL;
Z = DIFR + MLVL * 2;
IC = Z + MLVL;
IS = IC + 1;
POLES = IS + 1;
GIVNUM = POLES + 2 * MLVL;
// *
K = 1;
GIVPTR = 2;
PERM = 3;
GIVCOL = PERM + MLVL;
}
// *
for (I = 1; I <= N; I++)
{
if (Math.Abs(D[I + o_d]) < EPS)
{
D[I + o_d] = FortranLib.Sign(EPS, D[I + o_d]);
}
}
// *
START = 1;
SQRE = 0;
// *
for (I = 1; I <= NM1; I++)
{
if ((Math.Abs(E[I + o_e]) < EPS) || (I == NM1))
{
// *
// * Subproblem found. First determine its size and then
// * apply divide and conquer on it.
// *
if (I < NM1)
{
// *
// * A subproblem with E(I) small for I < NM1.
// *
NSIZE = I - START + 1;
}
else
{
if (Math.Abs(E[I + o_e]) >= EPS)
{
// *
// * A subproblem with E(NM1) not too small but I = NM1.
// *
NSIZE = N - START + 1;
}
else
{
// *
// * A subproblem with E(NM1) small. This implies an
// * 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
// * first.
// *
NSIZE = I - START + 1;
if (ICOMPQ == 2)
{
U[N + N * LDU + o_u] = FortranLib.Sign(ONE, D[N + o_d]);
VT[N + N * LDVT + o_vt] = ONE;
}
else
{
if (ICOMPQ == 1)
{
Q[N + (QSTART - 1) * N + o_q] = FortranLib.Sign(ONE, D[N + o_d]);
Q[N + (SMLSIZ + QSTART - 1) * N + o_q] = ONE;
}
}
D[N + o_d] = Math.Abs(D[N + o_d]);
}
}
if (ICOMPQ == 2)
{
this._dlasd0.Run(NSIZE, SQRE, ref D, START + o_d, ref E, START + o_e, ref U, START + START * LDU + o_u, LDU
, ref VT, START + START * LDVT + o_vt, LDVT, SMLSIZ, ref IWORK, offset_iwork, ref WORK, WSTART + o_work, ref INFO);
}
else
{
this._dlasda.Run(ICOMPQ, SMLSIZ, NSIZE, SQRE, ref D, START + o_d, ref E, START + o_e
, ref Q, START + (IU + QSTART - 2) * N + o_q, N, ref Q, START + (IVT + QSTART - 2) * N + o_q, ref IQ, START + K * N + o_iq, ref Q, START + (DIFL + QSTART - 2) * N + o_q, ref Q, START + (DIFR + QSTART - 2) * N + o_q
, ref Q, START + (Z + QSTART - 2) * N + o_q, ref Q, START + (POLES + QSTART - 2) * N + o_q, ref IQ, START + GIVPTR * N + o_iq, ref IQ, START + GIVCOL * N + o_iq, N, ref IQ, START + PERM * N + o_iq
, ref Q, START + (GIVNUM + QSTART - 2) * N + o_q, ref Q, START + (IC + QSTART - 2) * N + o_q, ref Q, START + (IS + QSTART - 2) * N + o_q, ref WORK, WSTART + o_work, ref IWORK, offset_iwork, ref INFO);
if (INFO != 0)
{
return;
}
}
START = I + 1;
}
}
// *
// * Unscale
// *
this._dlascl.Run("G", 0, 0, ONE, ORGNRM, N
, 1, ref D, offset_d, N, ref IERR);
LABEL40 :;
// *
// * Use Selection Sort to minimize swaps of singular vectors
// *
for (II = 2; II <= N; II++)
{
I = II - 1;
KK = I;
P = D[I + o_d];
for (J = II; J <= N; J++)
{
if (D[J + o_d] > P)
{
KK = J;
P = D[J + o_d];
}
}
if (KK != I)
{
D[KK + o_d] = D[I + o_d];
D[I + o_d] = P;
if (ICOMPQ == 1)
{
IQ[I + o_iq] = KK;
}
else
{
if (ICOMPQ == 2)
{
this._dswap.Run(N, ref U, 1 + I * LDU + o_u, 1, ref U, 1 + KK * LDU + o_u, 1);
this._dswap.Run(N, ref VT, I + 1 * LDVT + o_vt, LDVT, ref VT, KK + 1 * LDVT + o_vt, LDVT);
}
}
}
else
{
if (ICOMPQ == 1)
{
IQ[I + o_iq] = I;
}
}
}
// *
// * If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
// *
if (ICOMPQ == 1)
{
if (IUPLO == 1)
{
IQ[N + o_iq] = 1;
}
else
{
IQ[N + o_iq] = 0;
}
}
// *
// * If B is lower bidiagonal, update U by those Givens rotations
// * which rotated B to be upper bidiagonal
// *
if ((IUPLO == 2) && (ICOMPQ == 2))
{
this._dlasr.Run("L", "V", "B", N, N, WORK, 1 + o_work
, WORK, N + o_work, ref U, offset_u, LDU);
}
// *
return;
// *
// * End of DBDSDC
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DLARFG generates a real elementary reflector H of order n, such
/// that
///
/// H * ( alpha ) = ( beta ), H' * H = I.
/// ( x ) ( 0 )
///
/// where alpha and beta are scalars, and x is an (n-1)-element real
/// vector. H is represented in the form
///
/// H = I - tau * ( 1 ) * ( 1 v' ) ,
/// ( v )
///
/// where tau is a real scalar and v is a real (n-1)-element
/// vector.
///
/// If the elements of x are all zero, then tau = 0 and H is taken to be
/// the unit matrix.
///
/// Otherwise 1 .LE. tau .LE. 2.
///
///</summary>
/// <param name="N">
/// (input) INTEGER
/// The order of the elementary reflector.
///</param>
/// <param name="ALPHA">
/// (input/output) DOUBLE PRECISION
/// On entry, the value alpha.
/// On exit, it is overwritten with the value beta.
///</param>
/// <param name="X">
/// (input/output) DOUBLE PRECISION array, dimension
/// (1+(N-2)*abs(INCX))
/// On entry, the vector x.
/// On exit, it is overwritten with the vector v.
///</param>
/// <param name="INCX">
/// (input) INTEGER
/// The increment between elements of X. INCX .GT. 0.
///</param>
/// <param name="TAU">
/// (output) DOUBLE PRECISION
/// The value tau.
///</param>
public void Run(int N, ref double ALPHA, ref double[] X, int offset_x, int INCX, ref double TAU)
{
#region Variables
int J = 0; int KNT = 0; double BETA = 0; double RSAFMN = 0; double SAFMIN = 0; double XNORM = 0;
#endregion
#region Array Index Correction
int o_x = -1 + offset_x;
#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
// * =======
// *
// * DLARFG generates a real elementary reflector H of order n, such
// * that
// *
// * H * ( alpha ) = ( beta ), H' * H = I.
// * ( x ) ( 0 )
// *
// * where alpha and beta are scalars, and x is an (n-1)-element real
// * vector. H is represented in the form
// *
// * H = I - tau * ( 1 ) * ( 1 v' ) ,
// * ( v )
// *
// * where tau is a real scalar and v is a real (n-1)-element
// * vector.
// *
// * If the elements of x are all zero, then tau = 0 and H is taken to be
// * the unit matrix.
// *
// * Otherwise 1 <= tau <= 2.
// *
// * Arguments
// * =========
// *
// * N (input) INTEGER
// * The order of the elementary reflector.
// *
// * ALPHA (input/output) DOUBLE PRECISION
// * On entry, the value alpha.
// * On exit, it is overwritten with the value beta.
// *
// * X (input/output) DOUBLE PRECISION array, dimension
// * (1+(N-2)*abs(INCX))
// * On entry, the vector x.
// * On exit, it is overwritten with the vector v.
// *
// * INCX (input) INTEGER
// * The increment between elements of X. INCX > 0.
// *
// * TAU (output) DOUBLE PRECISION
// * The value tau.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, SIGN;
// * ..
// * .. External Subroutines ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
if (N <= 1)
{
TAU = ZERO;
return;
}
// *
XNORM = this._dnrm2.Run(N - 1, X, offset_x, INCX);
// *
if (XNORM == ZERO)
{
// *
// * H = I
// *
TAU = ZERO;
}
else
{
// *
// * general case
// *
BETA = -FortranLib.Sign(this._dlapy2.Run(ALPHA, XNORM), ALPHA);
SAFMIN = this._dlamch.Run("S") / this._dlamch.Run("E");
if (Math.Abs(BETA) < SAFMIN)
{
// *
// * XNORM, BETA may be inaccurate; scale X and recompute them
// *
RSAFMN = ONE / SAFMIN;
KNT = 0;
LABEL10 :;
KNT += 1;
this._dscal.Run(N - 1, RSAFMN, ref X, offset_x, INCX);
BETA *= RSAFMN;
ALPHA *= RSAFMN;
if (Math.Abs(BETA) < SAFMIN)
{
goto LABEL10;
}
// *
// * New BETA is at most 1, at least SAFMIN
// *
XNORM = this._dnrm2.Run(N - 1, X, offset_x, INCX);
BETA = -FortranLib.Sign(this._dlapy2.Run(ALPHA, XNORM), ALPHA);
TAU = (BETA - ALPHA) / BETA;
this._dscal.Run(N - 1, ONE / (ALPHA - BETA), ref X, offset_x, INCX);
// *
// * If ALPHA is subnormal, it may lose relative accuracy
// *
ALPHA = BETA;
for (J = 1; J <= KNT; J++)
{
ALPHA *= SAFMIN;
}
}
else
{
TAU = (BETA - ALPHA) / BETA;
this._dscal.Run(N - 1, ONE / (ALPHA - BETA), ref X, offset_x, INCX);
ALPHA = BETA;
}
}
// *
return;
// *
// * End of DLARFG
// *
#endregion
}