static void Main(string[] args)
{
try
{
FortranLib.ProgressUpdateAction updateProgress = delegate(ref int p)
{
Console.WriteLine("Progress: " + p + "%");
};
FortranLib.DoWork(ref updateProgress);
}
catch (Exception ex)
{
Console.WriteLine(ex);
}
}
/// <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
}
public void Run(int N, double[] X, int offset_x, double F, double[] G, int offset_g, int IPRINT, int ITFILE
, int ITER, int NFGV, int NACT, double SBGNRM, int NINT, ref BFGSWord WORD
, int IWORD, int IBACK, double STP, double XSTEP)
{
#region Variables
int I = 0; int IMOD = 0;
#endregion
#region Array Index Correction
int o_x = -1 + offset_x; int o_g = -1 + offset_g;
#endregion
#region Prolog
// c ************
// c
// c Subroutine prn2lb
// c
// c This subroutine prints out new information after a successful
// c line search.
// c
// c
// c * * *
// c
// c NEOS, November 1994. (Latest revision June 1996.)
// c Optimization Technology Center.
// c Argonne National Laboratory and Northwestern University.
// c Written by
// c Ciyou Zhu
// c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
// c
// c
// c ************
// c 'word' records the status of subspace solutions.
#endregion
#region Body
if (IWORD == 0)
{
// c the subspace minimization converged.
WORD = BFGSWord.con;
}
else
{
if (IWORD == 1)
{
// c the subspace minimization stopped at a bound.
WORD = BFGSWord.bnd;
}
else
{
if (IWORD == 5)
{
// c the truncated Newton step has been used.
WORD = BFGSWord.tnt;
}
else
{
WORD = BFGSWord.aaa;
}
}
}
if (IPRINT >= 99)
{
//ERROR-ERROR WRITE (6,*) 'LINE SEARCH',IBACK,' times; norm of step = ',XSTEP;
//ERROR-ERROR WRITE (6,2001) ITER,F,SBGNRM;
if (IPRINT > 100)
{
//ERROR-ERROR WRITE (6,1004) 'X =',(X(I), I = 1, N);
//ERROR-ERROR WRITE (6,1004) 'G =',(G(I), I = 1, N);
}
}
else
{
if (IPRINT > 0)
{
IMOD = FortranLib.Mod(ITER, IPRINT);
if (IMOD == 0)
{
; //ERROR-ERRORWRITE(6,2001)ITER,F,SBGNRM
}
}
}
if (IPRINT >= 1)
{
; //ERROR-ERRORWRITE(ITFILE,3001)ITER,NFGV,NINT,NACT,WORD,IBACK,STP,XSTEP,SBGNRM,F
}
return;
#endregion
}
/// <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
/// =======
///
/// DORMRZ overwrites the general real M-by-N matrix C with
///
/// SIDE = 'L' SIDE = 'R'
/// TRANS = 'N': Q * C C * Q
/// TRANS = 'T': Q**T * C C * Q**T
///
/// where Q is a real orthogonal matrix defined as the product of k
/// elementary reflectors
///
/// Q = H(1) H(2) . . . H(k)
///
/// as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
/// if SIDE = 'R'.
///
///</summary>
/// <param name="SIDE">
/// = 'L' SIDE = 'R'
///</param>
/// <param name="TRANS">
/// (input) CHARACTER*1
/// = 'N': No transpose, apply Q;
/// = 'T': Transpose, apply Q**T.
///</param>
/// <param name="M">
/// (input) INTEGER
/// The number of rows of the matrix C. M .GE. 0.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The number of columns of the matrix C. N .GE. 0.
///</param>
/// <param name="K">
/// (input) INTEGER
/// The number of elementary reflectors whose product defines
/// the matrix Q.
/// If SIDE = 'L', M .GE. K .GE. 0;
/// if SIDE = 'R', N .GE. K .GE. 0.
///</param>
/// <param name="L">
/// (input) INTEGER
/// The number of columns of the matrix A containing
/// the meaningful part of the Householder reflectors.
/// If SIDE = 'L', M .GE. L .GE. 0, if SIDE = 'R', N .GE. L .GE. 0.
///</param>
/// <param name="A">
/// (input) DOUBLE PRECISION array, dimension
/// (LDA,M) if SIDE = 'L',
/// (LDA,N) if SIDE = 'R'
/// The i-th row must contain the vector which defines the
/// elementary reflector H(i), for i = 1,2,...,k, as returned by
/// DTZRZF in the last k rows of its array argument A.
/// A is modified by the routine but restored on exit.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,K).
///</param>
/// <param name="TAU">
/// (input) DOUBLE PRECISION array, dimension (K)
/// TAU(i) must contain the scalar factor of the elementary
/// reflector H(i), as returned by DTZRZF.
///</param>
/// <param name="C">
/// (input/output) DOUBLE PRECISION array, dimension (LDC,N)
/// On entry, the M-by-N matrix C.
/// On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
///</param>
/// <param name="LDC">
/// (input) INTEGER
/// The leading dimension of the array C. LDC .GE. max(1,M).
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK.
/// If SIDE = 'L', LWORK .GE. max(1,N);
/// if SIDE = 'R', LWORK .GE. max(1,M).
/// For optimum performance LWORK .GE. N*NB if SIDE = 'L', and
/// LWORK .GE. M*NB if SIDE = 'R', where NB is the optimal
/// blocksize.
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
///</param>
public void Run(string SIDE, string TRANS, int M, int N, int K, int L
, double[] A, int offset_a, int LDA, double[] TAU, int offset_tau, ref double[] C, int offset_c, int LDC, ref double[] WORK, int offset_work
, int LWORK, ref int INFO)
{
#region Variables
bool LEFT = false; bool LQUERY = false; bool NOTRAN = false; string TRANST = new string(' ', 1); int I = 0;
int I1 = 0; int I2 = 0; int I3 = 0; int IB = 0; int IC = 0; int IINFO = 0; int IWS = 0; int JA = 0; int JC = 0;
int LDWORK = 0; int LWKOPT = 0; int MI = 0; int NB = 0; int NBMIN = 0; int NI = 0; int NQ = 0; int NW = 0;
int offset_t = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_tau = -1 + offset_tau; int o_c = -1 - LDC + offset_c;
int o_work = -1 + offset_work;
#endregion
#region Strings
SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.1.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * January 2007
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DORMRZ overwrites the general real M-by-N matrix C with
// *
// * SIDE = 'L' SIDE = 'R'
// * TRANS = 'N': Q * C C * Q
// * TRANS = 'T': Q**T * C C * Q**T
// *
// * where Q is a real orthogonal matrix defined as the product of k
// * elementary reflectors
// *
// * Q = H(1) H(2) . . . H(k)
// *
// * as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
// * if SIDE = 'R'.
// *
// * Arguments
// * =========
// *
// * SIDE (input) CHARACTER*1
// * = 'L': apply Q or Q**T from the Left;
// * = 'R': apply Q or Q**T from the Right.
// *
// * TRANS (input) CHARACTER*1
// * = 'N': No transpose, apply Q;
// * = 'T': Transpose, apply Q**T.
// *
// * M (input) INTEGER
// * The number of rows of the matrix C. M >= 0.
// *
// * N (input) INTEGER
// * The number of columns of the matrix C. N >= 0.
// *
// * K (input) INTEGER
// * The number of elementary reflectors whose product defines
// * the matrix Q.
// * If SIDE = 'L', M >= K >= 0;
// * if SIDE = 'R', N >= K >= 0.
// *
// * L (input) INTEGER
// * The number of columns of the matrix A containing
// * the meaningful part of the Householder reflectors.
// * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
// *
// * A (input) DOUBLE PRECISION array, dimension
// * (LDA,M) if SIDE = 'L',
// * (LDA,N) if SIDE = 'R'
// * The i-th row must contain the vector which defines the
// * elementary reflector H(i), for i = 1,2,...,k, as returned by
// * DTZRZF in the last k rows of its array argument A.
// * A is modified by the routine but restored on exit.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,K).
// *
// * TAU (input) DOUBLE PRECISION array, dimension (K)
// * TAU(i) must contain the scalar factor of the elementary
// * reflector H(i), as returned by DTZRZF.
// *
// * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
// * On entry, the M-by-N matrix C.
// * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
// *
// * LDC (input) INTEGER
// * The leading dimension of the array C. LDC >= max(1,M).
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK.
// * If SIDE = 'L', LWORK >= max(1,N);
// * if SIDE = 'R', LWORK >= max(1,M).
// * For optimum performance LWORK >= N*NB if SIDE = 'L', and
// * LWORK >= M*NB if SIDE = 'R', where NB is the optimal
// * blocksize.
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// *
// * Further Details
// * ===============
// *
// * Based on contributions by
// * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, MIN;
// * ..
// * .. Executable Statements ..
// *
// * Test the input arguments
// *
#endregion
#region Body
INFO = 0;
LEFT = this._lsame.Run(SIDE, "L");
NOTRAN = this._lsame.Run(TRANS, "N");
LQUERY = (LWORK == -1);
// *
// * NQ is the order of Q and NW is the minimum dimension of WORK
// *
if (LEFT)
{
NQ = M;
NW = Math.Max(1, N);
}
else
{
NQ = N;
NW = Math.Max(1, M);
}
if (!LEFT && !this._lsame.Run(SIDE, "R"))
{
INFO = -1;
}
else
{
if (!NOTRAN && !this._lsame.Run(TRANS, "T"))
{
INFO = -2;
}
else
{
if (M < 0)
{
INFO = -3;
}
else
{
if (N < 0)
{
INFO = -4;
}
else
{
if (K < 0 || K > NQ)
{
INFO = -5;
}
else
{
if (L < 0 || (LEFT && (L > M)) || (!LEFT && (L > N)))
{
INFO = -6;
}
else
{
if (LDA < Math.Max(1, K))
{
INFO = -8;
}
else
{
if (LDC < Math.Max(1, M))
{
INFO = -11;
}
}
}
}
}
}
}
}
// *
if (INFO == 0)
{
if (M == 0 || N == 0)
{
LWKOPT = 1;
}
else
{
// *
// * Determine the block size. NB may be at most NBMAX, where
// * NBMAX is used to define the local array T.
// *
NB = Math.Min(NBMAX, this._ilaenv.Run(1, "DORMRQ", SIDE + TRANS, M, N, K, -1));
LWKOPT = NW * NB;
}
WORK[1 + o_work] = LWKOPT;
// *
if (LWORK < Math.Max(1, NW) && !LQUERY)
{
INFO = -13;
}
}
// *
if (INFO != 0)
{
this._xerbla.Run("DORMRZ", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
if (M == 0 || N == 0)
{
WORK[1 + o_work] = 1;
return;
}
// *
NBMIN = 2;
LDWORK = NW;
if (NB > 1 && NB < K)
{
IWS = NW * NB;
if (LWORK < IWS)
{
NB = LWORK / LDWORK;
NBMIN = Math.Max(2, this._ilaenv.Run(2, "DORMRQ", SIDE + TRANS, M, N, K, -1));
}
}
else
{
IWS = NW;
}
// *
if (NB < NBMIN || NB >= K)
{
// *
// * Use unblocked code
// *
this._dormr3.Run(SIDE, TRANS, M, N, K, L
, A, offset_a, LDA, TAU, offset_tau, ref C, offset_c, LDC, ref WORK, offset_work
, ref IINFO);
}
else
{
// *
// * Use blocked code
// *
if ((LEFT && !NOTRAN) || (!LEFT && NOTRAN))
{
I1 = 1;
I2 = K;
I3 = NB;
}
else
{
I1 = ((K - 1) / NB) * NB + 1;
I2 = 1;
I3 = -NB;
}
// *
if (LEFT)
{
NI = N;
JC = 1;
JA = M - L + 1;
}
else
{
MI = M;
IC = 1;
JA = N - L + 1;
}
// *
if (NOTRAN)
{
FortranLib.Copy(ref TRANST, "T");
}
else
{
FortranLib.Copy(ref TRANST, "N");
}
// *
for (I = I1; (I3 >= 0) ? (I <= I2) : (I >= I2); I += I3)
{
IB = Math.Min(NB, K - I + 1);
// *
// * Form the triangular factor of the block reflector
// * H = H(i+ib-1) . . . H(i+1) H(i)
// *
this._dlarzt.Run("Backward", "Rowwise", L, IB, A, I + JA * LDA + o_a, LDA
, TAU, I + o_tau, ref T, offset_t, LDT);
// *
if (LEFT)
{
// *
// * H or H' is applied to C(i:m,1:n)
// *
MI = M - I + 1;
IC = I;
}
else
{
// *
// * H or H' is applied to C(1:m,i:n)
// *
NI = N - I + 1;
JC = I;
}
// *
// * Apply H or H'
// *
this._dlarzb.Run(SIDE, TRANST, "Backward", "Rowwise", MI, NI
, IB, L, A, I + JA * LDA + o_a, LDA, T, offset_t, LDT
, ref C, IC + JC * LDC + o_c, LDC, ref WORK, offset_work, LDWORK);
}
// *
}
// *
WORK[1 + o_work] = LWKOPT;
// *
return;
// *
// * End of DORMRZ
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// 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 void Run(int N, int M, double[] X, int offset_x, double[] G, int offset_g, double[] WS, int offset_ws, double[] WY, int offset_wy
, double[] SY, int offset_sy, double[] WT, int offset_wt, double[] Z, int offset_z, ref double[] R, int offset_r, ref double[] WA, int offset_wa, int[] INDEX, int offset_index
, double THETA, int COL, int HEAD, int NFREE, bool CNSTND, ref int INFO)
{
#region Variables
int I = 0; int J = 0; int K = 0; int POINTR = 0; double A1 = 0; double A2 = 0;
#endregion
#region Array Index Correction
int o_x = -1 + offset_x; int o_g = -1 + offset_g; int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy;
int o_sy = -1 - M + offset_sy; int o_wt = -1 - M + offset_wt; int o_z = -1 + offset_z; int o_r = -1 + offset_r;
int o_wa = -1 + offset_wa; int o_index = -1 + offset_index;
#endregion
#region Prolog
// c ************
// c
// c Subroutine cmprlb
// c
// c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using
// c wa(2m+1)=W'(xcp-x) from subroutine cauchy.
// c
// c Subprograms called:
// c
// c L-BFGS-B Library ... bmv.
// c
// c
// c * * *
// c
// c NEOS, November 1994. (Latest revision June 1996.)
// c Optimization Technology Center.
// c Argonne National Laboratory and Northwestern University.
// c Written by
// c Ciyou Zhu
// c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
// c
// c
// c ************
#endregion
#region Body
if (!CNSTND && COL > 0)
{
for (I = 1; I <= N; I++)
{
R[I + o_r] = -G[I + o_g];
}
}
else
{
for (I = 1; I <= NFREE; I++)
{
K = INDEX[I + o_index];
R[I + o_r] = -THETA * (Z[K + o_z] - X[K + o_x]) - G[K + o_g];
}
this._bmv.Run(M, SY, offset_sy, WT, offset_wt, COL, WA, 2 * M + 1 + o_wa, ref WA, 1 + o_wa
, ref INFO);
if (INFO != 0)
{
INFO = -8;
return;
}
POINTR = HEAD;
for (J = 1; J <= COL; J++)
{
A1 = WA[J + o_wa];
A2 = THETA * WA[COL + J + o_wa];
for (I = 1; I <= NFREE; I++)
{
K = INDEX[I + o_index];
R[I + o_r] += WY[K + POINTR * N + o_wy] * A1 + WS[K + POINTR * N + o_ws] * A2;
}
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
}
return;
#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
/// =======
///
/// 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
}
/// <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
/// =======
///
/// 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
/// =======
///
/// DGEEV computes for an N-by-N real nonsymmetric matrix A, the
/// eigenvalues and, optionally, the left and/or right eigenvectors.
///
/// The right eigenvector v(j) of A satisfies
/// A * v(j) = lambda(j) * v(j)
/// where lambda(j) is its eigenvalue.
/// The left eigenvector u(j) of A satisfies
/// u(j)**H * A = lambda(j) * u(j)**H
/// where u(j)**H denotes the conjugate transpose of u(j).
///
/// The computed eigenvectors are normalized to have Euclidean norm
/// equal to 1 and largest component real.
///
///</summary>
/// <param name="JOBVL">
/// (input) CHARACTER*1
/// = 'N': left eigenvectors of A are not computed;
/// = 'V': left eigenvectors of A are computed.
///</param>
/// <param name="JOBVR">
/// (input) CHARACTER*1
/// = 'N': right eigenvectors of A are not computed;
/// = 'V': right eigenvectors of A are computed.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix A. N .GE. 0.
///</param>
/// <param name="A">
/// (input/output) DOUBLE PRECISION array, dimension (LDA,N)
/// On entry, the N-by-N matrix A.
/// On exit, A has been overwritten.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,N).
///</param>
/// <param name="WR">
/// (output) DOUBLE PRECISION array, dimension (N)
///</param>
/// <param name="WI">
/// (output) DOUBLE PRECISION array, dimension (N)
/// WR and WI contain the real and imaginary parts,
/// respectively, of the computed eigenvalues. Complex
/// conjugate pairs of eigenvalues appear consecutively
/// with the eigenvalue having the positive imaginary part
/// first.
///</param>
/// <param name="VL">
/// (output) DOUBLE PRECISION array, dimension (LDVL,N)
/// If JOBVL = 'V', the left eigenvectors u(j) are stored one
/// after another in the columns of VL, in the same order
/// as their eigenvalues.
/// If JOBVL = 'N', VL is not referenced.
/// If the j-th eigenvalue is real, then u(j) = VL(:,j),
/// the j-th column of VL.
/// If the j-th and (j+1)-st eigenvalues form a complex
/// conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
/// u(j+1) = VL(:,j) - i*VL(:,j+1).
///</param>
/// <param name="LDVL">
/// (input) INTEGER
/// The leading dimension of the array VL. LDVL .GE. 1; if
/// JOBVL = 'V', LDVL .GE. N.
///</param>
/// <param name="VR">
/// (output) DOUBLE PRECISION array, dimension (LDVR,N)
/// If JOBVR = 'V', the right eigenvectors v(j) are stored one
/// after another in the columns of VR, in the same order
/// as their eigenvalues.
/// If JOBVR = 'N', VR is not referenced.
/// If the j-th eigenvalue is real, then v(j) = VR(:,j),
/// the j-th column of VR.
/// If the j-th and (j+1)-st eigenvalues form a complex
/// conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
/// v(j+1) = VR(:,j) - i*VR(:,j+1).
///</param>
/// <param name="LDVR">
/// (input) INTEGER
/// The leading dimension of the array VR. LDVR .GE. 1; if
/// JOBVR = 'V', LDVR .GE. N.
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK. LWORK .GE. max(1,3*N), and
/// if JOBVL = 'V' or JOBVR = 'V', LWORK .GE. 4*N. For good
/// performance, LWORK must generally be larger.
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value.
/// .GT. 0: if INFO = i, the QR algorithm failed to compute all the
/// eigenvalues, and no eigenvectors have been computed;
/// elements i+1:N of WR and WI contain eigenvalues which
/// have converged.
///</param>
public void Run(string JOBVL, string JOBVR, int N, ref double[] A, int offset_a, int LDA, ref double[] WR, int offset_wr
, ref double[] WI, int offset_wi, ref double[] VL, int offset_vl, int LDVL, ref double[] VR, int offset_vr, int LDVR, ref double[] WORK, int offset_work
, int LWORK, ref int INFO)
{
#region Variables
bool LQUERY = false; bool SCALEA = false; bool WANTVL = false; bool WANTVR = false; string SIDE = new string(' ', 1);
int HSWORK = 0; int I = 0; int IBAL = 0; int IERR = 0; int IHI = 0; int ILO = 0; int ITAU = 0; int IWRK = 0; int K = 0;
int MAXWRK = 0; int MINWRK = 0; int NOUT = 0; double ANRM = 0; double BIGNUM = 0; double CS = 0; double CSCALE = 0;
double EPS = 0; double R = 0; double SCL = 0; double SMLNUM = 0; double SN = 0;
int offset_select = 0; int offset_dum = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi;
int o_vl = -1 - LDVL + offset_vl; int o_vr = -1 - LDVR + offset_vr; int o_work = -1 + offset_work;
#endregion
#region Strings
JOBVL = JOBVL.Substring(0, 1); JOBVR = JOBVR.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK driver routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DGEEV computes for an N-by-N real nonsymmetric matrix A, the
// * eigenvalues and, optionally, the left and/or right eigenvectors.
// *
// * The right eigenvector v(j) of A satisfies
// * A * v(j) = lambda(j) * v(j)
// * where lambda(j) is its eigenvalue.
// * The left eigenvector u(j) of A satisfies
// * u(j)**H * A = lambda(j) * u(j)**H
// * where u(j)**H denotes the conjugate transpose of u(j).
// *
// * The computed eigenvectors are normalized to have Euclidean norm
// * equal to 1 and largest component real.
// *
// * Arguments
// * =========
// *
// * JOBVL (input) CHARACTER*1
// * = 'N': left eigenvectors of A are not computed;
// * = 'V': left eigenvectors of A are computed.
// *
// * JOBVR (input) CHARACTER*1
// * = 'N': right eigenvectors of A are not computed;
// * = 'V': right eigenvectors of A are computed.
// *
// * N (input) INTEGER
// * The order of the matrix A. N >= 0.
// *
// * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
// * On entry, the N-by-N matrix A.
// * On exit, A has been overwritten.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,N).
// *
// * WR (output) DOUBLE PRECISION array, dimension (N)
// * WI (output) DOUBLE PRECISION array, dimension (N)
// * WR and WI contain the real and imaginary parts,
// * respectively, of the computed eigenvalues. Complex
// * conjugate pairs of eigenvalues appear consecutively
// * with the eigenvalue having the positive imaginary part
// * first.
// *
// * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
// * If JOBVL = 'V', the left eigenvectors u(j) are stored one
// * after another in the columns of VL, in the same order
// * as their eigenvalues.
// * If JOBVL = 'N', VL is not referenced.
// * If the j-th eigenvalue is real, then u(j) = VL(:,j),
// * the j-th column of VL.
// * If the j-th and (j+1)-st eigenvalues form a complex
// * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
// * u(j+1) = VL(:,j) - i*VL(:,j+1).
// *
// * LDVL (input) INTEGER
// * The leading dimension of the array VL. LDVL >= 1; if
// * JOBVL = 'V', LDVL >= N.
// *
// * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
// * If JOBVR = 'V', the right eigenvectors v(j) are stored one
// * after another in the columns of VR, in the same order
// * as their eigenvalues.
// * If JOBVR = 'N', VR is not referenced.
// * If the j-th eigenvalue is real, then v(j) = VR(:,j),
// * the j-th column of VR.
// * If the j-th and (j+1)-st eigenvalues form a complex
// * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
// * v(j+1) = VR(:,j) - i*VR(:,j+1).
// *
// * LDVR (input) INTEGER
// * The leading dimension of the array VR. LDVR >= 1; if
// * JOBVR = 'V', LDVR >= N.
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK. LWORK >= max(1,3*N), and
// * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
// * performance, LWORK must generally be larger.
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value.
// * > 0: if INFO = i, the QR algorithm failed to compute all the
// * eigenvalues, and no eigenvectors have been computed;
// * elements i+1:N of WR and WI contain eigenvalues which
// * have converged.
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. External Functions ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MAX, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input arguments
// *
#endregion
#region Body
INFO = 0;
LQUERY = (LWORK == -1);
WANTVL = this._lsame.Run(JOBVL, "V");
WANTVR = this._lsame.Run(JOBVR, "V");
if ((!WANTVL) && (!this._lsame.Run(JOBVL, "N")))
{
INFO = -1;
}
else
{
if ((!WANTVR) && (!this._lsame.Run(JOBVR, "N")))
{
INFO = -2;
}
else
{
if (N < 0)
{
INFO = -3;
}
else
{
if (LDA < Math.Max(1, N))
{
INFO = -5;
}
else
{
if (LDVL < 1 || (WANTVL && LDVL < N))
{
INFO = -9;
}
else
{
if (LDVR < 1 || (WANTVR && LDVR < N))
{
INFO = -11;
}
}
}
}
}
}
// *
// * Compute workspace
// * (Note: Comments in the code beginning "Workspace:" describe the
// * minimal amount of workspace needed at that point in the code,
// * as well as the preferred amount for good performance.
// * NB refers to the optimal block size for the immediately
// * following subroutine, as returned by ILAENV.
// * HSWORK refers to the workspace preferred by DHSEQR, as
// * calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
// * the worst case.)
// *
if (INFO == 0)
{
if (N == 0)
{
MINWRK = 1;
MAXWRK = 1;
}
else
{
MAXWRK = 2 * N + N * this._ilaenv.Run(1, "DGEHRD", " ", N, 1, N, 0);
if (WANTVL)
{
MINWRK = 4 * N;
MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1));
this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
MAXWRK = Math.Max(MAXWRK, 4 * N);
}
else
{
if (WANTVR)
{
MINWRK = 4 * N;
MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1));
this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
MAXWRK = Math.Max(MAXWRK, 4 * N);
}
else
{
MINWRK = 3 * N;
this._dhseqr.Run("E", "N", N, 1, N, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work
, -1, ref INFO);
HSWORK = (int)WORK[1 + o_work];
MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK));
}
}
MAXWRK = Math.Max(MAXWRK, MINWRK);
}
WORK[1 + o_work] = MAXWRK;
// *
if (LWORK < MINWRK && !LQUERY)
{
INFO = -13;
}
}
// *
if (INFO != 0)
{
this._xerbla.Run("DGEEV ", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
if (N == 0)
{
return;
}
// *
// * Get machine constants
// *
EPS = this._dlamch.Run("P");
SMLNUM = this._dlamch.Run("S");
BIGNUM = ONE / SMLNUM;
this._dlabad.Run(ref SMLNUM, ref BIGNUM);
SMLNUM = Math.Sqrt(SMLNUM) / EPS;
BIGNUM = ONE / SMLNUM;
// *
// * Scale A if max element outside range [SMLNUM,BIGNUM]
// *
ANRM = this._dlange.Run("M", N, N, A, offset_a, LDA, ref DUM, offset_dum);
SCALEA = false;
if (ANRM > ZERO && ANRM < SMLNUM)
{
SCALEA = true;
CSCALE = SMLNUM;
}
else
{
if (ANRM > BIGNUM)
{
SCALEA = true;
CSCALE = BIGNUM;
}
}
if (SCALEA)
{
this._dlascl.Run("G", 0, 0, ANRM, CSCALE, N
, N, ref A, offset_a, LDA, ref IERR);
}
// *
// * Balance the matrix
// * (Workspace: need N)
// *
IBAL = 1;
this._dgebal.Run("B", N, ref A, offset_a, LDA, ref ILO, ref IHI
, ref WORK, IBAL + o_work, ref IERR);
// *
// * Reduce to upper Hessenberg form
// * (Workspace: need 3*N, prefer 2*N+N*NB)
// *
ITAU = IBAL + N;
IWRK = ITAU + N;
this._dgehrd.Run(N, ILO, IHI, ref A, offset_a, LDA, ref WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
if (WANTVL)
{
// *
// * Want left eigenvectors
// * Copy Householder vectors to VL
// *
FortranLib.Copy(ref SIDE, "L");
this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VL, offset_vl
, LDVL);
// *
// * Generate orthogonal matrix in VL
// * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
// *
this._dorghr.Run(N, ILO, IHI, ref VL, offset_vl, LDVL, WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
// * Perform QR iteration, accumulating Schur vectors in VL
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
// *
if (WANTVR)
{
// *
// * Want left and right eigenvectors
// * Copy Schur vectors to VR
// *
FortranLib.Copy(ref SIDE, "B");
this._dlacpy.Run("F", N, N, VL, offset_vl, LDVL, ref VR, offset_vr
, LDVR);
}
// *
}
else
{
if (WANTVR)
{
// *
// * Want right eigenvectors
// * Copy Householder vectors to VR
// *
FortranLib.Copy(ref SIDE, "R");
this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VR, offset_vr
, LDVR);
// *
// * Generate orthogonal matrix in VR
// * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
// *
this._dorghr.Run(N, ILO, IHI, ref VR, offset_vr, LDVR, WORK, ITAU + o_work
, ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR);
// *
// * Perform QR iteration, accumulating Schur vectors in VR
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
// *
}
else
{
// *
// * Compute eigenvalues only
// * (Workspace: need N+1, prefer N+HSWORK (see comments) )
// *
IWRK = ITAU;
this._dhseqr.Run("E", "N", N, ILO, IHI, ref A, offset_a
, LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work
, LWORK - IWRK + 1, ref INFO);
}
}
// *
// * If INFO > 0 from DHSEQR, then quit
// *
if (INFO > 0)
{
goto LABEL50;
}
// *
if (WANTVL || WANTVR)
{
// *
// * Compute left and/or right eigenvectors
// * (Workspace: need 4*N)
// *
this._dtrevc.Run(SIDE, "B", ref SELECT, offset_select, N, A, offset_a, LDA
, ref VL, offset_vl, LDVL, ref VR, offset_vr, LDVR, N, ref NOUT
, ref WORK, IWRK + o_work, ref IERR);
}
// *
if (WANTVL)
{
// *
// * Undo balancing of left eigenvectors
// * (Workspace: need N)
// *
this._dgebak.Run("B", "L", N, ILO, IHI, WORK, IBAL + o_work
, N, ref VL, offset_vl, LDVL, ref IERR);
// *
// * Normalize left eigenvectors and make largest component real
// *
for (I = 1; I <= N; I++)
{
if (WI[I + o_wi] == ZERO)
{
SCL = ONE / this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1);
this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1);
}
else
{
if (WI[I + o_wi] > ZERO)
{
SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1), this._dnrm2.Run(N, VL, 1 + (I + 1) * LDVL + o_vl, 1));
this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1);
this._dscal.Run(N, SCL, ref VL, 1 + (I + 1) * LDVL + o_vl, 1);
for (K = 1; K <= N; K++)
{
WORK[IWRK + K - 1 + o_work] = Math.Pow(VL[K + I * LDVL + o_vl], 2) + Math.Pow(VL[K + (I + 1) * LDVL + o_vl], 2);
}
K = this._idamax.Run(N, WORK, IWRK + o_work, 1);
this._dlartg.Run(VL[K + I * LDVL + o_vl], VL[K + (I + 1) * LDVL + o_vl], ref CS, ref SN, ref R);
this._drot.Run(N, ref VL, 1 + I * LDVL + o_vl, 1, ref VL, 1 + (I + 1) * LDVL + o_vl, 1, CS
, SN);
VL[K + (I + 1) * LDVL + o_vl] = ZERO;
}
}
}
}
// *
if (WANTVR)
{
// *
// * Undo balancing of right eigenvectors
// * (Workspace: need N)
// *
this._dgebak.Run("B", "R", N, ILO, IHI, WORK, IBAL + o_work
, N, ref VR, offset_vr, LDVR, ref IERR);
// *
// * Normalize right eigenvectors and make largest component real
// *
for (I = 1; I <= N; I++)
{
if (WI[I + o_wi] == ZERO)
{
SCL = ONE / this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1);
this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1);
}
else
{
if (WI[I + o_wi] > ZERO)
{
SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1), this._dnrm2.Run(N, VR, 1 + (I + 1) * LDVR + o_vr, 1));
this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1);
this._dscal.Run(N, SCL, ref VR, 1 + (I + 1) * LDVR + o_vr, 1);
for (K = 1; K <= N; K++)
{
WORK[IWRK + K - 1 + o_work] = Math.Pow(VR[K + I * LDVR + o_vr], 2) + Math.Pow(VR[K + (I + 1) * LDVR + o_vr], 2);
}
K = this._idamax.Run(N, WORK, IWRK + o_work, 1);
this._dlartg.Run(VR[K + I * LDVR + o_vr], VR[K + (I + 1) * LDVR + o_vr], ref CS, ref SN, ref R);
this._drot.Run(N, ref VR, 1 + I * LDVR + o_vr, 1, ref VR, 1 + (I + 1) * LDVR + o_vr, 1, CS
, SN);
VR[K + (I + 1) * LDVR + o_vr] = ZERO;
}
}
}
}
// *
// * Undo scaling if necessary
// *
LABEL50 :;
if (SCALEA)
{
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO
, 1, ref WR, INFO + 1 + o_wr, Math.Max(N - INFO, 1), ref IERR);
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO
, 1, ref WI, INFO + 1 + o_wi, Math.Max(N - INFO, 1), ref IERR);
if (INFO > 0)
{
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1
, 1, ref WR, offset_wr, N, ref IERR);
this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1
, 1, ref WI, offset_wi, N, ref IERR);
}
}
// *
WORK[1 + o_work] = MAXWRK;
return;
// *
// * End of DGEEV
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// 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
/// =======
///
/// DTRCON estimates the reciprocal of the condition number of a
/// triangular matrix A, in either the 1-norm or the infinity-norm.
///
/// The norm of A is computed and an estimate is obtained for
/// norm(inv(A)), then the reciprocal of the condition number is
/// computed as
/// RCOND = 1 / ( norm(A) * norm(inv(A)) ).
///
///</summary>
/// <param name="NORM">
/// (input) CHARACTER*1
/// Specifies whether the 1-norm condition number or the
/// infinity-norm condition number is required:
/// = '1' or 'O': 1-norm;
/// = 'I': Infinity-norm.
///</param>
/// <param name="UPLO">
/// (input) CHARACTER*1
/// = 'U': A is upper triangular;
/// = 'L': A is lower triangular.
///</param>
/// <param name="DIAG">
/// (input) CHARACTER*1
/// = 'N': A is non-unit triangular;
/// = 'U': A is unit triangular.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix A. N .GE. 0.
///</param>
/// <param name="A">
/// (input) DOUBLE PRECISION array, dimension (LDA,N)
/// The triangular matrix A. If UPLO = 'U', the leading N-by-N
/// upper triangular part of the array A contains the upper
/// triangular matrix, and the strictly lower triangular part of
/// A is not referenced. If UPLO = 'L', the leading N-by-N lower
/// triangular part of the array A contains the lower triangular
/// matrix, and the strictly upper triangular part of A is not
/// referenced. If DIAG = 'U', the diagonal elements of A are
/// also not referenced and are assumed to be 1.
///</param>
/// <param name="LDA">
/// (input) INTEGER
/// The leading dimension of the array A. LDA .GE. max(1,N).
///</param>
/// <param name="RCOND">
/// (output) DOUBLE PRECISION
/// The reciprocal of the condition number of the matrix A,
/// computed as RCOND = 1/(norm(A) * norm(inv(A))).
///</param>
/// <param name="WORK">
/// (workspace) DOUBLE PRECISION array, dimension (3*N)
///</param>
/// <param name="IWORK">
/// (workspace) INTEGER array, dimension (N)
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value
///</param>
public void Run(string NORM, string UPLO, string DIAG, int N, double[] A, int offset_a, int LDA
, ref double RCOND, ref double[] WORK, int offset_work, ref int[] IWORK, int offset_iwork, ref int INFO)
{
#region Variables
bool NOUNIT = false; bool ONENRM = false; bool UPPER = false; string NORMIN = new string(' ', 1); int IX = 0;
int KASE = 0; int KASE1 = 0; double AINVNM = 0; double ANORM = 0; double SCALE = 0; double SMLNUM = 0;
double XNORM = 0;
#endregion
#region Array Index Correction
int o_a = -1 - LDA + offset_a; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork;
#endregion
#region Strings
NORM = NORM.Substring(0, 1); UPLO = UPLO.Substring(0, 1); DIAG = DIAG.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK routine (version 3.0) --
// * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
// * Courant Institute, Argonne National Lab, and Rice University
// * March 31, 1993
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DTRCON estimates the reciprocal of the condition number of a
// * triangular matrix A, in either the 1-norm or the infinity-norm.
// *
// * The norm of A is computed and an estimate is obtained for
// * norm(inv(A)), then the reciprocal of the condition number is
// * computed as
// * RCOND = 1 / ( norm(A) * norm(inv(A)) ).
// *
// * Arguments
// * =========
// *
// * NORM (input) CHARACTER*1
// * Specifies whether the 1-norm condition number or the
// * infinity-norm condition number is required:
// * = '1' or 'O': 1-norm;
// * = 'I': Infinity-norm.
// *
// * UPLO (input) CHARACTER*1
// * = 'U': A is upper triangular;
// * = 'L': A is lower triangular.
// *
// * DIAG (input) CHARACTER*1
// * = 'N': A is non-unit triangular;
// * = 'U': A is unit triangular.
// *
// * N (input) INTEGER
// * The order of the matrix A. N >= 0.
// *
// * A (input) DOUBLE PRECISION array, dimension (LDA,N)
// * The triangular matrix A. If UPLO = 'U', the leading N-by-N
// * upper triangular part of the array A contains the upper
// * triangular matrix, and the strictly lower triangular part of
// * A is not referenced. If UPLO = 'L', the leading N-by-N lower
// * triangular part of the array A contains the lower triangular
// * matrix, and the strictly upper triangular part of A is not
// * referenced. If DIAG = 'U', the diagonal elements of A are
// * also not referenced and are assumed to be 1.
// *
// * LDA (input) INTEGER
// * The leading dimension of the array A. LDA >= max(1,N).
// *
// * RCOND (output) DOUBLE PRECISION
// * The reciprocal of the condition number of the matrix A,
// * computed as RCOND = 1/(norm(A) * norm(inv(A))).
// *
// * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
// *
// * IWORK (workspace) INTEGER array, dimension (N)
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * < 0: if INFO = -i, the i-th argument had an illegal value
// *
// * =====================================================================
// *
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, MAX;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
UPPER = this._lsame.Run(UPLO, "U");
ONENRM = NORM == "1" || this._lsame.Run(NORM, "O");
NOUNIT = this._lsame.Run(DIAG, "N");
// *
if (!ONENRM && !this._lsame.Run(NORM, "I"))
{
INFO = -1;
}
else
{
if (!UPPER && !this._lsame.Run(UPLO, "L"))
{
INFO = -2;
}
else
{
if (!NOUNIT && !this._lsame.Run(DIAG, "U"))
{
INFO = -3;
}
else
{
if (N < 0)
{
INFO = -4;
}
else
{
if (LDA < Math.Max(1, N))
{
INFO = -6;
}
}
}
}
}
if (INFO != 0)
{
this._xerbla.Run("DTRCON", -INFO);
return;
}
// *
// * Quick return if possible
// *
if (N == 0)
{
RCOND = ONE;
return;
}
// *
RCOND = ZERO;
SMLNUM = this._dlamch.Run("Safe minimum") * Convert.ToDouble(Math.Max(1, N));
// *
// * Compute the norm of the triangular matrix A.
// *
ANORM = this._dlantr.Run(NORM, UPLO, DIAG, N, N, A, offset_a, LDA, ref WORK, offset_work);
// *
// * Continue only if ANORM > 0.
// *
if (ANORM > ZERO)
{
// *
// * Estimate the norm of the inverse of A.
// *
AINVNM = ZERO;
FortranLib.Copy(ref NORMIN, "N");
if (ONENRM)
{
KASE1 = 1;
}
else
{
KASE1 = 2;
}
KASE = 0;
LABEL10 :;
this._dlacon.Run(N, ref WORK, N + 1 + o_work, ref WORK, offset_work, ref IWORK, offset_iwork, ref AINVNM, ref KASE);
if (KASE != 0)
{
if (KASE == KASE1)
{
// *
// * Multiply by inv(A).
// *
this._dlatrs.Run(UPLO, "No transpose", DIAG, NORMIN, N, A, offset_a
, LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO);
}
else
{
// *
// * Multiply by inv(A').
// *
this._dlatrs.Run(UPLO, "Transpose", DIAG, NORMIN, N, A, offset_a
, LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO);
}
FortranLib.Copy(ref NORMIN, "Y");
// *
// * Multiply by 1/SCALE if doing so will not cause overflow.
// *
if (SCALE != ONE)
{
IX = this._idamax.Run(N, WORK, offset_work, 1);
XNORM = Math.Abs(WORK[IX + o_work]);
if (SCALE < XNORM * SMLNUM || SCALE == ZERO)
{
goto LABEL20;
}
this._drscl.Run(N, SCALE, ref WORK, offset_work, 1);
}
goto LABEL10;
}
// *
// * Compute the estimate of the reciprocal condition number.
// *
if (AINVNM != ZERO)
{
RCOND = (ONE / ANORM) / AINVNM;
}
}
// *
LABEL20 :;
return;
// *
// * End of DTRCON
// *
#endregion
}
/// <param name="T">
/// * x = b
///</param>
/// <param name="LDT">
/// integer
/// ldt is the leading dimension of the array t.
///</param>
/// <param name="N">
/// integer
/// n is the order of the system.
///</param>
/// <param name="B">
/// double precision(n).
/// b contains the right hand side of the system.
///</param>
/// <param name="JOB">
/// integer
/// job specifies what kind of system is to be solved.
/// if job is
///
/// 00 solve t*x=b, t lower triangular,
/// 01 solve t*x=b, t upper triangular,
/// 10 solve trans(t)*x=b, t lower triangular,
/// 11 solve trans(t)*x=b, t upper triangular.
///</param>
/// <param name="INFO">
/// integer
/// info contains zero if the system is nonsingular.
/// otherwise info contains the index of
/// the first zero diagonal element of t.
///</param>
public void Run(double[] T, int offset_t, int LDT, int N, ref double[] B, int offset_b, int JOB, ref int INFO)
{
#region Variables
double TEMP = 0; int CASE = 0; int J = 0; int JJ = 0;
#endregion
#region Array Index Correction
int o_t = -1 - LDT + offset_t; int o_b = -1 + offset_b;
#endregion
#region Prolog
// c
// c
// c dtrsl solves systems of the form
// c
// c t * x = b
// c or
// c trans(t) * x = b
// c
// c where t is a triangular matrix of order n. here trans(t)
// c denotes the transpose of the matrix t.
// c
// c on entry
// c
// c t double precision(ldt,n)
// c t contains the matrix of the system. the zero
// c elements of the matrix are not referenced, and
// c the corresponding elements of the array can be
// c used to store other information.
// c
// c ldt integer
// c ldt is the leading dimension of the array t.
// c
// c n integer
// c n is the order of the system.
// c
// c b double precision(n).
// c b contains the right hand side of the system.
// c
// c job integer
// c job specifies what kind of system is to be solved.
// c if job is
// c
// c 00 solve t*x=b, t lower triangular,
// c 01 solve t*x=b, t upper triangular,
// c 10 solve trans(t)*x=b, t lower triangular,
// c 11 solve trans(t)*x=b, t upper triangular.
// c
// c on return
// c
// c b b contains the solution, if info .eq. 0.
// c otherwise b is unaltered.
// c
// c info integer
// c info contains zero if the system is nonsingular.
// c otherwise info contains the index of
// c the first zero diagonal element of t.
// c
// c linpack. this version dated 08/14/78 .
// c g. w. stewart, university of maryland, argonne national lab.
// c
// c subroutines and functions
// c
// c blas daxpy,ddot
// c fortran mod
// c
// c internal variables
// c
// INTRINSIC MOD;
// c
// c begin block permitting ...exits to 150
// c
// c check for zero diagonal elements.
// c
#endregion
#region Body
for (INFO = 1; INFO <= N; INFO++)
{
// c ......exit
if (T[INFO + INFO * LDT + o_t] == 0.0E0)
{
goto LABEL150;
}
}
INFO = 0;
// c
// c determine the task and go to it.
// c
CASE = 1;
if (FortranLib.Mod(JOB, 10) != 0)
{
CASE = 2;
}
if (FortranLib.Mod(JOB, 100) / 10 != 0)
{
CASE += 2;
}
switch (CASE)
{
case 1: goto LABEL20;
case 2: goto LABEL50;
case 3: goto LABEL80;
case 4: goto LABEL110;
}
// c
// c solve t*x=b for t lower triangular
// c
LABEL20 :;
B[1 + o_b] /= T[1 + 1 * LDT + o_t];
if (N < 2)
{
goto LABEL40;
}
for (J = 2; J <= N; J++)
{
TEMP = -B[J - 1 + o_b];
this._daxpy.Run(N - J + 1, TEMP, T, J + (J - 1) * LDT + o_t, 1, ref B, J + o_b, 1);
B[J + o_b] /= T[J + J * LDT + o_t];
}
LABEL40 :;
goto LABEL140;
// c
// c solve t*x=b for t upper triangular.
// c
LABEL50 :;
B[N + o_b] /= T[N + N * LDT + o_t];
if (N < 2)
{
goto LABEL70;
}
for (JJ = 2; JJ <= N; JJ++)
{
J = N - JJ + 1;
TEMP = -B[J + 1 + o_b];
this._daxpy.Run(J, TEMP, T, 1 + (J + 1) * LDT + o_t, 1, ref B, 1 + o_b, 1);
B[J + o_b] /= T[J + J * LDT + o_t];
}
LABEL70 :;
goto LABEL140;
// c
// c solve trans(t)*x=b for t lower triangular.
// c
LABEL80 :;
B[N + o_b] /= T[N + N * LDT + o_t];
if (N < 2)
{
goto LABEL100;
}
for (JJ = 2; JJ <= N; JJ++)
{
J = N - JJ + 1;
B[J + o_b] -= this._ddot.Run(JJ - 1, T, J + 1 + J * LDT + o_t, 1, B, J + 1 + o_b, 1);
B[J + o_b] /= T[J + J * LDT + o_t];
}
LABEL100 :;
goto LABEL140;
// c
// c solve trans(t)*x=b for t upper triangular.
// c
LABEL110 :;
B[1 + o_b] /= T[1 + 1 * LDT + o_t];
if (N < 2)
{
goto LABEL130;
}
for (J = 2; J <= N; J++)
{
B[J + o_b] -= this._ddot.Run(J - 1, T, 1 + J * LDT + o_t, 1, B, 1 + o_b, 1);
B[J + o_b] /= T[J + J * LDT + o_t];
}
LABEL130 :;
LABEL140 :;
LABEL150 :;
return;
#endregion
}
public void Run(int N, double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY)
{
#region Variables
int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy;
#endregion
// c
// c copies a vector, x, to a vector, y.
// c uses unrolled loops for increments equal to one.
// c jack dongarra, linpack, 3/11/78.
// c modified 12/3/93, array(1) declarations changed to array(*)
// c
// c
#region Body
if (N <= 0)
{
return;
}
if (INCX == 1 && INCY == 1)
{
goto LABEL20;
}
// c
// c code for unequal increments or equal increments
// c not equal to 1
// c
IX = 1;
IY = 1;
if (INCX < 0)
{
IX = (-N + 1) * INCX + 1;
}
if (INCY < 0)
{
IY = (-N + 1) * INCY + 1;
}
for (I = 1; I <= N; I++)
{
DY[IY + o_dy] = DX[IX + o_dx];
IX += INCX;
IY += INCY;
}
return;
// c
// c code for both increments equal to 1
// c
// c
// c clean-up loop
// c
LABEL20 : M = FortranLib.Mod(N, 7);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DY[I + o_dy] = DX[I + o_dx];
}
if (N < 7)
{
return;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 7)
{
DY[I + o_dy] = DX[I + o_dx];
DY[I + 1 + o_dy] = DX[I + 1 + o_dx];
DY[I + 2 + o_dy] = DX[I + 2 + o_dx];
DY[I + 3 + o_dy] = DX[I + 3 + o_dx];
DY[I + 4 + o_dy] = DX[I + 4 + o_dx];
DY[I + 5 + o_dy] = DX[I + 5 + o_dx];
DY[I + 6 + o_dy] = DX[I + 6 + o_dx];
}
return;
#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
}
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
/// =======
///
/// DLAQR0 computes the eigenvalues of a Hessenberg matrix H
/// and, optionally, the matrices T and Z from the Schur decomposition
/// H = Z T Z**T, where T is an upper quasi-triangular matrix (the
/// Schur form), and Z is the orthogonal matrix of Schur vectors.
///
/// Optionally Z may be postmultiplied into an input orthogonal
/// matrix Q so that this routine can give the Schur factorization
/// of a matrix A which has been reduced to the Hessenberg form H
/// by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
///
///</summary>
/// <param name="WANTT">
/// (input) LOGICAL
/// = .TRUE. : the full Schur form T is required;
/// = .FALSE.: only eigenvalues are required.
///</param>
/// <param name="WANTZ">
/// (input) LOGICAL
/// = .TRUE. : the matrix of Schur vectors Z is required;
/// = .FALSE.: Schur vectors are not required.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The order of the matrix H. N .GE. 0.
///</param>
/// <param name="ILO">
/// (input) INTEGER
///</param>
/// <param name="IHI">
/// (input) INTEGER
/// It is assumed that H is already upper triangular in rows
/// and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
/// H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
/// previous call to DGEBAL, and then passed to DGEHRD when the
/// matrix output by DGEBAL is reduced to Hessenberg form.
/// Otherwise, ILO and IHI should be set to 1 and N,
/// respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
/// If N = 0, then ILO = 1 and IHI = 0.
///</param>
/// <param name="H">
/// (input/output) DOUBLE PRECISION array, dimension (LDH,N)
/// On entry, the upper Hessenberg matrix H.
/// On exit, if INFO = 0 and WANTT is .TRUE., then H contains
/// the upper quasi-triangular matrix T from the Schur
/// decomposition (the Schur form); 2-by-2 diagonal blocks
/// (corresponding to complex conjugate pairs of eigenvalues)
/// are returned in standard form, with H(i,i) = H(i+1,i+1)
/// and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
/// .FALSE., then the contents of H are unspecified on exit.
/// (The output value of H when INFO.GT.0 is given under the
/// description of INFO below.)
///
/// This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
/// j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
///</param>
/// <param name="LDH">
/// (input) INTEGER
/// The leading dimension of the array H. LDH .GE. max(1,N).
///</param>
/// <param name="WR">
/// (output) DOUBLE PRECISION array, dimension (IHI)
///</param>
/// <param name="WI">
/// (output) DOUBLE PRECISION array, dimension (IHI)
/// The real and imaginary parts, respectively, of the computed
/// eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
/// and WI(ILO:IHI). If two eigenvalues are computed as a
/// complex conjugate pair, they are stored in consecutive
/// elements of WR and WI, say the i-th and (i+1)th, with
/// WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
/// the eigenvalues are stored in the same order as on the
/// diagonal of the Schur form returned in H, with
/// WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
/// block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
/// WI(i+1) = -WI(i).
///</param>
/// <param name="ILOZ">
/// (input) INTEGER
///</param>
/// <param name="IHIZ">
/// (input) INTEGER
/// Specify the rows of Z to which transformations must be
/// applied if WANTZ is .TRUE..
/// 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
///</param>
/// <param name="Z">
/// (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
/// If WANTZ is .FALSE., then Z is not referenced.
/// If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
/// replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
/// orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
/// (The output value of Z when INFO.GT.0 is given under
/// the description of INFO below.)
///</param>
/// <param name="LDZ">
/// (input) INTEGER
/// The leading dimension of the array Z. if WANTZ is .TRUE.
/// then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array, dimension LWORK
/// On exit, if LWORK = -1, WORK(1) returns an estimate of
/// the optimal value for LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK. LWORK .GE. max(1,N)
/// is sufficient, but LWORK typically as large as 6*N may
/// be required for optimal performance. A workspace query
/// to determine the optimal workspace size is recommended.
///
/// If LWORK = -1, then DLAQR0 does a workspace query.
/// In this case, DLAQR0 checks the input parameters and
/// estimates the optimal workspace size for the given
/// values of N, ILO and IHI. The estimate is returned
/// in WORK(1). No error message related to LWORK is
/// issued by XERBLA. Neither H nor Z are accessed.
///
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit
/// .GT. 0: if INFO = i, DLAQR0 failed to compute all of
/// the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
/// and WI contain those eigenvalues which have been
/// successfully computed. (Failures are rare.)
///
/// If INFO .GT. 0 and WANT is .FALSE., then on exit,
/// the remaining unconverged eigenvalues are the eigen-
/// values of the upper Hessenberg matrix rows and
/// columns ILO through INFO of the final, output
/// value of H.
///
/// If INFO .GT. 0 and WANTT is .TRUE., then on exit
///
/// (*) (initial value of H)*U = U*(final value of H)
///
/// where U is an orthogonal matrix. The final
/// value of H is upper Hessenberg and quasi-triangular
/// in rows and columns INFO+1 through IHI.
///
/// If INFO .GT. 0 and WANTZ is .TRUE., then on exit
///
/// (final value of Z(ILO:IHI,ILOZ:IHIZ)
/// = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
///
/// where U is the orthogonal matrix in (*) (regard-
/// less of the value of WANTT.)
///
/// If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
/// accessed.
///
///</param>
public void Run(bool WANTT, bool WANTZ, int N, int ILO, int IHI, ref double[] H, int offset_h
, int LDH, ref double[] WR, int offset_wr, ref double[] WI, int offset_wi, int ILOZ, int IHIZ, ref double[] Z, int offset_z
, int LDZ, ref double[] WORK, int offset_work, int LWORK, ref int INFO)
{
#region Variables
double AA = 0; double BB = 0; double CC = 0; double CS = 0; double DD = 0; double SN = 0; double SS = 0;
double SWAP = 0; int I = 0; int INF = 0; int IT = 0; int ITMAX = 0; int K = 0; int KACC22 = 0; int KBOT = 0;
int KDU = 0; int KS = 0; int KT = 0; int KTOP = 0; int KU = 0; int KV = 0; int KWH = 0; int KWTOP = 0; int KWV = 0;
int LD = 0; int LS = 0; int LWKOPT = 0; int NDFL = 0; int NH = 0; int NHO = 0; int NIBBLE = 0; int NMIN = 0;
int NS = 0; int NSMAX = 0; int NSR = 0; int NVE = 0; int NW = 0; int NWMAX = 0; int NWR = 0; bool NWINC = false;
bool SORTED = false; string JBCMPZ = new string(' ', 2); int offset_zdum = 0;
#endregion
#region Array Index Correction
int o_h = -1 - LDH + offset_h; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi;
int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work;
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DLAQR0 computes the eigenvalues of a Hessenberg matrix H
// * and, optionally, the matrices T and Z from the Schur decomposition
// * H = Z T Z**T, where T is an upper quasi-triangular matrix (the
// * Schur form), and Z is the orthogonal matrix of Schur vectors.
// *
// * Optionally Z may be postmultiplied into an input orthogonal
// * matrix Q so that this routine can give the Schur factorization
// * of a matrix A which has been reduced to the Hessenberg form H
// * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
// *
// * Arguments
// * =========
// *
// * WANTT (input) LOGICAL
// * = .TRUE. : the full Schur form T is required;
// * = .FALSE.: only eigenvalues are required.
// *
// * WANTZ (input) LOGICAL
// * = .TRUE. : the matrix of Schur vectors Z is required;
// * = .FALSE.: Schur vectors are not required.
// *
// * N (input) INTEGER
// * The order of the matrix H. N .GE. 0.
// *
// * ILO (input) INTEGER
// * IHI (input) INTEGER
// * It is assumed that H is already upper triangular in rows
// * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
// * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
// * previous call to DGEBAL, and then passed to DGEHRD when the
// * matrix output by DGEBAL is reduced to Hessenberg form.
// * Otherwise, ILO and IHI should be set to 1 and N,
// * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
// * If N = 0, then ILO = 1 and IHI = 0.
// *
// * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
// * On entry, the upper Hessenberg matrix H.
// * On exit, if INFO = 0 and WANTT is .TRUE., then H contains
// * the upper quasi-triangular matrix T from the Schur
// * decomposition (the Schur form); 2-by-2 diagonal blocks
// * (corresponding to complex conjugate pairs of eigenvalues)
// * are returned in standard form, with H(i,i) = H(i+1,i+1)
// * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
// * .FALSE., then the contents of H are unspecified on exit.
// * (The output value of H when INFO.GT.0 is given under the
// * description of INFO below.)
// *
// * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
// * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
// *
// * LDH (input) INTEGER
// * The leading dimension of the array H. LDH .GE. max(1,N).
// *
// * WR (output) DOUBLE PRECISION array, dimension (IHI)
// * WI (output) DOUBLE PRECISION array, dimension (IHI)
// * The real and imaginary parts, respectively, of the computed
// * eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
// * and WI(ILO:IHI). If two eigenvalues are computed as a
// * complex conjugate pair, they are stored in consecutive
// * elements of WR and WI, say the i-th and (i+1)th, with
// * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
// * the eigenvalues are stored in the same order as on the
// * diagonal of the Schur form returned in H, with
// * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
// * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
// * WI(i+1) = -WI(i).
// *
// * ILOZ (input) INTEGER
// * IHIZ (input) INTEGER
// * Specify the rows of Z to which transformations must be
// * applied if WANTZ is .TRUE..
// * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
// *
// * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
// * If WANTZ is .FALSE., then Z is not referenced.
// * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
// * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
// * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
// * (The output value of Z when INFO.GT.0 is given under
// * the description of INFO below.)
// *
// * LDZ (input) INTEGER
// * The leading dimension of the array Z. if WANTZ is .TRUE.
// * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
// *
// * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
// * On exit, if LWORK = -1, WORK(1) returns an estimate of
// * the optimal value for LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK. LWORK .GE. max(1,N)
// * is sufficient, but LWORK typically as large as 6*N may
// * be required for optimal performance. A workspace query
// * to determine the optimal workspace size is recommended.
// *
// * If LWORK = -1, then DLAQR0 does a workspace query.
// * In this case, DLAQR0 checks the input parameters and
// * estimates the optimal workspace size for the given
// * values of N, ILO and IHI. The estimate is returned
// * in WORK(1). No error message related to LWORK is
// * issued by XERBLA. Neither H nor Z are accessed.
// *
// *
// * INFO (output) INTEGER
// * = 0: successful exit
// * .GT. 0: if INFO = i, DLAQR0 failed to compute all of
// * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
// * and WI contain those eigenvalues which have been
// * successfully computed. (Failures are rare.)
// *
// * If INFO .GT. 0 and WANT is .FALSE., then on exit,
// * the remaining unconverged eigenvalues are the eigen-
// * values of the upper Hessenberg matrix rows and
// * columns ILO through INFO of the final, output
// * value of H.
// *
// * If INFO .GT. 0 and WANTT is .TRUE., then on exit
// *
// * (*) (initial value of H)*U = U*(final value of H)
// *
// * where U is an orthogonal matrix. The final
// * value of H is upper Hessenberg and quasi-triangular
// * in rows and columns INFO+1 through IHI.
// *
// * If INFO .GT. 0 and WANTZ is .TRUE., then on exit
// *
// * (final value of Z(ILO:IHI,ILOZ:IHIZ)
// * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
// *
// * where U is the orthogonal matrix in (*) (regard-
// * less of the value of WANTT.)
// *
// * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
// * accessed.
// *
// *
// * ================================================================
// * Based on contributions by
// * Karen Braman and Ralph Byers, Department of Mathematics,
// * University of Kansas, USA
// *
// * ================================================================
// *
// * References:
// * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
// * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
// * Performance, SIAM Journal of Matrix Analysis, volume 23, pages
// * 929--947, 2002.
// *
// * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
// * Algorithm Part II: Aggressive Early Deflation, SIAM Journal
// * of Matrix Analysis, volume 23, pages 948--973, 2002.
// *
// * ================================================================
// * .. Parameters ..
// *
// * ==== Matrices of order NTINY or smaller must be processed by
// * . DLAHQR because of insufficient subdiagonal scratch space.
// * . (This is a hard limit.) ====
// *
// * ==== Exceptional deflation windows: try to cure rare
// * . slow convergence by increasing the size of the
// * . deflation window after KEXNW iterations. =====
// *
// * ==== Exceptional shifts: try to cure rare slow convergence
// * . with ad-hoc exceptional shifts every KEXSH iterations.
// * . The constants WILK1 and WILK2 are used to form the
// * . exceptional shifts. ====
// *
// * ..
// * .. Local Scalars ..
// * ..
// * .. External Functions ..
// * ..
// * .. Local Arrays ..
// * ..
// * .. External Subroutines ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD;
// * ..
// * .. Executable Statements ..
#endregion
#region Body
INFO = 0;
// *
// * ==== Quick return for N = 0: nothing to do. ====
// *
if (N == 0)
{
WORK[1 + o_work] = ONE;
return;
}
// *
// * ==== Set up job flags for ILAENV. ====
// *
if (WANTT)
{
FortranLib.Copy(ref JBCMPZ, 1, 1, "S");
}
else
{
FortranLib.Copy(ref JBCMPZ, 1, 1, "E");
}
if (WANTZ)
{
FortranLib.Copy(ref JBCMPZ, 2, 2, "V");
}
else
{
FortranLib.Copy(ref JBCMPZ, 2, 2, "N");
}
// *
// * ==== Tiny matrices must use DLAHQR. ====
// *
if (N <= NTINY)
{
// *
// * ==== Estimate optimal workspace. ====
// *
LWKOPT = 1;
if (LWORK != -1)
{
this._dlahqr.Run(WANTT, WANTZ, N, ILO, IHI, ref H, offset_h
, LDH, ref WR, offset_wr, ref WI, offset_wi, ILOZ, IHIZ, ref Z, offset_z
, LDZ, ref INFO);
}
}
else
{
// *
// * ==== Use small bulge multi-shift QR with aggressive early
// * . deflation on larger-than-tiny matrices. ====
// *
// * ==== Hope for the best. ====
// *
INFO = 0;
// *
// * ==== NWR = recommended deflation window size. At this
// * . point, N .GT. NTINY = 11, so there is enough
// * . subdiagonal workspace for NWR.GE.2 as required.
// * . (In fact, there is enough subdiagonal space for
// * . NWR.GE.3.) ====
// *
NWR = this._ilaenv.Run(13, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NWR = Math.Max(2, NWR);
NWR = Math.Min(IHI - ILO + 1, Math.Min((N - 1) / 3, NWR));
NW = NWR;
// *
// * ==== NSR = recommended number of simultaneous shifts.
// * . At this point N .GT. NTINY = 11, so there is at
// * . enough subdiagonal workspace for NSR to be even
// * . and greater than or equal to two as required. ====
// *
NSR = this._ilaenv.Run(15, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NSR = Math.Min(NSR, Math.Min((N + 6) / 9, IHI - ILO));
NSR = Math.Max(2, NSR - FortranLib.Mod(NSR, 2));
// *
// * ==== Estimate optimal workspace ====
// *
// * ==== Workspace query call to DLAQR3 ====
// *
this._dlaqr3.Run(WANTT, WANTZ, N, ILO, IHI, NWR + 1
, ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ
, ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, offset_h, LDH
, N, ref H, offset_h, LDH, N, ref H, offset_h, LDH
, ref WORK, offset_work, -1);
// *
// * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
// *
LWKOPT = Math.Max(3 * NSR / 2, Convert.ToInt32(Math.Truncate(WORK[1 + o_work])));
// *
// * ==== Quick return in case of workspace query. ====
// *
if (LWORK == -1)
{
WORK[1 + o_work] = Convert.ToDouble(LWKOPT);
return;
}
// *
// * ==== DLAHQR/DLAQR0 crossover point ====
// *
NMIN = this._ilaenv.Run(12, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NMIN = Math.Max(NTINY, NMIN);
// *
// * ==== Nibble crossover point ====
// *
NIBBLE = this._ilaenv.Run(14, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
NIBBLE = Math.Max(0, NIBBLE);
// *
// * ==== Accumulate reflections during ttswp? Use block
// * . 2-by-2 structure during matrix-matrix multiply? ====
// *
KACC22 = this._ilaenv.Run(16, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK);
KACC22 = Math.Max(0, KACC22);
KACC22 = Math.Min(2, KACC22);
// *
// * ==== NWMAX = the largest possible deflation window for
// * . which there is sufficient workspace. ====
// *
NWMAX = Math.Min((N - 1) / 3, LWORK / 2);
// *
// * ==== NSMAX = the Largest number of simultaneous shifts
// * . for which there is sufficient workspace. ====
// *
NSMAX = Math.Min((N + 6) / 9, 2 * LWORK / 3);
NSMAX -= FortranLib.Mod(NSMAX, 2);
// *
// * ==== NDFL: an iteration count restarted at deflation. ====
// *
NDFL = 1;
// *
// * ==== ITMAX = iteration limit ====
// *
ITMAX = Math.Max(30, 2 * KEXSH) * Math.Max(10, (IHI - ILO + 1));
// *
// * ==== Last row and column in the active block ====
// *
KBOT = IHI;
// *
// * ==== Main Loop ====
// *
for (IT = 1; IT <= ITMAX; IT++)
{
// *
// * ==== Done when KBOT falls below ILO ====
// *
if (KBOT < ILO)
{
goto LABEL90;
}
// *
// * ==== Locate active block ====
// *
for (K = KBOT; K >= ILO + 1; K += -1)
{
if (H[K + (K - 1) * LDH + o_h] == ZERO)
{
goto LABEL20;
}
}
K = ILO;
LABEL20 :;
KTOP = K;
// *
// * ==== Select deflation window size ====
// *
NH = KBOT - KTOP + 1;
if (NDFL < KEXNW || NH < NW)
{
// *
// * ==== Typical deflation window. If possible and
// * . advisable, nibble the entire active block.
// * . If not, use size NWR or NWR+1 depending upon
// * . which has the smaller corresponding subdiagonal
// * . entry (a heuristic). ====
// *
NWINC = true;
if (NH <= Math.Min(NMIN, NWMAX))
{
NW = NH;
}
else
{
NW = Math.Min(NWR, Math.Min(NH, NWMAX));
if (NW < NWMAX)
{
if (NW >= NH - 1)
{
NW = NH;
}
else
{
KWTOP = KBOT - NW + 1;
if (Math.Abs(H[KWTOP + (KWTOP - 1) * LDH + o_h]) > Math.Abs(H[KWTOP - 1 + (KWTOP - 2) * LDH + o_h]))
{
NW += 1;
}
}
}
}
}
else
{
// *
// * ==== Exceptional deflation window. If there have
// * . been no deflations in KEXNW or more iterations,
// * . then vary the deflation window size. At first,
// * . because, larger windows are, in general, more
// * . powerful than smaller ones, rapidly increase the
// * . window up to the maximum reasonable and possible.
// * . Then maybe try a slightly smaller window. ====
// *
if (NWINC && NW < Math.Min(NWMAX, NH))
{
NW = Math.Min(NWMAX, Math.Min(NH, 2 * NW));
}
else
{
NWINC = false;
if (NW == NH && NH > 2)
{
NW = NH - 1;
}
}
}
// *
// * ==== Aggressive early deflation:
// * . split workspace under the subdiagonal into
// * . - an nw-by-nw work array V in the lower
// * . left-hand-corner,
// * . - an NW-by-at-least-NW-but-more-is-better
// * . (NW-by-NHO) horizontal work array along
// * . the bottom edge,
// * . - an at-least-NW-but-more-is-better (NHV-by-NW)
// * . vertical work array along the left-hand-edge.
// * . ====
// *
KV = N - NW + 1;
KT = NW + 1;
NHO = (N - NW - 1) - KT + 1;
KWV = NW + 2;
NVE = (N - NW) - KWV + 1;
// *
// * ==== Aggressive early deflation ====
// *
this._dlaqr3.Run(WANTT, WANTZ, N, KTOP, KBOT, NW
, ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ
, ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, KV + 1 * LDH + o_h, LDH
, NHO, ref H, KV + KT * LDH + o_h, LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH
, ref WORK, offset_work, LWORK);
// *
// * ==== Adjust KBOT accounting for new deflations. ====
// *
KBOT -= LD;
// *
// * ==== KS points to the shifts. ====
// *
KS = KBOT - LS + 1;
// *
// * ==== Skip an expensive QR sweep if there is a (partly
// * . heuristic) reason to expect that many eigenvalues
// * . will deflate without it. Here, the QR sweep is
// * . skipped if many eigenvalues have just been deflated
// * . or if the remaining active block is small.
// *
if ((LD == 0) || ((100 * LD <= NW * NIBBLE) && (KBOT - KTOP + 1 > Math.Min(NMIN, NWMAX))))
{
// *
// * ==== NS = nominal number of simultaneous shifts.
// * . This may be lowered (slightly) if DLAQR3
// * . did not provide that many shifts. ====
// *
NS = Math.Min(NSMAX, Math.Min(NSR, Math.Max(2, KBOT - KTOP)));
NS -= FortranLib.Mod(NS, 2);
// *
// * ==== If there have been no deflations
// * . in a multiple of KEXSH iterations,
// * . then try exceptional shifts.
// * . Otherwise use shifts provided by
// * . DLAQR3 above or from the eigenvalues
// * . of a trailing principal submatrix. ====
// *
if (FortranLib.Mod(NDFL, KEXSH) == 0)
{
KS = KBOT - NS + 1;
for (I = KBOT; I >= Math.Max(KS + 1, KTOP + 2); I += -2)
{
SS = Math.Abs(H[I + (I - 1) * LDH + o_h]) + Math.Abs(H[I - 1 + (I - 2) * LDH + o_h]);
AA = WILK1 * SS + H[I + I * LDH + o_h];
BB = SS;
CC = WILK2 * SS;
DD = AA;
this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[I - 1 + o_wr], ref WI[I - 1 + o_wi]
, ref WR[I + o_wr], ref WI[I + o_wi], ref CS, ref SN);
}
if (KS == KTOP)
{
WR[KS + 1 + o_wr] = H[KS + 1 + (KS + 1) * LDH + o_h];
WI[KS + 1 + o_wi] = ZERO;
WR[KS + o_wr] = WR[KS + 1 + o_wr];
WI[KS + o_wi] = WI[KS + 1 + o_wi];
}
}
else
{
// *
// * ==== Got NS/2 or fewer shifts? Use DLAQR4 or
// * . DLAHQR on a trailing principal submatrix to
// * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
// * . there is enough space below the subdiagonal
// * . to fit an NS-by-NS scratch array.) ====
// *
if (KBOT - KS + 1 <= NS / 2)
{
KS = KBOT - NS + 1;
KT = N - NS + 1;
this._dlacpy.Run("A", NS, NS, H, KS + KS * LDH + o_h, LDH, ref H, KT + 1 * LDH + o_h
, LDH);
if (NS > NMIN)
{
this._dlaqr4.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h
, LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum
, 1, ref WORK, offset_work, LWORK, ref INF);
}
else
{
this._dlahqr.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h
, LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum
, 1, ref INF);
}
KS += INF;
// *
// * ==== In case of a rare QR failure use
// * . eigenvalues of the trailing 2-by-2
// * . principal submatrix. ====
// *
if (KS >= KBOT)
{
AA = H[KBOT - 1 + (KBOT - 1) * LDH + o_h];
CC = H[KBOT + (KBOT - 1) * LDH + o_h];
BB = H[KBOT - 1 + KBOT * LDH + o_h];
DD = H[KBOT + KBOT * LDH + o_h];
this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[KBOT - 1 + o_wr], ref WI[KBOT - 1 + o_wi]
, ref WR[KBOT + o_wr], ref WI[KBOT + o_wi], ref CS, ref SN);
KS = KBOT - 1;
}
}
// *
if (KBOT - KS + 1 > NS)
{
// *
// * ==== Sort the shifts (Helps a little)
// * . Bubble sort keeps complex conjugate
// * . pairs together. ====
// *
SORTED = false;
for (K = KBOT; K >= KS + 1; K += -1)
{
if (SORTED)
{
goto LABEL60;
}
SORTED = true;
for (I = KS; I <= K - 1; I++)
{
if (Math.Abs(WR[I + o_wr]) + Math.Abs(WI[I + o_wi]) < Math.Abs(WR[I + 1 + o_wr]) + Math.Abs(WI[I + 1 + o_wi]))
{
SORTED = false;
// *
SWAP = WR[I + o_wr];
WR[I + o_wr] = WR[I + 1 + o_wr];
WR[I + 1 + o_wr] = SWAP;
// *
SWAP = WI[I + o_wi];
WI[I + o_wi] = WI[I + 1 + o_wi];
WI[I + 1 + o_wi] = SWAP;
}
}
}
LABEL60 :;
}
// *
// * ==== Shuffle shifts into pairs of real shifts
// * . and pairs of complex conjugate shifts
// * . assuming complex conjugate shifts are
// * . already adjacent to one another. (Yes,
// * . they are.) ====
// *
for (I = KBOT; I >= KS + 2; I += -2)
{
if (WI[I + o_wi] != -WI[I - 1 + o_wi])
{
// *
SWAP = WR[I + o_wr];
WR[I + o_wr] = WR[I - 1 + o_wr];
WR[I - 1 + o_wr] = WR[I - 2 + o_wr];
WR[I - 2 + o_wr] = SWAP;
// *
SWAP = WI[I + o_wi];
WI[I + o_wi] = WI[I - 1 + o_wi];
WI[I - 1 + o_wi] = WI[I - 2 + o_wi];
WI[I - 2 + o_wi] = SWAP;
}
}
}
// *
// * ==== If there are only two shifts and both are
// * . real, then use only one. ====
// *
if (KBOT - KS + 1 == 2)
{
if (WI[KBOT + o_wi] == ZERO)
{
if (Math.Abs(WR[KBOT + o_wr] - H[KBOT + KBOT * LDH + o_h]) < Math.Abs(WR[KBOT - 1 + o_wr] - H[KBOT + KBOT * LDH + o_h]))
{
WR[KBOT - 1 + o_wr] = WR[KBOT + o_wr];
}
else
{
WR[KBOT + o_wr] = WR[KBOT - 1 + o_wr];
}
}
}
// *
// * ==== Use up to NS of the the smallest magnatiude
// * . shifts. If there aren't NS shifts available,
// * . then use them all, possibly dropping one to
// * . make the number of shifts even. ====
// *
NS = Math.Min(NS, KBOT - KS + 1);
NS -= FortranLib.Mod(NS, 2);
KS = KBOT - NS + 1;
// *
// * ==== Small-bulge multi-shift QR sweep:
// * . split workspace under the subdiagonal into
// * . - a KDU-by-KDU work array U in the lower
// * . left-hand-corner,
// * . - a KDU-by-at-least-KDU-but-more-is-better
// * . (KDU-by-NHo) horizontal work array WH along
// * . the bottom edge,
// * . - and an at-least-KDU-but-more-is-better-by-KDU
// * . (NVE-by-KDU) vertical work WV arrow along
// * . the left-hand-edge. ====
// *
KDU = 3 * NS - 3;
KU = N - KDU + 1;
KWH = KDU + 1;
NHO = (N - KDU + 1 - 4) - (KDU + 1) + 1;
KWV = KDU + 4;
NVE = N - KDU - KWV + 1;
// *
// * ==== Small-bulge multi-shift QR sweep ====
// *
this._dlaqr5.Run(WANTT, WANTZ, KACC22, N, KTOP, KBOT
, NS, ref WR, KS + o_wr, ref WI, KS + o_wi, ref H, offset_h, LDH, ILOZ
, IHIZ, ref Z, offset_z, LDZ, ref WORK, offset_work, 3, ref H, KU + 1 * LDH + o_h
, LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH, NHO, ref H, KU + KWH * LDH + o_h
, LDH);
}
// *
// * ==== Note progress (or the lack of it). ====
// *
if (LD > 0)
{
NDFL = 1;
}
else
{
NDFL += 1;
}
// *
// * ==== End of main loop ====
}
// *
// * ==== Iteration limit exceeded. Set INFO to show where
// * . the problem occurred and exit. ====
// *
INFO = KBOT;
LABEL90 :;
}
// *
// * ==== Return the optimal value of LWORK. ====
// *
WORK[1 + o_work] = Convert.ToDouble(LWKOPT);
// *
// * ==== End of DLAQR0 ====
// *
#endregion
}
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
}
public double Run(int N, double[] DX, int offset_dx, int INCX, double[] DY, int offset_dy, int INCY)
{
double ddot = 0;
#region Variables
double DTEMP = 0; int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy;
#endregion
// c
// c forms the dot product of two vectors.
// c uses unrolled loops for increments equal to one.
// c jack dongarra, linpack, 3/11/78.
// c
// c
#region Body
ddot = 0.0E0;
DTEMP = 0.0E0;
if (N <= 0)
{
return(ddot);
}
if (INCX == 1 && INCY == 1)
{
goto LABEL20;
}
// c
// c code for unequal increments or equal increments
// c not equal to 1
// c
IX = 1;
IY = 1;
if (INCX < 0)
{
IX = (-N + 1) * INCX + 1;
}
if (INCY < 0)
{
IY = (-N + 1) * INCY + 1;
}
for (I = 1; I <= N; I++)
{
DTEMP += DX[IX + o_dx] * DY[IY + o_dy];
IX += INCX;
IY += INCY;
}
ddot = DTEMP;
return(ddot);
// c
// c code for both increments equal to 1
// c
// c
// c clean-up loop
// c
LABEL20 : M = FortranLib.Mod(N, 5);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DTEMP += DX[I + o_dx] * DY[I + o_dy];
}
if (N < 5)
{
goto LABEL60;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 5)
{
DTEMP += DX[I + o_dx] * DY[I + o_dy] + DX[I + 1 + o_dx] * DY[I + 1 + o_dy] + DX[I + 2 + o_dx] * DY[I + 2 + o_dy] + DX[I + 3 + o_dx] * DY[I + 3 + o_dy] + DX[I + 4 + o_dx] * DY[I + 4 + o_dy];
}
LABEL60 : ddot = DTEMP;
return(ddot);
#endregion
}
public void Run(int N, double DA, double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY)
{
#region Variables
int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy;
#endregion
// c
// c constant times a vector plus a vector.
// c uses unrolled loops for increments equal to one.
// c jack dongarra, linpack, 3/11/78.
// c
// c
#region Body
if (N <= 0)
{
return;
}
if (DA == 0.0E0)
{
return;
}
if (INCX == 1 && INCY == 1)
{
goto LABEL20;
}
// c
// c code for unequal increments or equal increments
// c not equal to 1
// c
IX = 1;
IY = 1;
if (INCX < 0)
{
IX = (-N + 1) * INCX + 1;
}
if (INCY < 0)
{
IY = (-N + 1) * INCY + 1;
}
for (I = 1; I <= N; I++)
{
DY[IY + o_dy] += DA * DX[IX + o_dx];
IX += INCX;
IY += INCY;
}
return;
// c
// c code for both increments equal to 1
// c
// c
// c clean-up loop
// c
LABEL20 : M = FortranLib.Mod(N, 4);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DY[I + o_dy] += DA * DX[I + o_dx];
}
if (N < 4)
{
return;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 4)
{
DY[I + o_dy] += DA * DX[I + o_dx];
DY[I + 1 + o_dy] += DA * DX[I + 1 + o_dx];
DY[I + 2 + o_dy] += DA * DX[I + 2 + o_dx];
DY[I + 3 + o_dy] += DA * DX[I + 3 + o_dx];
}
return;
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// ILAENV is called from the LAPACK routines to choose problem-dependent
/// parameters for the local environment. See ISPEC for a description of
/// the parameters.
///
/// ILAENV returns an INTEGER
/// if ILAENV .GE. 0: ILAENV returns the value of the parameter specified by ISPEC
/// if ILAENV .LT. 0: if ILAENV = -k, the k-th argument had an illegal value.
///
/// This version provides a set of parameters which should give good,
/// but not optimal, performance on many of the currently available
/// computers. Users are encouraged to modify this subroutine to set
/// the tuning parameters for their particular machine using the option
/// and problem size information in the arguments.
///
/// This routine will not function correctly if it is converted to all
/// lower case. Converting it to all upper case is allowed.
///
///</summary>
/// <param name="ISPEC">
/// (input) INTEGER
/// Specifies the parameter to be returned as the value of
/// ILAENV.
/// = 1: the optimal blocksize; if this value is 1, an unblocked
/// algorithm will give the best performance.
/// = 2: the minimum block size for which the block routine
/// should be used; if the usable block size is less than
/// this value, an unblocked routine should be used.
/// = 3: the crossover point (in a block routine, for N less
/// than this value, an unblocked routine should be used)
/// = 4: the number of shifts, used in the nonsymmetric
/// eigenvalue routines (DEPRECATED)
/// = 5: the minimum column dimension for blocking to be used;
/// rectangular blocks must have dimension at least k by m,
/// where k is given by ILAENV(2,...) and m by ILAENV(5,...)
/// = 6: the crossover point for the SVD (when reducing an m by n
/// matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
/// this value, a QR factorization is used first to reduce
/// the matrix to a triangular form.)
/// = 7: the number of processors
/// = 8: the crossover point for the multishift QR method
/// for nonsymmetric eigenvalue problems (DEPRECATED)
/// = 9: maximum size of the subproblems at the bottom of the
/// computation tree in the divide-and-conquer algorithm
/// (used by xGELSD and xGESDD)
/// =10: ieee NaN arithmetic can be trusted not to trap
/// =11: infinity arithmetic can be trusted not to trap
/// 12 .LE. ISPEC .LE. 16:
/// xHSEQR or one of its subroutines,
/// see IPARMQ for detailed explanation
///</param>
/// <param name="NAME">
/// (input) CHARACTER*(*)
/// The name of the calling subroutine, in either upper case or
/// lower case.
///</param>
/// <param name="OPTS">
/// (input) CHARACTER*(*)
/// The character options to the subroutine NAME, concatenated
/// into a single character string. For example, UPLO = 'U',
/// TRANS = 'T', and DIAG = 'N' for a triangular routine would
/// be specified as OPTS = 'UTN'.
///</param>
/// <param name="N1">
/// (input) INTEGER
///</param>
/// <param name="N2">
/// (input) INTEGER
///</param>
/// <param name="N3">
/// (input) INTEGER
///</param>
/// <param name="N4">
/// (input) INTEGER
/// Problem dimensions for the subroutine NAME; these may not all
/// be required.
///</param>
public int Run(int ISPEC, string NAME, string OPTS, int N1, int N2, int N3
, int N4)
{
int ilaenv = 0;
#region Variables
int I = 0; int IC = 0; int IZ = 0; int NB = 0; int NBMIN = 0; int NX = 0; bool CNAME = false; bool SNAME = false;
string C1 = new string(' ', 1); string C2 = new string(' ', 2); string C4 = new string(' ', 2);
string C3 = new string(' ', 3); string SUBNAM = new string(' ', 6);
#endregion
#region Prolog
// *
// * -- LAPACK auxiliary routine (version 3.1.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * January 2007
// *
// * .. Scalar Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * ILAENV is called from the LAPACK routines to choose problem-dependent
// * parameters for the local environment. See ISPEC for a description of
// * the parameters.
// *
// * ILAENV returns an INTEGER
// * if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
// * if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
// *
// * This version provides a set of parameters which should give good,
// * but not optimal, performance on many of the currently available
// * computers. Users are encouraged to modify this subroutine to set
// * the tuning parameters for their particular machine using the option
// * and problem size information in the arguments.
// *
// * This routine will not function correctly if it is converted to all
// * lower case. Converting it to all upper case is allowed.
// *
// * Arguments
// * =========
// *
// * ISPEC (input) INTEGER
// * Specifies the parameter to be returned as the value of
// * ILAENV.
// * = 1: the optimal blocksize; if this value is 1, an unblocked
// * algorithm will give the best performance.
// * = 2: the minimum block size for which the block routine
// * should be used; if the usable block size is less than
// * this value, an unblocked routine should be used.
// * = 3: the crossover point (in a block routine, for N less
// * than this value, an unblocked routine should be used)
// * = 4: the number of shifts, used in the nonsymmetric
// * eigenvalue routines (DEPRECATED)
// * = 5: the minimum column dimension for blocking to be used;
// * rectangular blocks must have dimension at least k by m,
// * where k is given by ILAENV(2,...) and m by ILAENV(5,...)
// * = 6: the crossover point for the SVD (when reducing an m by n
// * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
// * this value, a QR factorization is used first to reduce
// * the matrix to a triangular form.)
// * = 7: the number of processors
// * = 8: the crossover point for the multishift QR method
// * for nonsymmetric eigenvalue problems (DEPRECATED)
// * = 9: maximum size of the subproblems at the bottom of the
// * computation tree in the divide-and-conquer algorithm
// * (used by xGELSD and xGESDD)
// * =10: ieee NaN arithmetic can be trusted not to trap
// * =11: infinity arithmetic can be trusted not to trap
// * 12 <= ISPEC <= 16:
// * xHSEQR or one of its subroutines,
// * see IPARMQ for detailed explanation
// *
// * NAME (input) CHARACTER*(*)
// * The name of the calling subroutine, in either upper case or
// * lower case.
// *
// * OPTS (input) CHARACTER*(*)
// * The character options to the subroutine NAME, concatenated
// * into a single character string. For example, UPLO = 'U',
// * TRANS = 'T', and DIAG = 'N' for a triangular routine would
// * be specified as OPTS = 'UTN'.
// *
// * N1 (input) INTEGER
// * N2 (input) INTEGER
// * N3 (input) INTEGER
// * N4 (input) INTEGER
// * Problem dimensions for the subroutine NAME; these may not all
// * be required.
// *
// * Further Details
// * ===============
// *
// * The following conventions have been used when calling ILAENV from the
// * LAPACK routines:
// * 1) OPTS is a concatenation of all of the character options to
// * subroutine NAME, in the same order that they appear in the
// * argument list for NAME, even if they are not used in determining
// * the value of the parameter specified by ISPEC.
// * 2) The problem dimensions N1, N2, N3, N4 are specified in the order
// * that they appear in the argument list for NAME. N1 is used
// * first, N2 second, and so on, and unused problem dimensions are
// * passed a value of -1.
// * 3) The parameter value returned by ILAENV is checked for validity in
// * the calling subroutine. For example, ILAENV is used to retrieve
// * the optimal blocksize for STRTRI as follows:
// *
// * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
// * IF( NB.LE.1 ) NB = MAX( 1, N )
// *
// * =====================================================================
// *
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC CHAR, ICHAR, INT, MIN, REAL;
// * ..
// * .. External Functions ..
// * ..
// * .. Executable Statements ..
// *
#endregion
#region Body
switch (ISPEC)
{
case 1: goto LABEL10;
case 2: goto LABEL10;
case 3: goto LABEL10;
case 4: goto LABEL80;
case 5: goto LABEL90;
case 6: goto LABEL100;
case 7: goto LABEL110;
case 8: goto LABEL120;
case 9: goto LABEL130;
case 10: goto LABEL140;
case 11: goto LABEL150;
case 12: goto LABEL160;
case 13: goto LABEL160;
case 14: goto LABEL160;
case 15: goto LABEL160;
case 16: goto LABEL160;
}
// *
// * Invalid value for ISPEC
// *
ilaenv = -1;
return(ilaenv);
// *
LABEL10 :;
// *
// * Convert NAME to upper case if the first character is lower case.
// *
ilaenv = 1;
FortranLib.Copy(ref SUBNAM, NAME);
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, 1, 1)));
IZ = Convert.ToInt32('Z');
if (IZ == 90 || IZ == 122)
{
// *
// * ASCII character set
// *
if (IC >= 97 && IC <= 122)
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if (IC >= 97 && IC <= 122)
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32));
}
}
}
// *
}
else
{
if (IZ == 233 || IZ == 169)
{
// *
// * EBCDIC character set
// *
if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169))
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC + 64));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169))
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC + 64));
}
}
}
// *
}
else
{
if (IZ == 218 || IZ == 250)
{
// *
// * Prime machines: ASCII+128
// *
if (IC >= 225 && IC <= 250)
{
FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32));
for (I = 2; I <= 6; I++)
{
IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I)));
if (IC >= 225 && IC <= 250)
{
FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32));
}
}
}
}
}
}
// *
FortranLib.Copy(ref C1, FortranLib.Substring(SUBNAM, 1, 1));
SNAME = C1 == "S" || C1 == "D";
CNAME = C1 == "C" || C1 == "Z";
if (!(CNAME || SNAME))
{
return(ilaenv);
}
FortranLib.Copy(ref C2, FortranLib.Substring(SUBNAM, 2, 3));
FortranLib.Copy(ref C3, FortranLib.Substring(SUBNAM, 4, 6));
FortranLib.Copy(ref C4, FortranLib.Substring(C3, 2, 3));
// *
switch (ISPEC)
{
case 1: goto LABEL50;
case 2: goto LABEL60;
case 3: goto LABEL70;
}
// *
LABEL50 :;
// *
// * ISPEC = 1: block size
// *
// * In these examples, separate code is provided for setting NB for
// * real and complex. We assume that NB will take the same value in
// * single or double precision.
// *
NB = 1;
// *
if (C2 == "GE")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
else
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NB = 32;
}
else
{
NB = 32;
}
}
else
{
if (C3 == "TRI")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
}
}
}
}
else
{
if (C2 == "PO")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (C2 == "SY")
{
if (C3 == "TRF")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
else
{
if (SNAME && C3 == "TRD")
{
NB = 32;
}
else
{
if (SNAME && C3 == "GST")
{
NB = 64;
}
}
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRF")
{
NB = 64;
}
else
{
if (C3 == "TRD")
{
NB = 32;
}
else
{
if (C3 == "GST")
{
NB = 64;
}
}
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NB = 32;
}
}
}
}
else
{
if (C2 == "GB")
{
if (C3 == "TRF")
{
if (SNAME)
{
if (N4 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
else
{
if (N4 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
}
}
else
{
if (C2 == "PB")
{
if (C3 == "TRF")
{
if (SNAME)
{
if (N2 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
else
{
if (N2 <= 64)
{
NB = 1;
}
else
{
NB = 32;
}
}
}
}
else
{
if (C2 == "TR")
{
if (C3 == "TRI")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (C2 == "LA")
{
if (C3 == "UUM")
{
if (SNAME)
{
NB = 64;
}
else
{
NB = 64;
}
}
}
else
{
if (SNAME && C2 == "ST")
{
if (C3 == "EBZ")
{
NB = 1;
}
}
}
}
}
}
}
}
}
}
}
}
ilaenv = NB;
return(ilaenv);
// *
LABEL60 :;
// *
// * ISPEC = 2: minimum block size
// *
NBMIN = 2;
if (C2 == "GE")
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
else
{
if (C3 == "TRI")
{
if (SNAME)
{
NBMIN = 2;
}
else
{
NBMIN = 2;
}
}
}
}
}
}
else
{
if (C2 == "SY")
{
if (C3 == "TRF")
{
if (SNAME)
{
NBMIN = 8;
}
else
{
NBMIN = 8;
}
}
else
{
if (SNAME && C3 == "TRD")
{
NBMIN = 2;
}
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRD")
{
NBMIN = 2;
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
else
{
if (FortranLib.Substring(C3, 1, 1) == "M")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NBMIN = 2;
}
}
}
}
}
}
}
}
ilaenv = NBMIN;
return(ilaenv);
// *
LABEL70 :;
// *
// * ISPEC = 3: crossover point
// *
NX = 0;
if (C2 == "GE")
{
if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
else
{
if (C3 == "HRD")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
else
{
if (C3 == "BRD")
{
if (SNAME)
{
NX = 128;
}
else
{
NX = 128;
}
}
}
}
}
else
{
if (C2 == "SY")
{
if (SNAME && C3 == "TRD")
{
NX = 32;
}
}
else
{
if (CNAME && C2 == "HE")
{
if (C3 == "TRD")
{
NX = 32;
}
}
else
{
if (SNAME && C2 == "OR")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NX = 128;
}
}
}
else
{
if (CNAME && C2 == "UN")
{
if (FortranLib.Substring(C3, 1, 1) == "G")
{
if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR")
{
NX = 128;
}
}
}
}
}
}
}
ilaenv = NX;
return(ilaenv);
// *
LABEL80 :;
// *
// * ISPEC = 4: number of shifts (used by xHSEQR)
// *
ilaenv = 6;
return(ilaenv);
// *
LABEL90 :;
// *
// * ISPEC = 5: minimum column dimension (not used)
// *
ilaenv = 2;
return(ilaenv);
// *
LABEL100 :;
// *
// * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
// *
ilaenv = Convert.ToInt32(Math.Truncate(Convert.ToSingle(Math.Min(N1, N2)) * 1.6E0));
return(ilaenv);
// *
LABEL110 :;
// *
// * ISPEC = 7: number of processors (not used)
// *
ilaenv = 1;
return(ilaenv);
// *
LABEL120 :;
// *
// * ISPEC = 8: crossover point for multishift (used by xHSEQR)
// *
ilaenv = 50;
return(ilaenv);
// *
LABEL130 :;
// *
// * ISPEC = 9: maximum size of the subproblems at the bottom of the
// * computation tree in the divide-and-conquer algorithm
// * (used by xGELSD and xGESDD)
// *
ilaenv = 25;
return(ilaenv);
// *
LABEL140 :;
// *
// * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
// *
// * ILAENV = 0
ilaenv = 1;
if (ilaenv == 1)
{
ilaenv = this._ieeeck.Run(0, 0.0, 1.0);
}
return(ilaenv);
// *
LABEL150 :;
// *
// * ISPEC = 11: infinity arithmetic can be trusted not to trap
// *
// * ILAENV = 0
ilaenv = 1;
if (ilaenv == 1)
{
ilaenv = this._ieeeck.Run(1, 0.0, 1.0);
}
return(ilaenv);
// *
LABEL160 :;
// *
// * 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
// *
ilaenv = this._iparmq.Run(ISPEC, NAME, OPTS, N1, N2, N3, N4);
return(ilaenv);
// *
// * End of ILAENV
// *
#endregion
}
/// <summary>
/// Purpose
/// =======
/// *
/// scales a vector by a constant.
/// uses unrolled loops for increment equal to one.
/// jack dongarra, linpack, 3/11/78.
/// modified 3/93 to return if incx .le. 0.
/// modified 12/3/93, array(1) declarations changed to array(*)
///</summary>
public void Run(int N, double DA, ref double[] DX, int offset_dx, int INCX)
{
#region Variables
int I = 0; int M = 0; int MP1 = 0; int NINCX = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx;
#endregion
#region Prolog
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// **
// * scales a vector by a constant.
// * uses unrolled loops for increment equal to one.
// * jack dongarra, linpack, 3/11/78.
// * modified 3/93 to return if incx .le. 0.
// * modified 12/3/93, array(1) declarations changed to array(*)
// *
// *
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MOD;
// * ..
#endregion
#region Body
if (N <= 0 || INCX <= 0)
{
return;
}
if (INCX == 1)
{
goto LABEL20;
}
// *
// * code for increment not equal to 1
// *
NINCX = N * INCX;
for (I = 1; (INCX >= 0) ? (I <= NINCX) : (I >= NINCX); I += INCX)
{
DX[I + o_dx] *= DA;
}
return;
// *
// * code for increment equal to 1
// *
// *
// * clean-up loop
// *
LABEL20 : M = FortranLib.Mod(N, 5);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DX[I + o_dx] *= DA;
}
if (N < 5)
{
return;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 5)
{
DX[I + o_dx] *= DA;
DX[I + 1 + o_dx] *= DA;
DX[I + 2 + o_dx] *= DA;
DX[I + 3 + o_dx] *= DA;
DX[I + 4 + o_dx] *= DA;
}
return;
#endregion
}
public void Run(int N, int M, ref double[] WS, int offset_ws, ref double[] WY, int offset_wy, ref double[] SY, int offset_sy, ref double[] SS, int offset_ss
, double[] D, int offset_d, double[] R, int offset_r, ref int ITAIL, int IUPDAT, ref int COL, ref int HEAD
, ref double THETA, double RR, double DR, double STP, double DTD)
{
#region Variables
int J = 0; int POINTR = 0; double DDOT = 0;
#endregion
#region Implicit Variables
int SS_COL = 0;
#endregion
#region Array Index Correction
int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy; int o_sy = -1 - M + offset_sy;
int o_ss = -1 - M + offset_ss; int o_d = -1 + offset_d; int o_r = -1 + offset_r;
#endregion
#region Prolog
// c ************
// c
// c Subroutine matupd
// c
// c This subroutine updates matrices WS and WY, and forms the
// c middle matrix in B.
// c
// c Subprograms called:
// c
// c Linpack ... dcopy, ddot.
// c
// c
// c * * *
// c
// c NEOS, November 1994. (Latest revision June 1996.)
// c Optimization Technology Center.
// c Argonne National Laboratory and Northwestern University.
// c Written by
// c Ciyou Zhu
// c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
// c
// c
// c ************
// c Set pointers for matrices WS and WY.
#endregion
#region Body
if (IUPDAT <= M)
{
COL = IUPDAT;
ITAIL = FortranLib.Mod(HEAD + IUPDAT - 2, M) + 1;
}
else
{
ITAIL = FortranLib.Mod(ITAIL, M) + 1;
HEAD = FortranLib.Mod(HEAD, M) + 1;
}
// c Update matrices WS and WY.
this._dcopy.Run(N, D, offset_d, 1, ref WS, 1 + ITAIL * N + o_ws, 1);
this._dcopy.Run(N, R, offset_r, 1, ref WY, 1 + ITAIL * N + o_wy, 1);
// c Set theta=yy/ys.
THETA = RR / DR;
// c Form the middle matrix in B.
// c update the upper triangle of SS,
// c and the lower triangle of SY:
if (IUPDAT > M)
{
// c move old information
for (J = 1; J <= COL - 1; J++)
{
this._dcopy.Run(J, SS, 2 + (J + 1) * M + o_ss, 1, ref SS, 1 + J * M + o_ss, 1);
this._dcopy.Run(COL - J, SY, J + 1 + (J + 1) * M + o_sy, 1, ref SY, J + J * M + o_sy, 1);
}
}
// c add new information: the last row of SY
// c and the last column of SS:
POINTR = HEAD;
SS_COL = COL * M + o_ss;
for (J = 1; J <= COL - 1; J++)
{
SY[COL + J * M + o_sy] = this._ddot.Run(N, D, offset_d, 1, WY, 1 + POINTR * N + o_wy, 1);
SS[J + SS_COL] = this._ddot.Run(N, WS, 1 + POINTR * N + o_ws, 1, D, offset_d, 1);
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
if (STP == ONE)
{
SS[COL + COL * M + o_ss] = DTD;
}
else
{
SS[COL + COL * M + o_ss] = STP * STP * DTD;
}
SY[COL + COL * M + o_sy] = DR;
return;
#endregion
}
/// <param name="N">
/// is an integer variable.
/// On entry n is the dimension of the problem.
/// On exit n is unchanged.
///</param>
/// <param name="M">
/// is an integer variable.
/// On entry m is the maximum number of variable metric corrections
/// used to define the limited memory matrix.
/// On exit m is unchanged.
///</param>
/// <param name="NSUB">
/// is an integer variable.
/// On entry nsub is the number of free variables.
/// On exit nsub is unchanged.
///</param>
/// <param name="IND">
/// is an integer array of dimension nsub.
/// On entry ind specifies the coordinate indices of free variables.
/// On exit ind is unchanged.
///</param>
/// <param name="L">
/// is a double precision array of dimension n.
/// On entry l is the lower bound of x.
/// On exit l is unchanged.
///</param>
/// <param name="U">
/// is a double precision array of dimension n.
/// On entry u is the upper bound of x.
/// On exit u is unchanged.
///</param>
/// <param name="NBD">
/// is a integer array of dimension n.
/// On entry nbd represents the type of bounds imposed on the
/// variables, and must be specified as follows:
/// nbd(i)=0 if x(i) is unbounded,
/// 1 if x(i) has only a lower bound,
/// 2 if x(i) has both lower and upper bounds, and
/// 3 if x(i) has only an upper bound.
/// On exit nbd is unchanged.
///</param>
/// <param name="X">
/// is a double precision array of dimension n.
/// On entry x specifies the Cauchy point xcp.
/// On exit x(i) is the minimizer of Q over the subspace of
/// free variables.
///</param>
/// <param name="D">
/// = -(Z'BZ)^(-1) r.
///
/// The formula for the Newton direction, given the L-BFGS matrix
/// and the Sherman-Morrison formula, is
///
/// d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r.
///
/// where
/// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ]
/// [L_a -R_z theta*S'AA'S ]
///
/// Note that this procedure for computing d differs
/// from that described in [1]. One can show that the matrix K is
/// equal to the matrix M^[-1]N in that paper.
///
/// n is an integer variable.
/// On entry n is the dimension of the problem.
/// On exit n is unchanged.
///
/// m is an integer variable.
/// On entry m is the maximum number of variable metric corrections
/// used to define the limited memory matrix.
/// On exit m is unchanged.
///
/// nsub is an integer variable.
/// On entry nsub is the number of free variables.
/// On exit nsub is unchanged.
///
/// ind is an integer array of dimension nsub.
/// On entry ind specifies the coordinate indices of free variables.
/// On exit ind is unchanged.
///
/// l is a double precision array of dimension n.
/// On entry l is the lower bound of x.
/// On exit l is unchanged.
///
/// u is a double precision array of dimension n.
/// On entry u is the upper bound of x.
/// On exit u is unchanged.
///
/// nbd is a integer array of dimension n.
/// On entry nbd represents the type of bounds imposed on the
/// variables, and must be specified as follows:
/// nbd(i)=0 if x(i) is unbounded,
/// 1 if x(i) has only a lower bound,
/// 2 if x(i) has both lower and upper bounds, and
/// 3 if x(i) has only an upper bound.
/// On exit nbd is unchanged.
///
/// x is a double precision array of dimension n.
/// On entry x specifies the Cauchy point xcp.
/// On exit x(i) is the minimizer of Q over the subspace of
/// free variables.
///
/// d is a double precision array of dimension n.
/// On entry d is the reduced gradient of Q at xcp.
/// On exit d is the Newton direction of Q.
///
/// ws and wy are double precision arrays;
/// theta is a double precision variable;
/// col is an integer variable;
/// head is an integer variable.
/// On entry they store the information defining the
/// limited memory BFGS matrix:
/// ws(n,m) stores S, a set of s-vectors;
/// wy(n,m) stores Y, a set of y-vectors;
/// theta is the scaling factor specifying B_0 = theta I;
/// col is the number of variable metric corrections stored;
/// head is the location of the 1st s- (or y-) vector in S (or Y).
/// On exit they are unchanged.
///
/// iword is an integer variable.
/// On entry iword is unspecified.
/// On exit iword specifies the status of the subspace solution.
/// iword = 0 if the solution is in the box,
/// 1 if some bound is encountered.
///
/// wv is a double precision working array of dimension 2m.
///
/// wn is a double precision array of dimension 2m x 2m.
/// On entry the upper triangle of wn stores the LEL^T factorization
/// of the indefinite matrix
///
/// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ]
/// [L_a -R_z theta*S'AA'S ]
/// where E = [-I 0]
/// [ 0 I]
/// On exit wn is unchanged.
///
/// iprint is an INTEGER variable that must be set by the user.
/// It controls the frequency and type of output generated:
/// iprint.LT.0 no output is generated;
/// iprint=0 print only one line at the last iteration;
/// 0.LT.iprint.LT.99 print also f and |proj g| every iprint iterations;
/// iprint=99 print details of every iteration except n-vectors;
/// iprint=100 print also the changes of active set and final x;
/// iprint.GT.100 print details of every iteration including x and g;
/// When iprint .GT. 0, the file iterate.dat will be created to
/// summarize the iteration.
///
/// info is an integer variable.
/// On entry info is unspecified.
/// On exit info = 0 for normal return,
/// = nonzero for abnormal return
/// when the matrix K is ill-conditioned.
///
/// Subprograms called:
///
/// Linpack dtrsl.
///
///
/// References:
///
/// [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
/// memory algorithm for bound constrained optimization'',
/// SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
///
///
///
/// * * *
///
/// NEOS, November 1994. (Latest revision June 1996.)
/// Optimization Technology Center.
/// Argonne National Laboratory and Northwestern University.
/// Written by
/// Ciyou Zhu
/// in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
///
///
/// ************
///
///
///
///
///
///</param>
/// <param name="WS">
/// and wy are double precision arrays;
///</param>
/// <param name="THETA">
/// is a double precision variable;
///</param>
/// <param name="COL">
/// is an integer variable;
///</param>
/// <param name="HEAD">
/// is an integer variable.
/// On entry they store the information defining the
/// limited memory BFGS matrix:
/// ws(n,m) stores S, a set of s-vectors;
/// wy(n,m) stores Y, a set of y-vectors;
/// theta is the scaling factor specifying B_0 = theta I;
/// col is the number of variable metric corrections stored;
/// head is the location of the 1st s- (or y-) vector in S (or Y).
/// On exit they are unchanged.
///</param>
/// <param name="IWORD">
/// is an integer variable.
/// On entry iword is unspecified.
/// On exit iword specifies the status of the subspace solution.
/// iword = 0 if the solution is in the box,
/// 1 if some bound is encountered.
///</param>
/// <param name="WV">
/// is a double precision working array of dimension 2m.
///</param>
/// <param name="WN">
/// is a double precision array of dimension 2m x 2m.
/// On entry the upper triangle of wn stores the LEL^T factorization
/// of the indefinite matrix
///
/// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ]
/// [L_a -R_z theta*S'AA'S ]
/// where E = [-I 0]
/// [ 0 I]
/// On exit wn is unchanged.
///</param>
/// <param name="IPRINT">
/// is an INTEGER variable that must be set by the user.
/// It controls the frequency and type of output generated:
/// iprint.LT.0 no output is generated;
/// iprint=0 print only one line at the last iteration;
/// 0.LT.iprint.LT.99 print also f and |proj g| every iprint iterations;
/// iprint=99 print details of every iteration except n-vectors;
/// iprint=100 print also the changes of active set and final x;
/// iprint.GT.100 print details of every iteration including x and g;
/// When iprint .GT. 0, the file iterate.dat will be created to
/// summarize the iteration.
///</param>
/// <param name="INFO">
/// is an integer variable.
/// On entry info is unspecified.
/// On exit info = 0 for normal return,
/// = nonzero for abnormal return
/// when the matrix K is ill-conditioned.
///</param>
public void Run(int N, int M, int NSUB, int[] IND, int offset_ind, double[] L, int offset_l, double[] U, int offset_u
, int[] NBD, int offset_nbd, ref double[] X, int offset_x, ref double[] D, int offset_d, double[] WS, int offset_ws, double[] WY, int offset_wy, double THETA
, int COL, int HEAD, ref int IWORD, ref double[] WV, int offset_wv, double[] WN, int offset_wn, int IPRINT
, ref int INFO)
{
#region Variables
int POINTR = 0; int M2 = 0; int COL2 = 0; int IBD = 0; int JY = 0; int JS = 0; int I = 0; int J = 0; int K = 0;
double ALPHA = 0; double DK = 0; double TEMP1 = 0; double TEMP2 = 0;
#endregion
#region Array Index Correction
int o_ind = -1 + offset_ind; int o_l = -1 + offset_l; int o_u = -1 + offset_u; int o_nbd = -1 + offset_nbd;
int o_x = -1 + offset_x; int o_d = -1 + offset_d; int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy;
int o_wv = -1 + offset_wv; int o_wn = -1 - (2 * M) + offset_wn;
#endregion
#region Prolog
// c ************
// c
// c Subroutine subsm
// c
// c Given xcp, l, u, r, an index set that specifies
// c the active set at xcp, and an l-BFGS matrix B
// c (in terms of WY, WS, SY, WT, head, col, and theta),
// c this subroutine computes an approximate solution
// c of the subspace problem
// c
// c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp)
// c
// c subject to l<=x<=u
// c x_i=xcp_i for all i in A(xcp)
// c
// c along the subspace unconstrained Newton direction
// c
// c d = -(Z'BZ)^(-1) r.
// c
// c The formula for the Newton direction, given the L-BFGS matrix
// c and the Sherman-Morrison formula, is
// c
// c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r.
// c
// c where
// c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ]
// c [L_a -R_z theta*S'AA'S ]
// c
// c Note that this procedure for computing d differs
// c from that described in [1]. One can show that the matrix K is
// c equal to the matrix M^[-1]N in that paper.
// c
// c n is an integer variable.
// c On entry n is the dimension of the problem.
// c On exit n is unchanged.
// c
// c m is an integer variable.
// c On entry m is the maximum number of variable metric corrections
// c used to define the limited memory matrix.
// c On exit m is unchanged.
// c
// c nsub is an integer variable.
// c On entry nsub is the number of free variables.
// c On exit nsub is unchanged.
// c
// c ind is an integer array of dimension nsub.
// c On entry ind specifies the coordinate indices of free variables.
// c On exit ind is unchanged.
// c
// c l is a double precision array of dimension n.
// c On entry l is the lower bound of x.
// c On exit l is unchanged.
// c
// c u is a double precision array of dimension n.
// c On entry u is the upper bound of x.
// c On exit u is unchanged.
// c
// c nbd is a integer array of dimension n.
// c On entry nbd represents the type of bounds imposed on the
// c variables, and must be specified as follows:
// c nbd(i)=0 if x(i) is unbounded,
// c 1 if x(i) has only a lower bound,
// c 2 if x(i) has both lower and upper bounds, and
// c 3 if x(i) has only an upper bound.
// c On exit nbd is unchanged.
// c
// c x is a double precision array of dimension n.
// c On entry x specifies the Cauchy point xcp.
// c On exit x(i) is the minimizer of Q over the subspace of
// c free variables.
// c
// c d is a double precision array of dimension n.
// c On entry d is the reduced gradient of Q at xcp.
// c On exit d is the Newton direction of Q.
// c
// c ws and wy are double precision arrays;
// c theta is a double precision variable;
// c col is an integer variable;
// c head is an integer variable.
// c On entry they store the information defining the
// c limited memory BFGS matrix:
// c ws(n,m) stores S, a set of s-vectors;
// c wy(n,m) stores Y, a set of y-vectors;
// c theta is the scaling factor specifying B_0 = theta I;
// c col is the number of variable metric corrections stored;
// c head is the location of the 1st s- (or y-) vector in S (or Y).
// c On exit they are unchanged.
// c
// c iword is an integer variable.
// c On entry iword is unspecified.
// c On exit iword specifies the status of the subspace solution.
// c iword = 0 if the solution is in the box,
// c 1 if some bound is encountered.
// c
// c wv is a double precision working array of dimension 2m.
// c
// c wn is a double precision array of dimension 2m x 2m.
// c On entry the upper triangle of wn stores the LEL^T factorization
// c of the indefinite matrix
// c
// c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ]
// c [L_a -R_z theta*S'AA'S ]
// c where E = [-I 0]
// c [ 0 I]
// c On exit wn is unchanged.
// c
// c iprint is an INTEGER variable that must be set by the user.
// c It controls the frequency and type of output generated:
// c iprint<0 no output is generated;
// c iprint=0 print only one line at the last iteration;
// c 0<iprint<99 print also f and |proj g| every iprint iterations;
// c iprint=99 print details of every iteration except n-vectors;
// c iprint=100 print also the changes of active set and final x;
// c iprint>100 print details of every iteration including x and g;
// c When iprint > 0, the file iterate.dat will be created to
// c summarize the iteration.
// c
// c info is an integer variable.
// c On entry info is unspecified.
// c On exit info = 0 for normal return,
// c = nonzero for abnormal return
// c when the matrix K is ill-conditioned.
// c
// c Subprograms called:
// c
// c Linpack dtrsl.
// c
// c
// c References:
// c
// c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
// c memory algorithm for bound constrained optimization'',
// c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
// c
// c
// c
// c * * *
// c
// c NEOS, November 1994. (Latest revision June 1996.)
// c Optimization Technology Center.
// c Argonne National Laboratory and Northwestern University.
// c Written by
// c Ciyou Zhu
// c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
// c
// c
// c ************
#endregion
#region Body
if (NSUB <= 0)
{
return;
}
if (IPRINT >= 99)
{
; //ERROR-ERRORWRITE(6,1001)
}
// c Compute wv = W'Zd.
POINTR = HEAD;
for (I = 1; I <= COL; I++)
{
TEMP1 = ZERO;
TEMP2 = ZERO;
for (J = 1; J <= NSUB; J++)
{
K = IND[J + o_ind];
TEMP1 += WY[K + POINTR * N + o_wy] * D[J + o_d];
TEMP2 += WS[K + POINTR * N + o_ws] * D[J + o_d];
}
WV[I + o_wv] = TEMP1;
WV[COL + I + o_wv] = THETA * TEMP2;
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
// c Compute wv:=K^(-1)wv.
M2 = 2 * M;
COL2 = 2 * COL;
this._dtrsl.Run(WN, offset_wn, M2, COL2, ref WV, offset_wv, 11, ref INFO);
if (INFO != 0)
{
return;
}
for (I = 1; I <= COL; I++)
{
WV[I + o_wv] = -WV[I + o_wv];
}
this._dtrsl.Run(WN, offset_wn, M2, COL2, ref WV, offset_wv, 01, ref INFO);
if (INFO != 0)
{
return;
}
// c Compute d = (1/theta)d + (1/theta**2)Z'W wv.
POINTR = HEAD;
for (JY = 1; JY <= COL; JY++)
{
JS = COL + JY;
for (I = 1; I <= NSUB; I++)
{
K = IND[I + o_ind];
D[I + o_d] += WY[K + POINTR * N + o_wy] * WV[JY + o_wv] / THETA + WS[K + POINTR * N + o_ws] * WV[JS + o_wv];
}
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
for (I = 1; I <= NSUB; I++)
{
D[I + o_d] /= THETA;
}
// c Backtrack to the feasible region.
ALPHA = ONE;
TEMP1 = ALPHA;
for (I = 1; I <= NSUB; I++)
{
K = IND[I + o_ind];
DK = D[I + o_d];
if (NBD[K + o_nbd] != 0)
{
if (DK < ZERO && NBD[K + o_nbd] <= 2)
{
TEMP2 = L[K + o_l] - X[K + o_x];
if (TEMP2 >= ZERO)
{
TEMP1 = ZERO;
}
else
{
if (DK * ALPHA < TEMP2)
{
TEMP1 = TEMP2 / DK;
}
}
}
else
{
if (DK > ZERO && NBD[K + o_nbd] >= 2)
{
TEMP2 = U[K + o_u] - X[K + o_x];
if (TEMP2 <= ZERO)
{
TEMP1 = ZERO;
}
else
{
if (DK * ALPHA > TEMP2)
{
TEMP1 = TEMP2 / DK;
}
}
}
}
if (TEMP1 < ALPHA)
{
ALPHA = TEMP1;
IBD = I;
}
}
}
if (ALPHA < ONE)
{
DK = D[IBD + o_d];
K = IND[IBD + o_ind];
if (DK > ZERO)
{
X[K + o_x] = U[K + o_u];
D[IBD + o_d] = ZERO;
}
else
{
if (DK < ZERO)
{
X[K + o_x] = L[K + o_l];
D[IBD + o_d] = ZERO;
}
}
}
for (I = 1; I <= NSUB; I++)
{
K = IND[I + o_ind];
X[K + o_x] += ALPHA * D[I + o_d];
}
if (IPRINT >= 99)
{
if (ALPHA < ONE)
{
//ERROR-ERROR WRITE (6,1002) ALPHA;
}
else
{
//ERROR-ERROR WRITE (6,*) 'SM solution inside the box';
}
if (IPRINT > 100)
{
; //ERROR-ERRORWRITE(6,1003)(X(I),I=1,N)
}
}
if (ALPHA < ONE)
{
IWORD = 1;
}
else
{
IWORD = 0;
}
if (IPRINT >= 99)
{
; //ERROR-ERRORWRITE(6,1004)
}
return;
#endregion
}
public void Run(int N, double DA, ref double[] DX, int offset_dx, int INCX)
{
#region Variables
int I = 0; int M = 0; int MP1 = 0; int NINCX = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx;
#endregion
// c
// c scales a vector by a constant.
// c uses unrolled loops for increment equal to one.
// c jack dongarra, linpack, 3/11/78.
// c modified 3/93 to return if incx .le. 0.
// c
// c
#region Body
if (N <= 0 || INCX <= 0)
{
return;
}
if (INCX == 1)
{
goto LABEL20;
}
// c
// c code for increment not equal to 1
// c
NINCX = N * INCX;
for (I = 1; (INCX >= 0) ? (I <= NINCX) : (I >= NINCX); I += INCX)
{
DX[I + o_dx] *= DA;
}
return;
// c
// c code for increment equal to 1
// c
// c
// c clean-up loop
// c
LABEL20 : M = FortranLib.Mod(N, 5);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DX[I + o_dx] *= DA;
}
if (N < 5)
{
return;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 5)
{
DX[I + o_dx] *= DA;
DX[I + 1 + o_dx] *= DA;
DX[I + 2 + o_dx] *= DA;
DX[I + 3 + o_dx] *= DA;
DX[I + 4 + o_dx] *= DA;
}
return;
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// interchanges two vectors.
/// uses unrolled loops for increments equal one.
/// jack dongarra, linpack, 3/11/78.
/// modified 12/3/93, array(1) declarations changed to array(*)
///</summary>
public void Run(int N, ref double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY)
{
#region Variables
double DTEMP = 0; int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0;
#endregion
#region Array Index Correction
int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy;
#endregion
#region Prolog
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * interchanges two vectors.
// * uses unrolled loops for increments equal one.
// * jack dongarra, linpack, 3/11/78.
// * modified 12/3/93, array(1) declarations changed to array(*)
// *
// *
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC MOD;
// * ..
#endregion
#region Body
if (N <= 0)
{
return;
}
if (INCX == 1 && INCY == 1)
{
goto LABEL20;
}
// *
// * code for unequal increments or equal increments not equal
// * to 1
// *
IX = 1;
IY = 1;
if (INCX < 0)
{
IX = (-N + 1) * INCX + 1;
}
if (INCY < 0)
{
IY = (-N + 1) * INCY + 1;
}
for (I = 1; I <= N; I++)
{
DTEMP = DX[IX + o_dx];
DX[IX + o_dx] = DY[IY + o_dy];
DY[IY + o_dy] = DTEMP;
IX += INCX;
IY += INCY;
}
return;
// *
// * code for both increments equal to 1
// *
// *
// * clean-up loop
// *
LABEL20 : M = FortranLib.Mod(N, 3);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DTEMP = DX[I + o_dx];
DX[I + o_dx] = DY[I + o_dy];
DY[I + o_dy] = DTEMP;
}
if (N < 3)
{
return;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 3)
{
DTEMP = DX[I + o_dx];
DX[I + o_dx] = DY[I + o_dy];
DY[I + o_dy] = DTEMP;
DTEMP = DX[I + 1 + o_dx];
DX[I + 1 + o_dx] = DY[I + 1 + o_dy];
DY[I + 1 + o_dy] = DTEMP;
DTEMP = DX[I + 2 + o_dx];
DX[I + 2 + o_dx] = DY[I + 2 + o_dy];
DY[I + 2 + o_dy] = DTEMP;
}
return;
#endregion
}
/// <summary>
/// Purpose
/// =======
///
/// DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
/// symmetric tridiagonal matrix using the divide and conquer method.
/// The eigenvectors of a full or band real symmetric matrix can also be
/// found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
/// matrix to tridiagonal 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 DLAED3 for details.
///
///</summary>
/// <param name="COMPZ">
/// (input) CHARACTER*1
/// = 'N': Compute eigenvalues only.
/// = 'I': Compute eigenvectors of tridiagonal matrix also.
/// = 'V': Compute eigenvectors of original dense symmetric
/// matrix also. On entry, Z contains the orthogonal
/// matrix used to reduce the original matrix to
/// tridiagonal form.
///</param>
/// <param name="N">
/// (input) INTEGER
/// The dimension of the symmetric tridiagonal 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 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.
/// If eigenvectors are desired, then LDZ .GE. max(1,N).
///</param>
/// <param name="WORK">
/// (workspace/output) DOUBLE PRECISION array,
/// dimension (LWORK)
/// On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
///</param>
/// <param name="LWORK">
/// (input) INTEGER
/// The dimension of the array WORK.
/// If COMPZ = 'N' or N .LE. 1 then LWORK must be at least 1.
/// If COMPZ = 'V' and N .GT. 1 then LWORK must be at least
/// ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
/// where lg( N ) = smallest integer k such
/// that 2**k .GE. N.
/// If COMPZ = 'I' and N .GT. 1 then LWORK must be at least
/// ( 1 + 4*N + N**2 ).
/// Note that for COMPZ = 'I' or 'V', then if N is less than or
/// equal to the minimum divide size, usually 25, then LWORK need
/// only be max(1,2*(N-1)).
///
/// If LWORK = -1, then a workspace query is assumed; the routine
/// only calculates the optimal size of the WORK array, returns
/// this value as the first entry of the WORK array, and no error
/// message related to LWORK is issued by XERBLA.
///</param>
/// <param name="IWORK">
/// (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
/// On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
///</param>
/// <param name="LIWORK">
/// (input) INTEGER
/// The dimension of the array IWORK.
/// If COMPZ = 'N' or N .LE. 1 then LIWORK must be at least 1.
/// If COMPZ = 'V' and N .GT. 1 then LIWORK must be at least
/// ( 6 + 6*N + 5*N*lg N ).
/// If COMPZ = 'I' and N .GT. 1 then LIWORK must be at least
/// ( 3 + 5*N ).
/// Note that for COMPZ = 'I' or 'V', then if N is less than or
/// equal to the minimum divide size, usually 25, then LIWORK
/// need only be 1.
///
/// If LIWORK = -1, then a workspace query is assumed; the
/// routine only calculates the optimal size of the IWORK array,
/// returns this value as the first entry of the IWORK array, and
/// no error message related to LIWORK is issued by XERBLA.
///</param>
/// <param name="INFO">
/// (output) INTEGER
/// = 0: successful exit.
/// .LT. 0: if INFO = -i, the i-th argument had an illegal value.
/// .GT. 0: The algorithm failed to compute an eigenvalue while
/// working on the submatrix lying in rows and columns
/// INFO/(N+1) through mod(INFO,N+1).
///</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, int LWORK, ref int[] IWORK, int offset_iwork, int LIWORK, ref int INFO)
{
#region Variables
bool LQUERY = false; int FINISH = 0; int I = 0; int ICOMPZ = 0; int II = 0; int J = 0; int K = 0; int LGN = 0;
int LIWMIN = 0; int LWMIN = 0; int M = 0; int SMLSIZ = 0; int START = 0; int STOREZ = 0; int STRTRW = 0;
double EPS = 0; double ORGNRM = 0; double P = 0; double TINY = 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;
int o_iwork = -1 + offset_iwork;
#endregion
#region Strings
COMPZ = COMPZ.Substring(0, 1);
#endregion
#region Prolog
// *
// * -- LAPACK driver routine (version 3.1) --
// * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
// * November 2006
// *
// * .. Scalar Arguments ..
// * ..
// * .. Array Arguments ..
// * ..
// *
// * Purpose
// * =======
// *
// * DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
// * symmetric tridiagonal matrix using the divide and conquer method.
// * The eigenvectors of a full or band real symmetric matrix can also be
// * found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
// * matrix to tridiagonal 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 DLAED3 for details.
// *
// * Arguments
// * =========
// *
// * COMPZ (input) CHARACTER*1
// * = 'N': Compute eigenvalues only.
// * = 'I': Compute eigenvectors of tridiagonal matrix also.
// * = 'V': Compute eigenvectors of original dense symmetric
// * matrix also. On entry, Z contains the orthogonal
// * matrix used to reduce the original matrix to
// * tridiagonal form.
// *
// * N (input) INTEGER
// * The dimension of the symmetric tridiagonal 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 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.
// * If eigenvectors are desired, then LDZ >= max(1,N).
// *
// * WORK (workspace/output) DOUBLE PRECISION array,
// * dimension (LWORK)
// * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
// *
// * LWORK (input) INTEGER
// * The dimension of the array WORK.
// * If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
// * If COMPZ = 'V' and N > 1 then LWORK must be at least
// * ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
// * where lg( N ) = smallest integer k such
// * that 2**k >= N.
// * If COMPZ = 'I' and N > 1 then LWORK must be at least
// * ( 1 + 4*N + N**2 ).
// * Note that for COMPZ = 'I' or 'V', then if N is less than or
// * equal to the minimum divide size, usually 25, then LWORK need
// * only be max(1,2*(N-1)).
// *
// * If LWORK = -1, then a workspace query is assumed; the routine
// * only calculates the optimal size of the WORK array, returns
// * this value as the first entry of the WORK array, and no error
// * message related to LWORK is issued by XERBLA.
// *
// * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
// * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
// *
// * LIWORK (input) INTEGER
// * The dimension of the array IWORK.
// * If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
// * If COMPZ = 'V' and N > 1 then LIWORK must be at least
// * ( 6 + 6*N + 5*N*lg N ).
// * If COMPZ = 'I' and N > 1 then LIWORK must be at least
// * ( 3 + 5*N ).
// * Note that for COMPZ = 'I' or 'V', then if N is less than or
// * equal to the minimum divide size, usually 25, then LIWORK
// * need only be 1.
// *
// * If LIWORK = -1, then a workspace query is assumed; the
// * routine only calculates the optimal size of the IWORK array,
// * returns this value as the first entry of the IWORK array, and
// * no error message related to LIWORK is issued by XERBLA.
// *
// * 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 eigenvalue while
// * working on the submatrix lying in rows and columns
// * INFO/(N+1) through mod(INFO,N+1).
// *
// * 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 ABS, DBLE, INT, LOG, MAX, MOD, SQRT;
// * ..
// * .. Executable Statements ..
// *
// * Test the input parameters.
// *
#endregion
#region Body
INFO = 0;
LQUERY = (LWORK == -1 || LIWORK == -1);
// *
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)
{
// *
// * Compute the workspace requirements
// *
SMLSIZ = this._ilaenv.Run(9, "DSTEDC", " ", 0, 0, 0, 0);
if (N <= 1 || ICOMPZ == 0)
{
LIWMIN = 1;
LWMIN = 1;
}
else
{
if (N <= SMLSIZ)
{
LIWMIN = 1;
LWMIN = 2 * (N - 1);
}
else
{
LGN = Convert.ToInt32(Math.Truncate(Math.Log(Convert.ToDouble(N)) / Math.Log(TWO)));
if (Math.Pow(2, LGN) < N)
{
LGN += 1;
}
if (Math.Pow(2, LGN) < N)
{
LGN += 1;
}
if (ICOMPZ == 1)
{
LWMIN = 1 + 3 * N + 2 * N * LGN + 3 * (int)Math.Pow(N, 2);
LIWMIN = 6 + 6 * N + 5 * N * LGN;
}
else
{
if (ICOMPZ == 2)
{
LWMIN = 1 + 4 * N + (int)Math.Pow(N, 2);
LIWMIN = 3 + 5 * N;
}
}
}
}
WORK[1 + o_work] = LWMIN;
IWORK[1 + o_iwork] = LIWMIN;
// *
if (LWORK < LWMIN && !LQUERY)
{
INFO = -8;
}
else
{
if (LIWORK < LIWMIN && !LQUERY)
{
INFO = -10;
}
}
}
// *
if (INFO != 0)
{
this._xerbla.Run("DSTEDC", -INFO);
return;
}
else
{
if (LQUERY)
{
return;
}
}
// *
// * Quick return if possible
// *
if (N == 0)
{
return;
}
if (N == 1)
{
if (ICOMPZ != 0)
{
Z[1 + 1 * LDZ + o_z] = ONE;
}
return;
}
// *
// * If the following conditional clause is removed, then the routine
// * will use the Divide and Conquer routine to compute only the
// * eigenvalues, which requires (3N + 3N**2) real workspace and
// * (2 + 5N + 2N lg(N)) integer workspace.
// * Since on many architectures DSTERF is much faster than any other
// * algorithm for finding eigenvalues only, it is used here
// * as the default. If the conditional clause is removed, then
// * information on the size of workspace needs to be changed.
// *
// * If COMPZ = 'N', use DSTERF to compute the eigenvalues.
// *
if (ICOMPZ == 0)
{
this._dsterf.Run(N, ref D, offset_d, ref E, offset_e, ref INFO);
goto LABEL50;
}
// *
// * If N is smaller than the minimum divide size (SMLSIZ+1), then
// * solve the problem with another solver.
// *
if (N <= SMLSIZ)
{
// *
this._dsteqr.Run(COMPZ, N, ref D, offset_d, ref E, offset_e, ref Z, offset_z, LDZ
, ref WORK, offset_work, ref INFO);
// *
}
else
{
// *
// * If COMPZ = 'V', the Z matrix must be stored elsewhere for later
// * use.
// *
if (ICOMPZ == 1)
{
STOREZ = 1 + N * N;
}
else
{
STOREZ = 1;
}
// *
if (ICOMPZ == 2)
{
this._dlaset.Run("Full", N, N, ZERO, ONE, ref Z, offset_z
, LDZ);
}
// *
// * Scale.
// *
ORGNRM = this._dlanst.Run("M", N, D, offset_d, E, offset_e);
if (ORGNRM == ZERO)
{
goto LABEL50;
}
// *
EPS = this._dlamch.Run("Epsilon");
// *
START = 1;
// *
// * while ( START <= N )
// *
LABEL10 :;
if (START <= N)
{
// *
// * Let FINISH be the position of the next subdiagonal entry
// * such that E( FINISH ) <= TINY or FINISH = N if no such
// * subdiagonal exists. The matrix identified by the elements
// * between START and FINISH constitutes an independent
// * sub-problem.
// *
FINISH = START;
LABEL20 :;
if (FINISH < N)
{
TINY = EPS * Math.Sqrt(Math.Abs(D[FINISH + o_d])) * Math.Sqrt(Math.Abs(D[FINISH + 1 + o_d]));
if (Math.Abs(E[FINISH + o_e]) > TINY)
{
FINISH += 1;
goto LABEL20;
}
}
// *
// * (Sub) Problem determined. Compute its size and solve it.
// *
M = FINISH - START + 1;
if (M == 1)
{
START = FINISH + 1;
goto LABEL10;
}
if (M > SMLSIZ)
{
// *
// * Scale.
// *
ORGNRM = this._dlanst.Run("M", M, D, START + o_d, E, START + o_e);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, M
, 1, ref D, START + o_d, M, ref INFO);
this._dlascl.Run("G", 0, 0, ORGNRM, ONE, M - 1
, 1, ref E, START + o_e, M - 1, ref INFO);
// *
if (ICOMPZ == 1)
{
STRTRW = 1;
}
else
{
STRTRW = START;
}
this._dlaed0.Run(ICOMPZ, N, M, ref D, START + o_d, ref E, START + o_e, ref Z, STRTRW + START * LDZ + o_z
, LDZ, ref WORK, 1 + o_work, N, ref WORK, STOREZ + o_work, ref IWORK, offset_iwork, ref INFO);
if (INFO != 0)
{
INFO = (INFO / (M + 1) + START - 1) * (N + 1) + FortranLib.Mod(INFO, (M + 1)) + START - 1;
goto LABEL50;
}
// *
// * Scale back.
// *
this._dlascl.Run("G", 0, 0, ONE, ORGNRM, M
, 1, ref D, START + o_d, M, ref INFO);
// *
}
else
{
if (ICOMPZ == 1)
{
// *
// * Since QR won't update a Z matrix which is larger than
// * the length of D, we must solve the sub-problem in a
// * workspace and then multiply back into Z.
// *
this._dsteqr.Run("I", M, ref D, START + o_d, ref E, START + o_e, ref WORK, offset_work, M
, ref WORK, M * M + 1 + o_work, ref INFO);
this._dlacpy.Run("A", N, M, Z, 1 + START * LDZ + o_z, LDZ, ref WORK, STOREZ + o_work
, N);
this._dgemm.Run("N", "N", N, M, M, ONE
, WORK, STOREZ + o_work, N, WORK, offset_work, M, ZERO, ref Z, 1 + START * LDZ + o_z
, LDZ);
}
else
{
if (ICOMPZ == 2)
{
this._dsteqr.Run("I", M, ref D, START + o_d, ref E, START + o_e, ref Z, START + START * LDZ + o_z, LDZ
, ref WORK, offset_work, ref INFO);
}
else
{
this._dsterf.Run(M, ref D, START + o_d, ref E, START + o_e, ref INFO);
}
}
if (INFO != 0)
{
INFO = START * (N + 1) + FINISH;
goto LABEL50;
}
}
// *
START = FINISH + 1;
goto LABEL10;
}
// *
// * endwhile
// *
// * If the problem split any number of times, then the eigenvalues
// * will not be properly ordered. Here we permute the eigenvalues
// * (and the associated eigenvectors) into ascending order.
// *
if (M != N)
{
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);
}
}
}
}
}
// *
LABEL50 :;
WORK[1 + o_work] = LWMIN;
IWORK[1 + o_iwork] = LIWMIN;
// *
return;
// *
// * End of DSTEDC
// *
#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
}
