public static double dgeco(ref double[] a, int lda, int n, ref int[] ipvt, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DGECO factors a real matrix and estimates its condition number.
//
// Discussion:
//
// If RCOND is not needed, DGEFA is slightly faster.
//
// To solve A * X = B, follow DGECO by DGESL.
//
// To compute inverse ( A ) * C, follow DGECO by DGESL.
//
// To compute determinant ( A ), follow DGECO by DGEDI.
//
// To compute inverse ( A ), follow DGECO by DGEDI.
//
// For the system A * X = B, relative perturbations in A and B
// of size EPSILON may cause relative perturbations in X of size
// EPSILON/RCOND.
//
// If RCOND is so small that the logical expression
// 1.0D+00 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate
// underflows.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 25 May 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double A[LDA*N]. On input, a matrix to be
// factored. On output, the LU factorization of the matrix.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int N, the order of the matrix A.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, double Z[N], a work vector whose contents are usually
// unimportant. If A is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ).
//
// Output, double DGECO, the value of RCOND, an estimate
// of the reciprocal condition number of A.
//
{
int i;
int j;
int k;
int l;
double rcond;
double s;
double t;
//
// Compute the L1 norm of A.
//
double anorm = 0.0;
for (j = 1; j <= n; j++)
{
anorm = Math.Max(anorm, BLAS1D.dasum(n, a, 1, index: +0 + (j - 1) * lda));
}
//
// Compute the LU factorization.
//
DGEFA.dgefa(ref a, lda, n, ref ipvt);
//
// RCOND = 1 / ( norm(A) * (estimate of norm(inverse(A))) )
//
// estimate of norm(inverse(A)) = norm(Z) / norm(Y)
//
// where
// A * Z = Y
// and
// A' * Y = E
//
// The components of E are chosen to cause maximum local growth in the
// elements of W, where U'*W = E. The vectors are frequently rescaled
// to avoid overflow.
//
// Solve U' * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
for (k = 1; k <= n; k++)
{
if (z[k - 1] != 0.0)
{
ek *= typeMethods.r8_sign(-z[k - 1]);
}
if (Math.Abs(a[k - 1 + (k - 1) * lda]) < Math.Abs(ek - z[k - 1]))
{
s = Math.Abs(a[k - 1 + (k - 1) * lda]) / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
if (a[k - 1 + (k - 1) * lda] != 0.0)
{
wk /= a[k - 1 + (k - 1) * lda];
wkm /= a[k - 1 + (k - 1) * lda];
}
else
{
wk = 1.0;
wkm = 1.0;
}
if (k + 1 <= n)
{
for (j = k + 1; j <= n; j++)
{
sm += Math.Abs(z[j - 1] + wkm * a[k - 1 + (j - 1) * lda]);
z[j - 1] += wk * a[k - 1 + (j - 1) * lda];
s += Math.Abs(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
for (i = k + 1; i <= n; i++)
{
z[i - 1] += t * a[k - 1 + (i - 1) * lda];
}
}
}
z[k - 1] = wk;
}
t = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= t;
}
//
// Solve L' * Y = W
//
for (k = n; 1 <= k; k--)
{
z[k - 1] += BLAS1D.ddot(n - k, a, 1, z, 1, xIndex: +k + (k - 1) * lda, yIndex: +k);
switch (Math.Abs(z[k - 1]))
{
case > 1.0:
{
t = Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] /= t;
}
break;
}
}
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
}
t = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= t;
}
double ynorm = 1.0;
//
// Solve L * V = Y.
//
for (k = 1; k <= n; k++)
{
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
for (i = k + 1; i <= n; i++)
{
z[i - 1] += t * a[i - 1 + (k - 1) * lda];
}
switch (Math.Abs(z[k - 1]))
{
case > 1.0:
{
ynorm /= Math.Abs(z[k - 1]);
t = Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] /= t;
}
break;
}
}
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
ynorm /= s;
//
// Solve U * Z = V.
//
for (k = n; 1 <= k; k--)
{
if (Math.Abs(a[k - 1 + (k - 1) * lda]) < Math.Abs(z[k - 1]))
{
s = Math.Abs(a[k - 1 + (k - 1) * lda]) / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
if (a[k - 1 + (k - 1) * lda] != 0.0)
{
z[k - 1] /= a[k - 1 + (k - 1) * lda];
}
else
{
z[k - 1] = 1.0;
}
for (i = 1; i <= k - 1; i++)
{
z[i - 1] -= z[k - 1] * a[i - 1 + (k - 1) * lda];
}
}
//
// Normalize Z in the L1 norm.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static double dgbco(ref double[] abd, int lda, int n, int ml, int mu, ref int[] ipvt,
double[] z)
//****************************************************************************80
//
// Purpose:
//
// DGBCO factors a real band matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, DGBFA is slightly faster.
//
// To solve A*X = B, follow DGBCO by DGBSL.
//
// To compute inverse(A)*C, follow DGBCO by DGBSL.
//
// To compute determinant(A), follow DGBCO by DGBDI.
//
// Example:
//
// If the original matrix is
//
// 11 12 13 0 0 0
// 21 22 23 24 0 0
// 0 32 33 34 35 0
// 0 0 43 44 45 46
// 0 0 0 54 55 56
// 0 0 0 0 65 66
//
// then for proper band storage,
//
// N = 6, ML = 1, MU = 2, 5 <= LDA and ABD should contain
//
// * * * + + + * = not used
// * * 13 24 35 46 + = used for pivoting
// * 12 23 34 45 56
// 11 22 33 44 55 66
// 21 32 43 54 65 *
//
// Band storage:
//
// If A is a band matrix, the following program segment
// will set up the input.
//
// ml = (band width below the diagonal)
// mu = (band width above the diagonal)
// m = ml + mu + 1
//
// do j = 1, n
// i1 = max ( 1, j-mu )
// i2 = min ( n, j+ml )
// do i = i1, i2
// k = i - j + m
// abd(k,j) = a(i,j)
// }
// }
//
// This uses rows ML+1 through 2*ML+MU+1 of ABD. In addition, the first
// ML rows in ABD are used for elements generated during the
// triangularization. The total number of rows needed in ABD is
// 2*ML+MU+1. The ML+MU by ML+MU upper left triangle and the ML by ML
// lower right triangle are not referenced.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 07 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double ABD[LDA*N]. On input, the matrix in band
// storage. The columns of the matrix are stored in the columns of ABD and
// the diagonals of the matrix are stored in rows ML+1 through 2*ML+MU+1
// of ABD. On output, an upper triangular matrix in band storage and
// the multipliers which were used to obtain it. The factorization can
// be written A = L*U where L is a product of permutation and unit lower
// triangular matrices and U is upper triangular.
//
// Input, int LDA, the leading dimension of the array ABD.
// 2*ML + MU + 1 <= LDA is required.
//
// Input, int N, the order of the matrix.
//
// Input, int ML, MU, the number of diagonals below and above the
// main diagonal. 0 <= ML < N, 0 <= MU < N.
//
// Output, int IPVT[N], the pivot indices.
//
// Workspace, double Z[N], a work vector whose contents are
// usually unimportant. If A is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
//
// Output, double DGBCO, an estimate of the reciprocal condition number RCOND
// of A. For the system A*X = B, relative perturbations in A and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
int i;
int j;
int k;
int lm;
double rcond;
double s;
double t;
//
// Compute the 1-norm of A.
//
double anorm = 0.0;
int l = ml + 1;
int is_ = l + mu;
for (j = 1; j <= n; j++)
{
anorm = Math.Max(anorm, BLAS1D.dasum(l, abd, 1, index: +is_ - 1 + (j - 1) * lda));
if (ml + 1 < is_)
{
is_ -= 1;
}
if (j <= mu)
{
l += 1;
}
if (n - ml <= j)
{
l -= 1;
}
}
//
// Factor.
//
DGBFA.dgbfa(ref abd, lda, n, ml, mu, ref ipvt);
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where a*z = y and A'*Y = E.
//
// A' is the transpose of A. The components of E are
// chosen to cause maximum local growth in the elements of W where
// U'*W = E. The vectors are frequently rescaled to avoid
// overflow.
//
// Solve U' * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
int m = ml + mu + 1;
int ju = 0;
for (k = 1; k <= n; k++)
{
if (z[k - 1] != 0.0)
{
ek *= typeMethods.r8_sign(-z[k - 1]);
}
if (Math.Abs(abd[m - 1 + (k - 1) * lda]) < Math.Abs(ek - z[k - 1]))
{
s = Math.Abs(abd[m - 1 + (k - 1) * lda]) / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
if (abd[m - 1 + (k - 1) * lda] != 0.0)
{
wk /= abd[m - 1 + (k - 1) * lda];
wkm /= abd[m - 1 + (k - 1) * lda];
}
else
{
wk = 1.0;
wkm = 1.0;
}
ju = Math.Min(Math.Max(ju, mu + ipvt[k - 1]), n);
int mm = m;
if (k + 1 <= ju)
{
for (j = k + 1; j <= ju; j++)
{
mm -= 1;
sm += Math.Abs(z[j - 1] + wkm * abd[mm - 1 + (j - 1) * lda]);
z[j - 1] += wk * abd[mm - 1 + (j - 1) * lda];
s += Math.Abs(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
mm = m;
for (j = k + 1; j <= ju; ju++)
{
mm -= 1;
z[j - 1] += t * abd[mm - 1 + (j - 1) * lda];
}
}
}
z[k - 1] = wk;
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
//
// Solve L' * Y = W.
//
for (k = n; 1 <= k; k--)
{
lm = Math.Min(ml, n - k);
if (k < m)
{
z[k - 1] += BLAS1D.ddot(lm, abd, 1, z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
}
switch (Math.Abs(z[k - 1]))
{
case > 1.0:
{
s = 1.0 / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
break;
}
}
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
double ynorm = 1.0;
//
// Solve L * V = Y.
//
for (k = 1; k <= n; k++)
{
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
lm = Math.Min(ml, n - k);
if (k < n)
{
BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
}
switch (Math.Abs(z[k - 1]))
{
case > 1.0:
{
s = 1.0 / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
break;
}
}
}
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
//
// Solve U * Z = W.
//
for (k = n; 1 <= k; k--)
{
if (Math.Abs(abd[m - 1 + (k - 1) * lda]) < Math.Abs(z[k - 1]))
{
s = Math.Abs(abd[m - 1 + (k - 1) * lda]) / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
if (abd[m - 1 + (k - 1) * lda] != 0.0)
{
z[k - 1] /= abd[m - 1 + (k - 1) * lda];
}
else
{
z[k - 1] = 1.0;
}
lm = Math.Min(k, m) - 1;
int la = m - lm;
int lz = k - lm;
t = -z[k - 1];
BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lz - 1);
}
//
// Make ZNORM = 1.0.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
private static void dasum_test()
//****************************************************************************80
//
// Purpose:
//
// DASUM_TEST tests DASUM.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 15 May 2006
//
// Author:
//
// John Burkardt
//
{
int LDA = 6;
int MA = 5;
int NA = 4;
int NX = 10;
double[] a = new double[LDA * NA];
double[] x = new double[NX];
for (int i = 0; i < NX; i++)
{
x[i] = Math.Pow(-1.0, i + 1) * (2 * (i + 1));
}
Console.WriteLine("");
Console.WriteLine("DASUM_TEST");
Console.WriteLine(" DASUM adds the absolute values of elements of a vector.");
Console.WriteLine("");
Console.WriteLine(" X = ");
Console.WriteLine("");
for (int i = 0; i < NX; i++)
{
Console.WriteLine(" "
+ (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " "
+ x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + "");
}
Console.WriteLine("");
Console.WriteLine(" DASUM ( NX, X, 1 ) = " + BLAS1D.dasum(NX, x, 1) + "");
Console.WriteLine(" DASUM ( NX/2, X, 2 ) = " + BLAS1D.dasum(NX / 2, x, 2) + "");
Console.WriteLine(" DASUM ( 2, X, NX/2 ) = " + BLAS1D.dasum(2, x, NX / 2) + "");
for (int i = 0; i < MA; i++)
{
for (int j = 0; j < NA; j++)
{
a[i + j * LDA] = Math.Pow(-1.0, i + 1 + j + 1)
* (10 * (i + 1) + j + 1);
}
}
Console.WriteLine("");
Console.WriteLine(" Demonstrate with a matrix A:");
Console.WriteLine("");
for (int i = 0; i < MA; i++)
{
string cout = "";
for (int j = 0; j < NA; j++)
{
cout += " " + a[i + j * LDA].ToString(CultureInfo.InvariantCulture).PadLeft(14);
}
Console.WriteLine(cout);
}
Console.WriteLine("");
Console.WriteLine(" DASUM(MA,A(1,2),1) = " + BLAS1D.dasum(MA, a, 1, 0 + 1 * LDA) + "");
Console.WriteLine(" DASUM(NA,A(2,1),LDA) = " + BLAS1D.dasum(NA, a, LDA, 1) + "");
}
public static double dpoco(ref double[] a, int lda, int n, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DPOCO factors a real symmetric positive definite matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, DPOFA is slightly faster.
//
// To solve A*X = B, follow DPOCO by DPOSL.
//
// To compute inverse(A)*C, follow DPOCO by DPOSL.
//
// To compute determinant(A), follow DPOCO by DPODI.
//
// To compute inverse(A), follow DPOCO by DPODI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 06 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double A[LDA*N]. On input, the symmetric
// matrix to be factored. Only the diagonal and upper triangle are used.
// On output, an upper triangular matrix R so that A = R'*R where R'
// is the transpose. The strict lower triangle is unaltered.
// If INFO /= 0, the factorization is not complete.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int N, the order of the matrix.
//
// Output, double Z[N], a work vector whose contents are usually
// unimportant. If A is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
// If INFO /= 0, Z is unchanged.
//
// Output, double DPOCO, an estimate of the reciprocal
// condition of A. For the system A*X = B, relative perturbations in
// A and B of size EPSILON may cause relative perturbations in X of
// size EPSILON/RCOND. If RCOND is so small that the logical expression
// 1.0D+00 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
int i;
int j;
int k;
double rcond;
double s;
double t;
//
// Find norm of A using only upper half.
//
for (j = 1; j <= n; j++)
{
z[j - 1] = BLAS1D.dasum(j, a, 1, index: +0 + (j - 1) * lda);
for (i = 1; i <= j - 1; i++)
{
z[i - 1] += Math.Abs(a[i - 1 + (j - 1) * lda]);
}
}
double anorm = 0.0;
for (i = 1; i <= n; i++)
{
anorm = Math.Max(anorm, z[i - 1]);
}
//
// Factor.
//
int info = DPOFA.dpofa(ref a, lda, n);
if (info != 0)
{
rcond = 0.0;
return(rcond);
}
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A*Z = Y and A*Y = E.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where R'*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve R' * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
for (k = 1; k <= n; k++)
{
if (z[k - 1] != 0.0)
{
ek *= typeMethods.r8_sign(-z[k - 1]);
}
if (a[k - 1 + (k - 1) * lda] < Math.Abs(ek - z[k - 1]))
{
s = a[k - 1 + (k - 1) * lda] / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
wk /= a[k - 1 + (k - 1) * lda];
wkm /= a[k - 1 + (k - 1) * lda];
if (k + 1 <= n)
{
for (j = k + 1; j <= n; j++)
{
sm += Math.Abs(z[j - 1] + wkm * a[k - 1 + (j - 1) * lda]);
z[j - 1] += wk * a[k - 1 + (j - 1) * lda];
s += Math.Abs(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
for (j = k + 1; j <= n; j++)
{
z[j - 1] += t * a[k - 1 + (j - 1) * lda];
}
}
}
z[k - 1] = wk;
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
//
// Solve R * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
}
z[k - 1] /= a[k - 1 + (k - 1) * lda];
t = -z[k - 1];
BLAS1D.daxpy(k - 1, t, a, 1, ref z, 1, xIndex: +0 + (k - 1) * lda);
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
double ynorm = 1.0;
//
// Solve R' * V = Y.
//
for (k = 1; k <= n; k++)
{
z[k - 1] -= BLAS1D.ddot(k - 1, a, 1, z, 1, xIndex: +0 + (k - 1) * lda);
if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= a[k - 1 + (k - 1) * lda];
}
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
//
// Solve R * Z = V.
//
for (k = n; 1 <= k; k--)
{
if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= a[k - 1 + (k - 1) * lda];
t = -z[k - 1];
BLAS1D.daxpy(k - 1, t, a, 1, ref z, 1, xIndex: +0 + (k - 1) * lda);
}
//
// Make ZNORM = 1.0.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static double dppco(ref double[] ap, int n, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DPPCO factors a real symmetric positive definite matrix in packed form.
//
// Discussion:
//
// DPPCO also estimates the condition of the matrix.
//
// If RCOND is not needed, DPPFA is slightly faster.
//
// To solve A*X = B, follow DPPCO by DPPSL.
//
// To compute inverse(A)*C, follow DPPCO by DPPSL.
//
// To compute determinant(A), follow DPPCO by DPPDI.
//
// To compute inverse(A), follow DPPCO by DPPDI.
//
// Packed storage:
//
// The following program segment will pack the upper triangle of
// a symmetric matrix.
//
// k = 0
// do j = 1, n
// do i = 1, j
// k = k + 1
// ap[k-1] = a(i,j)
// }
// }
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 07 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double AP[N*(N+1)/2]. On input, the packed
// form of a symmetric matrix A. The columns of the upper triangle are
// stored sequentially in a one-dimensional array. On output, an upper
// triangular matrix R, stored in packed form, so that A = R'*R.
// If INFO /= 0, the factorization is not complete.
//
// Input, int N, the order of the matrix.
//
// Output, double Z[N], a work vector whose contents are usually
// unimportant. If A is singular to working precision, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
// If INFO /= 0, Z is unchanged.
//
// Output, double DPPCO, an estimate of the reciprocal condition number RCOND
// of A. For the system A*X = B, relative perturbations in A and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
int i;
int j;
int k;
double rcond;
double s;
double t;
//
// Find the norm of A.
//
int j1 = 1;
for (j = 1; j <= n; j++)
{
z[j - 1] = BLAS1D.dasum(j, ap, 1, index: +j1 - 1);
int ij = j1;
j1 += j;
for (i = 1; i <= j - 1; i++)
{
z[i - 1] += Math.Abs(ap[ij - 1]);
ij += 1;
}
}
double anorm = 0.0;
for (i = 1; i <= n; i++)
{
anorm = Math.Max(anorm, z[i - 1]);
}
//
// Factor.
//
int info = DPPFA.dppfa(ref ap, n);
if (info != 0)
{
rcond = 0.0;
return(rcond);
}
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A * Z = Y and A * Y = E.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where R'*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve R' * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
int kk = 0;
for (k = 1; k <= n; k++)
{
kk += k;
if (z[k - 1] != 0.0)
{
ek *= typeMethods.r8_sign(-z[k - 1]);
}
if (ap[kk - 1] < Math.Abs(ek - z[k - 1]))
{
s = ap[kk - 1] / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
wk /= ap[kk - 1];
wkm /= ap[kk - 1];
int kj = kk + k;
if (k + 1 <= n)
{
for (j = k + 1; j <= n; j++)
{
sm += Math.Abs(z[j - 1] + wkm * ap[kj - 1]);
z[j - 1] += wk * ap[kj - 1];
s += Math.Abs(z[j - 1]);
kj += j;
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
kj = kk + k;
for (j = k + 1; j <= n; j++)
{
z[j - 1] += t * ap[kj - 1];
kj += j;
}
}
}
z[k - 1] = wk;
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
//
// Solve R * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (ap[kk - 1] < Math.Abs(z[k - 1]))
{
s = ap[kk - 1] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
}
z[k - 1] /= ap[kk - 1];
kk -= k;
t = -z[k - 1];
BLAS1D.daxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk);
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
double ynorm = 1.0;
//
// Solve R' * V = Y.
//
for (k = 1; k <= n; k++)
{
z[k - 1] -= BLAS1D.ddot(k - 1, ap, 1, z, 1, xIndex: +kk);
kk += k;
if (ap[kk - 1] < Math.Abs(z[k - 1]))
{
s = ap[kk - 1] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= ap[kk - 1];
}
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
//
// Solve R * Z = V.
//
for (k = n; 1 <= k; k--)
{
if (ap[kk - 1] < Math.Abs(z[k - 1]))
{
s = ap[kk - 1] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= ap[kk - 1];
kk -= k;
t = -z[k - 1];
BLAS1D.daxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk);
}
//
// Make ZNORM = 1.0.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static double dspco(ref double[] ap, int n, ref int[] kpvt, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DSPCO factors a real symmetric matrix stored in packed form.
//
// Discussion:
//
// DSPCO uses elimination with symmetric pivoting and estimates
// the condition of the matrix.
//
// If RCOND is not needed, DSPFA is slightly faster.
//
// To solve A*X = B, follow DSPCO by DSPSL.
//
// To compute inverse(A)*C, follow DSPCO by DSPSL.
//
// To compute inverse(A), follow DSPCO by DSPDI.
//
// To compute determinant(A), follow DSPCO by DSPDI.
//
// To compute inertia(A), follow DSPCO by DSPDI.
//
// Packed storage:
//
// The following program segment will pack the upper triangle of a
// symmetric matrix.
//
// k = 0
// do j = 1, n
// do i = 1, j
// k = k + 1
// ap[k-1] = a(i,j)
// }
// }
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 07 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double AP[N*(N+1)/2]. On input, the packed form
// of a symmetric matrix A. The columns of the upper triangle are stored
// sequentially in a one-dimensional array. On output, a block diagonal
// matrix and the multipliers which were used to obtain it, stored in
// packed form. The factorization can be written A = U*D*U'
// where U is a product of permutation and unit upper triangular
// matrices, U' is the transpose of U, and D is block diagonal
// with 1 by 1 and 2 by 2 blocks.
//
// Input, int N, the order of the matrix.
//
// Output, int KPVT[N], the pivot indices.
//
// Output, double Z[N] a work vector whose contents are usually
// unimportant. If A is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
//
// Output, double DSPCO, an estimate of the reciprocal condition number RCOND
// of A. For the system A*X = B, relative perturbations in A and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
double ak;
double akm1;
double bk;
double bkm1;
double denom;
int i;
int ikm1;
int ikp1;
int j;
int kk;
int km1k;
int km1km1;
int kp;
int kps;
int ks;
double rcond;
double s;
double t;
//
// Find norm of A using only upper half.
//
int j1 = 1;
for (j = 1; j <= n; j++)
{
z[j - 1] = BLAS1D.dasum(j, ap, 1, index: +j1 - 1);
int ij = j1;
j1 += j;
for (i = 1; i <= j - 1; i++)
{
z[i - 1] += Math.Abs(ap[ij - 1]);
ij += 1;
}
}
double anorm = 0.0;
for (i = 1; i <= n; i++)
{
anorm = Math.Max(anorm, z[i - 1]);
}
//
// Factor.
//
DSPFA.dspfa(ref ap, n, ref kpvt);
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A*Z = Y and A*Y = E.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where U*D*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve U * D * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
int k = n;
int ik = n * (n - 1) / 2;
while (k != 0)
{
kk = ik + k;
ikm1 = ik - (k - 1);
ks = kpvt[k - 1] switch
{
public static double dsico(ref double[] a, int lda, int n, ref int[] kpvt, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DSICO factors a real symmetric matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, DSIFA is slightly faster.
//
// To solve A * X = B, follow DSICO by DSISL.
//
// To compute inverse(A)*C, follow DSICO by DSISL.
//
// To compute inverse(A), follow DSICO by DSIDI.
//
// To compute determinant(A), follow DSICO by DSIDI.
//
// To compute inertia(A), follow DSICO by DSIDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 07 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double A[LDA*N]. On input, the symmetric
// matrix to be factored. Only the diagonal and upper triangle are used.
// On output, a block diagonal matrix and the multipliers which
// were used to obtain it. The factorization can be written A = U*D*U'
// where U is a product of permutation and unit upper triangular
// matrices, U' is the transpose of U, and D is block diagonal
// with 1 by 1 and 2 by 2 blocks.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int N, the order of the matrix.
//
// Output, int KPVT[N], pivot indices.
//
// Output, double Z[N], a work vector whose contents are usually
// unimportant. If A is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
//
// Output, double DSICO, an estimate of the reciprocal condition number RCOND
// of A. For the system A*X = B, relative perturbations in A and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
double ak;
double akm1;
double bk;
double bkm1;
double denom;
int i;
int j;
int kp;
int kps;
int ks;
double rcond;
double s;
double t;
//
// Find the norm of A, using only entries in the upper half of the matrix.
//
for (j = 1; j <= n; j++)
{
z[j - 1] = BLAS1D.dasum(j, a, 1, index: +0 + (j - 1) * lda);
for (i = 1; i <= j - 1; i++)
{
z[i - 1] += Math.Abs(a[i - 1 + (j - 1) * lda]);
}
}
double anorm = 0.0;
for (i = 1; i <= n; i++)
{
anorm = Math.Max(anorm, z[i - 1]);
}
//
// Factor.
//
DSIFA.dsifa(ref a, lda, n, ref kpvt);
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A*Z = Y and A*Y = E.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where U*D*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve U * D * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
int k = n;
while (k != 2)
{
ks = kpvt[k - 1] switch
{
public static double dtrco(double[] t, int ldt, int n, ref double[] z, int job)
//****************************************************************************80
//
// Purpose:
//
// DTRCO estimates the condition of a real triangular matrix.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 25 May 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input, double T[LDT*N], the triangular matrix. The zero
// elements of the matrix are not referenced, and the corresponding
// elements of the array can be used to store other information.
//
// Input, int LDT, the leading dimension of the array T.
//
// Input, int N, the order of the matrix.
//
// Output, double Z[N] a work vector whose contents are usually
// unimportant. If T is close to a singular matrix, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
//
// Input, int JOB, indicates the shape of T:
// 0, T is lower triangular.
// nonzero, T is upper triangular.
//
// Output, double DTRCO, an estimate of the reciprocal condition RCOND
// of T. For the system T*X = B, relative perturbations in T and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0D+00 + RCOND == 1.0D+00
// is true, then T may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
int i;
int i1;
int j;
int k;
int kk;
double rcond;
double s;
double w;
bool lower = job == 0;
//
// Compute the 1-norm of T.
//
double tnorm = 0.0;
for (j = 1; j <= n; j++)
{
int l;
switch (lower)
{
case true:
l = n + 1 - j;
i1 = j;
break;
default:
l = j;
i1 = 1;
break;
}
tnorm = Math.Max(tnorm, BLAS1D.dasum(l, t, 1, index: +i1 - 1 + (j - 1) * ldt));
}
//
// RCOND = 1/(norm(T)*(estimate of norm(inverse(T)))).
//
// Estimate = norm(Z)/norm(Y) where T * Z = Y and T' * Y = E.
//
// T' is the transpose of T.
//
// The components of E are chosen to cause maximum local
// growth in the elements of Y.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve T' * Y = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
for (kk = 1; kk <= n; kk++)
{
k = lower switch
{
true => n + 1 - kk,
_ => kk
};
if (z[k - 1] != 0.0)
{
ek = typeMethods.r8_sign(-z[k - 1]) * ek;
}
if (Math.Abs(t[k - 1 + (k - 1) * ldt]) < Math.Abs(ek - z[k - 1]))
{
s = Math.Abs(t[k - 1 + (k - 1) * ldt]) / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
if (t[k - 1 + (k - 1) * ldt] != 0.0)
{
wk /= t[k - 1 + (k - 1) * ldt];
wkm /= t[k - 1 + (k - 1) * ldt];
}
else
{
wk = 1.0;
wkm = 1.0;
}
if (kk != n)
{
int j2;
int j1;
switch (lower)
{
case true:
j1 = 1;
j2 = k - 1;
break;
default:
j1 = k + 1;
j2 = n;
break;
}
for (j = j1; j <= j2; j++)
{
sm += Math.Abs(z[j - 1] + wkm * t[k - 1 + (j - 1) * ldt]);
z[j - 1] += wk * t[k - 1 + (j - 1) * ldt];
s += Math.Abs(z[j - 1]);
}
if (s < sm)
{
w = wkm - wk;
wk = wkm;
for (j = j1; j <= j2; j++)
{
z[j - 1] += w * t[k - 1 + (j - 1) * ldt];
}
}
}
z[k - 1] = wk;
}
double temp = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= temp;
}
double ynorm = 1.0;
//
// Solve T * Z = Y.
//
for (kk = 1; kk <= n; kk++)
{
k = lower switch
{
true => kk,
_ => n + 1 - kk
};
if (Math.Abs(t[k - 1 + (k - 1) * ldt]) < Math.Abs(z[k - 1]))
{
s = Math.Abs(t[k - 1 + (k - 1) * ldt]) / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
if (t[k - 1 + (k - 1) * ldt] != 0.0)
{
z[k - 1] /= t[k - 1 + (k - 1) * ldt];
}
else
{
z[k - 1] = 1.0;
}
i1 = lower switch
{
true => k + 1,
_ => 1
};
if (kk >= n)
{
continue;
}
w = -z[k - 1];
BLAS1D.daxpy(n - kk, w, t, 1, ref z, 1, xIndex: +i1 - 1 + (k - 1) * ldt, yIndex: +i1 - 1);
}
//
// Make ZNORM = 1.0.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (tnorm != 0.0)
{
rcond = ynorm / tnorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
}
public static double dpbco(ref double[] abd, int lda, int n, int m, ref double[] z)
//****************************************************************************80
//
// Purpose:
//
// DPBCO factors a real symmetric positive definite banded matrix.
//
// Discussion:
//
// DPBCO also estimates the condition of the matrix.
//
// If RCOND is not needed, DPBFA is slightly faster.
//
// To solve A*X = B, follow DPBCO by DPBSL.
//
// To compute inverse(A)*C, follow DPBCO by DPBSL.
//
// To compute determinant(A), follow DPBCO by DPBDI.
//
// Band storage:
//
// If A is a symmetric positive definite band matrix, the following
// program segment will set up the input.
//
// m = (band width above diagonal)
// do j = 1, n
// i1 = max (1, j-m)
// do i = i1, j
// k = i-j+m+1
// abd(k,j) = a(i,j)
// }
// }
//
// This uses M + 1 rows of A, except for the M by M upper left triangle,
// which is ignored.
//
// For example, if the original matrix is
//
// 11 12 13 0 0 0
// 12 22 23 24 0 0
// 13 23 33 34 35 0
// 0 24 34 44 45 46
// 0 0 35 45 55 56
// 0 0 0 46 56 66
//
// then N = 6, M = 2 and ABD should contain
//
// * * 13 24 35 46
// * 12 23 34 45 56
// 11 22 33 44 55 66
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 07 June 2005
//
// Author:
//
// Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch,
// Pete Stewart.
// C++ version by John Burkardt.
//
// Reference:
//
// Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
// LINPACK User's Guide,
// SIAM, (Society for Industrial and Applied Mathematics),
// 3600 University City Science Center,
// Philadelphia, PA, 19104-2688.
// ISBN 0-89871-172-X
//
// Parameters:
//
// Input/output, double ABD[LDA*N]. On input, the matrix to be
// factored. The columns of the upper triangle are stored in the columns
// of ABD and the diagonals of the upper triangle are stored in the rows
// of ABD. On output, an upper triangular matrix R, stored in band form,
// so that A = R'*R. If INFO /= 0, the factorization is not complete.
//
// Input, int LDA, the leading dimension of the array ABD.
// M+1 <= LDA is required.
//
// Input, int N, the order of the matrix.
//
// Input, int M, the number of diagonals above the main diagonal.
//
// Output, double Z[N], a work vector whose contents are usually
// unimportant. If A is singular to working precision, then Z is an
// approximate null vector in the sense that
// norm(A*Z) = RCOND * norm(A) * norm(Z).
// If INFO /= 0, Z is unchanged.
//
// Output, double DPBCO, an estimate of the reciprocal condition number
// RCOND. For the system A*X = B, relative perturbations in A and B of size
// EPSILON may cause relative perturbations in X of size EPSILON/RCOND.
// If RCOND is so small that the logical expression
// 1.0 + RCOND == 1.0D+00
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
{
int i;
int j;
int k;
int la;
int lb;
int lm;
double rcond;
double s;
double t;
//
// Find the norm of A.
//
for (j = 1; j <= n; j++)
{
int l = Math.Min(j, m + 1);
int mu = Math.Max(m + 2 - j, 1);
z[j - 1] = BLAS1D.dasum(l, abd, 1, index: +mu - 1 + (j - 1) * lda);
k = j - l;
for (i = mu; i <= m; i++)
{
k += 1;
z[k - 1] += Math.Abs(abd[i - 1 + (j - 1) * lda]);
}
}
double anorm = 0.0;
for (i = 1; i <= n; i++)
{
anorm = Math.Max(anorm, z[i - 1]);
}
//
// Factor.
//
int info = DPBFA.dpbfa(ref abd, lda, n, m);
if (info != 0)
{
rcond = 0.0;
return(rcond);
}
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A*Z = Y and A*Y = E.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where R'*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve R' * W = E.
//
double ek = 1.0;
for (i = 1; i <= n; i++)
{
z[i - 1] = 0.0;
}
for (k = 1; k <= n; k++)
{
if (z[k - 1] != 0.0)
{
ek *= typeMethods.r8_sign(-z[k - 1]);
}
if (abd[m + (k - 1) * lda] < Math.Abs(ek - z[k - 1]))
{
s = abd[m + (k - 1) * lda] / Math.Abs(ek - z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ek = s * ek;
}
double wk = ek - z[k - 1];
double wkm = -ek - z[k - 1];
s = Math.Abs(wk);
double sm = Math.Abs(wkm);
wk /= abd[m + (k - 1) * lda];
wkm /= abd[m + (k - 1) * lda];
int j2 = Math.Min(k + m, n);
i = m + 1;
if (k + 1 <= j2)
{
for (j = k + 1; j <= j2; j++)
{
i -= 1;
sm += Math.Abs(z[j - 1] + wkm * abd[i - 1 + (j - 1) * lda]);
z[j - 1] += wk * abd[i - 1 + (j - 1) * lda];
s += Math.Abs(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
i = m + 1;
for (j = k + 1; j <= j2; j++)
{
i -= 1;
z[j - 1] += t * abd[i - 1 + (j - 1) * lda];
}
}
}
z[k - 1] = wk;
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
//
// Solve R * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (abd[m + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = abd[m + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
}
z[k - 1] /= abd[m + (k - 1) * lda];
lm = Math.Min(k - 1, m);
la = m + 1 - lm;
lb = k - lm;
t = -z[k - 1];
BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
s = BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] /= s;
}
double ynorm = 1.0;
//
// Solve R' * V = Y.
//
for (k = 1; k <= n; k++)
{
lm = Math.Min(k - 1, m);
la = m + 1 - lm;
lb = k - lm;
z[k - 1] -= BLAS1D.ddot(lm, abd, 1, z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
if (abd[m + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = abd[m + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= abd[m + (k - 1) * lda];
}
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
//
// Solve R * Z = W.
//
for (k = n; 1 <= k; k--)
{
if (abd[m + (k - 1) * lda] < Math.Abs(z[k - 1]))
{
s = abd[m + (k - 1) * lda] / Math.Abs(z[k - 1]);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
}
z[k - 1] /= abd[m + (k - 1) * lda];
lm = Math.Min(k - 1, m);
la = m + 1 - lm;
lb = k - lm;
t = -z[k - 1];
BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
//
// Make ZNORM = 1.0.
//
s = 1.0 / BLAS1D.dasum(n, z, 1);
for (i = 1; i <= n; i++)
{
z[i - 1] = s * z[i - 1];
}
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}