public static int dspfa(ref double[] ap, int n, ref int[] kpvt)
//****************************************************************************80
//
// Purpose:
//
// DSPFA factors a real symmetric matrix stored in packed form.
//
// Discussion:
//
// To solve A*X = B, follow DSPFA by DSPSL.
//
// To compute inverse(A)*C, follow DSPFA by DSPSL.
//
// To compute determinant(A), follow DSPFA by DSPDI.
//
// To compute inertia(A), follow DSPFA by DSPDI.
//
// To compute inverse(A), follow DSPFA 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) = a(i,j)
// end do
// end do
//
// 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 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, int DSPFA, error flag.
// 0, normal value.
// K, if the K-th pivot block is singular. This is not an error
// condition for this subroutine, but it does indicate that DSPSL or
// DSPDI may divide by zero if called.
//
{
int im = 0;
//
// ALPHA is used in choosing pivot block size.
//
double alpha = (1.0 + Math.Sqrt(17.0)) / 8.0;
int info = 0;
//
// Main loop on K, which goes from N to 1.
//
int k = n;
int ik = n * (n - 1) / 2;
for (;;)
{
//
// Leave the loop if K = 0 or K = 1.
//
if (k == 0)
{
break;
}
if (k == 1)
{
kpvt[0] = 1;
info = ap[0] switch
{
0.0 => 1,
_ => info
};
break;
}
//
// This section of code determines the kind of elimination to be performed.
// When it is completed, KSTEP will be set to the size of the pivot block,
// and SWAP will be set to .true. if an interchange is required.
//
int km1 = k - 1;
int kk = ik + k;
double absakk = Math.Abs(ap[kk - 1]);
//
// Determine the largest off-diagonal element in column K.
//
int imax = BLAS1D.idamax(k - 1, ap, 1, index: +ik);
int imk = ik + imax;
double colmax = Math.Abs(ap[imk - 1]);
int kstep;
bool swap;
int j;
int imj;
if (alpha * colmax <= absakk)
{
kstep = 1;
swap = false;
}
//
// Determine the largest off-diagonal element in row IMAX.
//
else
{
double rowmax = 0.0;
int imaxp1 = imax + 1;
im = imax * (imax - 1) / 2;
imj = im + 2 * imax;
for (j = imaxp1; j <= k; j++)
{
rowmax = Math.Max(rowmax, Math.Abs(ap[imj - 1]));
imj += j;
}
if (imax != 1)
{
int jmax = BLAS1D.idamax(imax - 1, ap, 1, index: +im);
int jmim = jmax + im;
rowmax = Math.Max(rowmax, Math.Abs(ap[jmim - 1]));
}
int imim = imax + im;
if (alpha * rowmax <= Math.Abs(ap[imim - 1]))
{
kstep = 1;
swap = true;
}
else if (alpha * colmax * (colmax / rowmax) <= absakk)
{
kstep = 1;
swap = false;
}
else
{
kstep = 2;
swap = imax != km1;
}
}
switch (Math.Max(absakk, colmax))
{
//
// Column K is zero. Set INFO and iterate the loop.
//
case 0.0:
kpvt[k - 1] = k;
info = k;
break;
default:
{
double mulk;
int jk;
int jj;
double t;
int ij;
if (kstep != 2)
{
switch (swap)
{
//
// 1 x 1 pivot block.
//
case true:
{
//
// Perform an interchange.
//
BLAS1D.dswap(imax, ref ap, 1, ref ap, 1, xIndex: +im, yIndex: +ik);
imj = ik + imax;
for (jj = imax; jj <= k; jj++)
{
j = k + imax - jj;
jk = ik + j;
t = ap[jk - 1];
ap[jk - 1] = ap[imj - 1];
ap[imj - 1] = t;
imj -= j - 1;
}
break;
}
}
//
// Perform the elimination.
//
ij = ik - (k - 1);
for (jj = 1; jj <= km1; jj++)
{
j = k - jj;
jk = ik + j;
mulk = -ap[jk - 1] / ap[kk - 1];
t = mulk;
BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij);
ap[jk - 1] = mulk;
ij -= j - 1;
}
kpvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => imax,
_ => k
};
}
else
{
//
// 2 x 2 pivot block.
//
int km1k = ik + k - 1;
int ikm1 = ik - (k - 1);
int jkm1;
switch (swap)
{
//
// Perform an interchange.
//
case true:
{
BLAS1D.dswap(imax, ref ap, 1, ref ap, 1, xIndex: +im, yIndex: +ikm1);
imj = ikm1 + imax;
for (jj = imax; jj <= km1; jj++)
{
j = km1 + imax - jj;
jkm1 = ikm1 + j;
t = ap[jkm1 - 1];
ap[jkm1 - 1] = ap[imj - 1];
ap[imj - 1] = t;
imj -= j - 1;
}
t = ap[km1k - 1];
ap[km1k - 1] = ap[imk - 1];
ap[imk - 1] = t;
break;
}
}
//
// Perform the elimination.
//
if (k - 2 != 0)
{
double ak = ap[kk - 1] / ap[km1k - 1];
int km1km1 = ikm1 + k - 1;
double akm1 = ap[km1km1 - 1] / ap[km1k - 1];
double denom = 1.0 - ak * akm1;
ij = ik - (k - 1) - (k - 2);
for (jj = 1; jj <= k - 2; jj++)
{
j = km1 - jj;
jk = ik + j;
double bk = ap[jk - 1] / ap[km1k - 1];
jkm1 = ikm1 + j;
double bkm1 = ap[jkm1 - 1] / ap[km1k - 1];
mulk = (akm1 * bk - bkm1) / denom;
double mulkm1 = (ak * bkm1 - bk) / denom;
t = mulk;
BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij);
t = mulkm1;
BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ikm1, yIndex: +ij);
ap[jk - 1] = mulk;
ap[jkm1 - 1] = mulkm1;
ij -= j - 1;
}
}
kpvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => - imax,
_ => 1 - k
};
kpvt[k - 2] = kpvt[k - 1];
}
break;
}
}
ik -= k - 1;
switch (kstep)
{
case 2:
ik -= k - 2;
break;
}
k -= kstep;
}
return(info);
}
}
public static void dspdi(ref double[] ap, int n, int[] kpvt, ref double[] det, ref int[] inert,
double[] work, int job)
//****************************************************************************80
//
// Purpose:
//
// DSPDI computes the determinant, inertia and inverse of a real symmetric matrix.
//
// Discussion:
//
// DSPDI uses the factors from DSPFA, where the matrix is stored in
// packed form.
//
// A division by zero will occur if the inverse is requested
// and DSPCO has set RCOND == 0.0D+00 or DSPFA has set INFO /= 0.
//
// Variables not requested by JOB are not used.
//
// 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 AP[(N*(N+1))/2]. On input, the output from
// DSPFA. On output, the upper triangle of the inverse of the original
// matrix, stored in packed form, if requested. The columns of the upper
// triangle are stored sequentially in a one-dimensional array.
//
// Input, int N, the order of the matrix.
//
// Input, int KPVT[N], the pivot vector from DSPFA.
//
// Output, double DET[2], the determinant of the original matrix,
// if requested.
// determinant = DET[0] * 10.0**DET[1]
// with 1.0D+00 <= abs ( DET[0] ) < 10.0D+00 or DET[0] = 0.0.
//
// Output, int INERT[3], the inertia of the original matrix, if requested.
// INERT(1) = number of positive eigenvalues.
// INERT(2) = number of negative eigenvalues.
// INERT(3) = number of zero eigenvalues.
//
// Workspace, double WORK[N].
//
// Input, int JOB, has the decimal expansion ABC where:
// if A /= 0, the inertia is computed,
// if B /= 0, the determinant is computed,
// if C /= 0, the inverse is computed.
// For example, JOB = 111 gives all three.
//
{
double d;
int ik;
int ikp1;
int k;
int kk;
int kkp1;
double t;
bool doinv = job % 10 != 0;
bool dodet = job % 100 / 10 != 0;
bool doert = job % 1000 / 100 != 0;
if (dodet || doert)
{
switch (doert)
{
case true:
inert[0] = 0;
inert[1] = 0;
inert[2] = 0;
break;
}
switch (dodet)
{
case true:
det[0] = 1.0;
det[1] = 0.0;
break;
}
t = 0.0;
ik = 0;
for (k = 1; k <= n; k++)
{
kk = ik + k;
d = ap[kk - 1];
switch (kpvt[k - 1])
{
//
// 2 by 2 block
// use det (d s) = (d/t * c - t) * t, t = abs ( s )
// (s c)
// to avoid underflow/overflow troubles.
//
// Take two passes through scaling. Use T for flag.
//
case <= 0 when t == 0.0:
ikp1 = ik + k;
kkp1 = ikp1 + k;
t = Math.Abs(ap[kkp1 - 1]);
d = d / t * ap[kkp1] - t;
break;
case <= 0:
d = t;
t = 0.0;
break;
}
switch (doert)
{
case true:
switch (d)
{
case > 0.0:
inert[0] += 1;
break;
case < 0.0:
inert[1] += 1;
break;
case 0.0:
inert[2] += 1;
break;
}
break;
}
switch (dodet)
{
case true:
{
det[0] *= d;
if (det[0] != 0.0)
{
while (Math.Abs(det[0]) < 1.0)
{
det[0] *= 10.0;
det[1] -= 1.0;
}
while (10.0 <= Math.Abs(det[0]))
{
det[0] /= 10.0;
det[1] += 1.0;
}
}
break;
}
}
ik += k;
}
}
switch (doinv)
{
//
// Compute inverse(A).
//
case true:
{
k = 1;
ik = 0;
while (k <= n)
{
int km1 = k - 1;
kk = ik + k;
ikp1 = ik + k;
kkp1 = ikp1 + k;
int kstep;
int jk;
int j;
int ij;
switch (kpvt[k - 1])
{
case >= 0:
{
//
// 1 by 1.
//
ap[kk - 1] = 1.0 / ap[kk - 1];
switch (k)
{
case >= 2:
{
BLAS1D.dcopy(k - 1, ap, 1, ref work, 1, xIndex: +ik);
ij = 0;
for (j = 1; j <= k - 1; j++)
{
jk = ik + j;
ap[jk - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij);
BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik);
ij += j;
}
ap[kk - 1] += BLAS1D.ddot(k - 1, work, 1, ap, 1, yIndex: +ik);
break;
}
}
kstep = 1;
break;
}
default:
{
//
// 2 by 2.
//
t = Math.Abs(ap[kkp1 - 1]);
double ak = ap[kk - 1] / t;
double akp1 = ap[kkp1] / t;
double akkp1 = ap[kkp1 - 1] / t;
d = t * (ak * akp1 - 1.0);
ap[kk - 1] = akp1 / d;
ap[kkp1] = ak / d;
ap[kkp1 - 1] = -akkp1 / d;
switch (km1)
{
case >= 1:
{
BLAS1D.dcopy(km1, ap, 1, ref work, 1, xIndex: +ikp1);
ij = 0;
for (j = 1; j <= km1; j++)
{
int jkp1 = ikp1 + j;
ap[jkp1 - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij);
BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ikp1);
ij += j;
}
ap[kkp1] += BLAS1D.ddot(km1, work, 1, ap, 1, yIndex: +ikp1);
ap[kkp1 - 1] += BLAS1D.ddot(km1, ap, 1, ap, 1, xIndex: +ik, yIndex: +ikp1);
BLAS1D.dcopy(km1, ap, 1, ref work, 1, xIndex: +ik);
ij = 0;
for (j = 1; j <= km1; j++)
{
jk = ik + j;
ap[jk - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij);
BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik);
ij += j;
}
ap[kk - 1] += BLAS1D.ddot(km1, work, 1, ap, 1, yIndex: +ik);
break;
}
}
kstep = 2;
break;
}
}
//
// Swap.
//
int ks = Math.Abs(kpvt[k - 1]);
if (ks != k)
{
int iks = ks * (ks - 1) / 2;
BLAS1D.dswap(ks, ref ap, 1, ref ap, 1, xIndex: +iks, yIndex: +ik);
int ksj = ik + ks;
double temp;
int jb;
for (jb = ks; jb <= k; jb++)
{
j = k + ks - jb;
jk = ik + j;
temp = ap[jk - 1];
ap[jk - 1] = ap[ksj - 1];
ap[ksj - 1] = temp;
ksj -= j - 1;
}
if (kstep != 1)
{
int kskp1 = ikp1 + ks;
temp = ap[kskp1 - 1];
ap[kskp1 - 1] = ap[kkp1 - 1];
ap[kkp1 - 1] = temp;
}
}
ik += k;
ik = kstep switch
{
2 => ik + k + 1,
_ => ik
};
k += kstep;
}
break;
}
}
}
}
private static void dswap_test()
//****************************************************************************80
//
// Purpose:
//
// DSWAP_TEST tests DSWAP.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 15 May 2006
//
// Author:
//
// John Burkardt
//
{
int N = 6;
double[] x = new double[N];
double[] y = new double[N];
for (int i = 0; i < N; i++)
{
x[i] = i + 1;
}
for (int i = 0; i < N; i++)
{
y[i] = 100 * (i + 1);
}
Console.WriteLine("");
Console.WriteLine("DSWAP_TEST");
Console.WriteLine(" DSWAP swaps two vectors.");
Console.WriteLine("");
Console.WriteLine(" X and Y:");
Console.WriteLine("");
for (int i = 0; i < N; i++)
{
Console.WriteLine(" "
+ (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " "
+ x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " "
+ y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + "");
}
BLAS1D.dswap(N, ref x, 1, ref y, 1);
Console.WriteLine("");
Console.WriteLine(" DSWAP ( N, X, 1, Y, 1 )");
Console.WriteLine("");
Console.WriteLine(" X and Y:");
Console.WriteLine("");
for (int i = 0; i < N; i++)
{
Console.WriteLine(" "
+ (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " "
+ x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " "
+ y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + "");
}
for (int i = 0; i < N; i++)
{
x[i] = i + 1;
}
for (int i = 0; i < N; i++)
{
y[i] = 100 * (i + 1);
}
BLAS1D.dswap(3, ref x, 2, ref y, 1);
Console.WriteLine("");
Console.WriteLine(" DSWAP ( 3, X, 2, Y, 1 )");
Console.WriteLine("");
Console.WriteLine(" X and Y:");
Console.WriteLine("");
for (int i = 0; i < N; i++)
{
Console.WriteLine(" "
+ (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " "
+ x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " "
+ y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + "");
}
}
public static int dchdc(ref double[] a, int lda, int p, double[] work, ref int[] ipvt, int job)
//****************************************************************************80
//
// Purpose:
//
// DCHDC computes the Cholesky decomposition of a positive definite matrix.
//
// Discussion:
//
// A pivoting option allows the user to estimate the condition of a
// positive definite matrix or determine the rank of a positive
// semidefinite matrix.
//
// For positive definite matrices, INFO = P is the normal return.
//
// For pivoting with positive semidefinite matrices, INFO will
// in general be less than P. However, INFO may be greater than
// the rank of A, since rounding error can cause an otherwise zero
// element to be positive. Indefinite systems will always cause
// INFO to be less than P.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 23 June 2009
//
// 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*P].
// On input, A contains the matrix whose decomposition is to
// be computed. Only the upper half of A need be stored.
// The lower part of the array a is not referenced.
// On output, A contains in its upper half the Cholesky factor
// of the input matrix, as it has been permuted by pivoting.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int P, the order of the matrix.
//
// Input, double WORK[P] is a work array.
//
// Input/output, int IPVT[P].
// On input, IPVT contains integers that control the selection
// of the pivot elements, if pivoting has been requested.
// Each diagonal element A(K,K) is placed in one of three classes
// according to the value of IPVT(K).
//
// > 0, then X(K) is an initial element.
// = 0, then X(K) is a free element.
// < 0, then X(K) is a final element.
//
// Before the decomposition is computed, initial elements are moved by
// symmetric row and column interchanges to the beginning of the array A
// and final elements to the end. Both initial and final elements are
// frozen in place during the computation and only free elements are moved.
// At the K-th stage of the reduction, if A(K,K) is occupied by a free
// element, it is interchanged with the largest free element A(L,L) with
// K <= L. IPVT is not referenced if JOB is 0.
//
// On output, IPVT(J) contains the index of the diagonal element
// of A that was moved into the J-th position, if pivoting was requested.
//
// Input, int JOB, initiates column pivoting.
// 0, no pivoting is done.
// nonzero, pivoting is done.
//
// Output, int DCHDC, contains the index of the last positive diagonal
// element of the Cholesky factor.
//
{
int j;
int k;
double temp;
int pl = 1;
int pu = 0;
int info = p;
//
// Pivoting has been requested.
// Rearrange the the elements according to IPVT.
//
if (job != 0)
{
for (k = 1; k <= p; k++)
{
bool swapk = 0 < ipvt[k - 1];
bool negk = ipvt[k - 1] < 0;
ipvt[k - 1] = negk switch
{
true => - k,
_ => k
};
switch (swapk)
{
case true:
{
if (k != pl)
{
BLAS1D.dswap(pl - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (pl - 1) * lda);
temp = a[k - 1 + (k - 1) * lda];
a[k - 1 + (k - 1) * lda] = a[pl - 1 + (pl - 1) * lda];
a[pl - 1 + (pl - 1) * lda] = temp;
for (j = pl + 1; j <= p; j++)
{
if (j < k)
{
temp = a[pl - 1 + (j - 1) * lda];
a[pl - 1 + (j - 1) * lda] = a[j - 1 + (k - 1) * lda];
a[j - 1 + (k - 1) * lda] = temp;
}
else if (k < j)
{
temp = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = a[pl - 1 + (j - 1) * lda];
a[pl - 1 + (j - 1) * lda] = temp;
}
}
ipvt[k - 1] = ipvt[pl - 1];
ipvt[pl - 1] = k;
}
pl += 1;
break;
}
}
}
pu = p;
for (k = p; pl <= k; k--)
{
switch (ipvt[k - 1])
{
case < 0:
{
ipvt[k - 1] = -ipvt[k - 1];
if (pu != k)
{
BLAS1D.dswap(k - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (pu - 1) * lda);
temp = a[k - 1 + (k - 1) * lda];
a[k - 1 + (k - 1) * lda] = a[pu - 1 + (pu - 1) * lda];
a[pu - 1 + (pu - 1) * lda] = temp;
for (j = k + 1; j <= p; j++)
{
if (j < pu)
{
temp = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = a[j - 1 + (pu - 1) * lda];
a[j - 1 + (pu - 1) * lda] = temp;
}
else if (pu < j)
{
temp = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = a[pu - 1 + (j - 1) * lda];
a[pu - 1 + (j - 1) * lda] = temp;
}
}
(ipvt[k - 1], ipvt[pu - 1]) = (ipvt[pu - 1], ipvt[k - 1]);
}
pu -= 1;
break;
}
}
}
}
for (k = 1; k <= p; k++)
{
//
// Reduction loop.
//
double maxdia = a[k - 1 + (k - 1) * lda];
int maxl = k;
//
// Determine the pivot element.
//
if (pl <= k && k < pu)
{
int l;
for (l = k + 1; l <= pu; l++)
{
if (!(maxdia < a[l - 1 + (l - 1) * lda]))
{
continue;
}
maxdia = a[l - 1 + (l - 1) * lda];
maxl = l;
}
}
switch (maxdia)
{
//
// Quit if the pivot element is not positive.
//
case <= 0.0:
info = k - 1;
return(info);
}
//
// Start the pivoting and update IPVT.
//
if (k != maxl)
{
BLAS1D.dswap(k - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (maxl - 1) * lda);
a[maxl - 1 + (maxl - 1) * lda] = a[k - 1 + (k - 1) * lda];
a[k - 1 + (k - 1) * lda] = maxdia;
(ipvt[maxl - 1], ipvt[k - 1]) = (ipvt[k - 1], ipvt[maxl - 1]);
}
//
// Reduction step.
// Pivoting is contained across the rows.
//
work[k - 1] = Math.Sqrt(a[k - 1 + (k - 1) * lda]);
a[k - 1 + (k - 1) * lda] = work[k - 1];
for (j = k + 1; j <= p; j++)
{
if (k != maxl)
{
if (j < maxl)
{
temp = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = a[j - 1 + (maxl - 1) * lda];
a[j - 1 + (maxl - 1) * lda] = temp;
}
else if (maxl < j)
{
temp = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = a[maxl - 1 + (j - 1) * lda];
a[maxl - 1 + (j - 1) * lda] = temp;
}
}
a[k - 1 + (j - 1) * lda] /= work[k - 1];
work[j - 1] = a[k - 1 + (j - 1) * lda];
temp = -a[k - 1 + (j - 1) * lda];
BLAS1D.daxpy(j - k, temp, work, 1, ref a, 1, xIndex: +k, yIndex: +k + (j - 1) * lda);
}
}
return(info);
}
}
public static void dgedi(ref double[] a, int lda, int n, int[] ipvt, ref double[] det,
double[] work, int job)
//****************************************************************************80
//
// Purpose:
//
// DGEDI computes the determinant and inverse of a matrix factored by DGECO or DGEFA.
//
// Discussion:
//
// A division by zero will occur if the input factor contains
// a zero on the diagonal and the inverse is requested.
// It will not occur if the subroutines are called correctly
// and if DGECO has set 0.0 < RCOND or DGEFA has set INFO == 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 17 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, the LU factor information,
// as output by DGECO or DGEFA. On output, the inverse
// matrix if requested.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int N, the order of the matrix A.
//
// Input, int IPVT[N], the pivot vector from DGECO or DGEFA.
//
// Workspace, double WORK[N].
//
// Output, double DET[2], the determinant of original matrix if
// requested. The determinant = DET[0] * pow ( 10.0, DET[1] )
// with 1.0 <= abs ( DET[0] ) < 10.0 or DET[0] == 0.0.
//
// Input, int JOB, specifies what is to be computed.
// 11, both determinant and inverse.
// 01, inverse only.
// 10, determinant only.
//
{
int i;
//
// Compute the determinant.
//
if (job / 10 != 0)
{
det[0] = 1.0;
det[1] = 0.0;
for (i = 1; i <= n; i++)
{
if (ipvt[i - 1] != i)
{
det[0] = -det[0];
}
det[0] *= a[i - 1 + (i - 1) * lda];
if (det[0] == 0.0)
{
break;
}
while (Math.Abs(det[0]) < 1.0)
{
det[0] *= 10.0;
det[1] -= 1.0;
}
while (10.0 <= Math.Abs(det[0]))
{
det[0] /= 10.0;
det[1] += 1.0;
}
}
}
//
// Compute inverse(U).
//
if (job % 10 == 0)
{
return;
}
int j;
double t;
int k;
for (k = 1; k <= n; k++)
{
a[k - 1 + (k - 1) * lda] = 1.0 / a[k - 1 + (k - 1) * lda];
t = -a[k - 1 + (k - 1) * lda];
BLAS1D.dscal(k - 1, t, ref a, 1, index: +0 + (k - 1) * lda);
for (j = k + 1; j <= n; j++)
{
t = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = 0.0;
BLAS1D.daxpy(k, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
}
}
//
// Form inverse(U) * inverse(L).
//
for (k = n - 1; 1 <= k; k--)
{
for (i = k + 1; i <= n; i++)
{
work[i - 1] = a[i - 1 + (k - 1) * lda];
a[i - 1 + (k - 1) * lda] = 0.0;
}
for (j = k + 1; j <= n; j++)
{
t = work[j - 1];
BLAS1D.daxpy(n, t, a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda, yIndex: +0 + (k - 1) * lda);
}
int l = ipvt[k - 1];
if (l != k)
{
BLAS1D.dswap(n, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (l - 1) * lda);
}
}
}
public static void dsidi(ref double[] a, int lda, int n, int[] kpvt, ref double[] det,
ref int[] inert, double[] work, int job)
//****************************************************************************80
//
// Purpose:
//
// DSIDI computes the determinant, inertia and inverse of a real symmetric matrix.
//
// Discussion:
//
// DSIDI uses the factors from DSIFA.
//
// A division by zero may occur if the inverse is requested
// and DSICO has set RCOND == 0.0D+00 or DSIFA has set INFO /= 0.
//
// Variables not requested by JOB are not used.
//
// 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, the output from DSIFA.
// On output, the upper triangle of the inverse of the original matrix,
// if requested. The strict lower triangle is never referenced.
//
// Input, int LDA, the leading dimension of the array A.
//
// Input, int N, the order of the matrix.
//
// Input, int KPVT[N], the pivot vector from DSIFA.
//
// Output, double DET[2], the determinant of the original matrix,
// if requested.
// determinant = DET[0] * 10.0**DET[1]
// with 1.0D+00 <= abs ( DET[0] ) < 10.0D+00 or DET[0] = 0.0.
//
// Output, int INERT(3), the inertia of the original matrix,
// if requested.
// INERT(1) = number of positive eigenvalues.
// INERT(2) = number of negative eigenvalues.
// INERT(3) = number of zero eigenvalues.
//
// Workspace, double WORK[N].
//
// Input, int JOB, specifies the tasks.
// JOB has the decimal expansion ABC where
// If C /= 0, the inverse is computed,
// If B /= 0, the determinant is computed,
// If A /= 0, the inertia is computed.
// For example, JOB = 111 gives all three.
//
{
double d;
int k;
double t;
bool doinv = job % 10 != 0;
bool dodet = job % 100 / 10 != 0;
bool doert = job % 1000 / 100 != 0;
if (dodet || doert)
{
switch (doert)
{
case true:
inert[0] = 0;
inert[1] = 0;
inert[2] = 0;
break;
}
switch (dodet)
{
case true:
det[0] = 1.0;
det[1] = 0.0;
break;
}
t = 0.0;
for (k = 1; k <= n; k++)
{
d = a[k - 1 + (k - 1) * lda];
switch (kpvt[k - 1])
{
//
// 2 by 2 block.
//
// use det (d s) = (d/t * c - t) * t, t = abs ( s )
// (s c)
// to avoid underflow/overflow troubles.
//
// Take two passes through scaling. Use T for flag.
//
case <= 0 when t == 0.0:
t = Math.Abs(a[k - 1 + k * lda]);
d = d / t * a[k + k * lda] - t;
break;
case <= 0:
d = t;
t = 0.0;
break;
}
switch (doert)
{
case true:
switch (d)
{
case > 0.0:
inert[0] += 1;
break;
case < 0.0:
inert[1] += 1;
break;
case 0.0:
inert[2] += 1;
break;
}
break;
}
switch (dodet)
{
case true:
{
det[0] *= d;
if (det[0] != 0.0)
{
while (Math.Abs(det[0]) < 1.0)
{
det[0] *= 10.0;
det[1] -= 1.0;
}
while (10.0 <= Math.Abs(det[0]))
{
det[0] /= 10.0;
det[1] += 1.0;
}
}
break;
}
}
}
}
switch (doinv)
{
//
// Compute inverse(A).
//
case true:
{
k = 1;
while (k <= n)
{
int j;
int kstep;
switch (kpvt[k - 1])
{
case >= 0:
{
//
// 1 by 1.
//
a[k - 1 + (k - 1) * lda] = 1.0 / a[k - 1 + (k - 1) * lda];
switch (k)
{
case >= 2:
{
BLAS1D.dcopy(k - 1, a, 1, ref work, 1, xIndex: +0 + (k - 1) * lda);
for (j = 1; j <= k - 1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1D.ddot(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1D.daxpy(j - 1, work[j - 1], a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda,
yIndex: +0 + (k - 1) * lda);
}
a[k - 1 + (k - 1) * lda] += BLAS1D.ddot(k - 1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda);
break;
}
}
kstep = 1;
break;
}
//
default:
{
t = Math.Abs(a[k - 1 + k * lda]);
double ak = a[k - 1 + (k - 1) * lda] / t;
double akp1 = a[k + k * lda] / t;
double akkp1 = a[k - 1 + k * lda] / t;
d = t * (ak * akp1 - 1.0);
a[k - 1 + (k - 1) * lda] = akp1 / d;
a[k + k * lda] = ak / d;
a[k - 1 + k * lda] = -akkp1 / d;
switch (k)
{
case >= 2:
{
BLAS1D.dcopy(k - 1, a, 1, ref work, 1, xIndex: +0 + k * lda);
for (j = 1; j <= k - 1; j++)
{
a[j - 1 + k * lda] = BLAS1D.ddot(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1D.daxpy(j - 1, work[j - 1], a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda,
yIndex: +0 + k * lda);
}
a[k + k * lda] += BLAS1D.ddot(k - 1, work, 1, a, 1, yIndex: +0 + k * lda);
a[k - 1 + k * lda] += BLAS1D.ddot(k - 1, a, 1, a, 1, xIndex: +0 + (k - 1) * lda,
yIndex: +0 + k * lda);
BLAS1D.dcopy(k - 1, a, 1, ref work, 1, xIndex: +0 + (k - 1) * lda);
for (j = 1; j <= k - 1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1D.ddot(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1D.daxpy(j - 1, work[j - 1], a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda,
yIndex: +0 + (k - 1) * lda);
}
a[k - 1 + (k - 1) * lda] += BLAS1D.ddot(k - 1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda);
break;
}
}
kstep = 2;
break;
}
}
//
// Swap.
//
int ks = Math.Abs(kpvt[k - 1]);
if (ks != k)
{
BLAS1D.dswap(ks, ref a, 1, ref a, 1, xIndex: +0 + (ks - 1) * lda, yIndex: +0 + (k - 1) * lda);
int jb;
double temp;
for (jb = ks; jb <= k; jb++)
{
j = k + ks - jb;
temp = a[j - 1 + (k - 1) * lda];
a[j - 1 + (k - 1) * lda] = a[ks - 1 + (j - 1) * lda];
a[ks - 1 + (j - 1) * lda] = temp;
}
if (kstep != 1)
{
temp = a[ks - 1 + k * lda];
a[ks - 1 + k * lda] = a[k - 1 + k * lda];
a[k - 1 + k * lda] = temp;
}
}
k += kstep;
}
break;
}
}
}
public static int dsifa(ref double[] a, int lda, int n, ref int[] kpvt)
//****************************************************************************80
//
// Purpose:
//
// DSIFA factors a real symmetric matrix.
//
// Discussion:
//
// To solve A*X = B, follow DSIFA by DSISL.
//
// To compute inverse(A)*C, follow DSIFA by DSISL.
//
// To compute determinant(A), follow DSIFA by DSIDI.
//
// To compute inertia(A), follow DSIFA by DSIDI.
//
// To compute inverse(A), follow DSIFA by DSIDI.
//
// 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, 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], the pivot indices.
//
// Output, integer DSIFA, error flag.
// 0, normal value.
// K, if the K-th pivot block is singular. This is not an error
// condition for this subroutine, but it does indicate that DSISL
// or DSIDI may divide by zero if called.
//
{
//
// ALPHA is used in choosing pivot block size.
//
double alpha = (1.0 + Math.Sqrt(17.0)) / 8.0;
int info = 0;
//
// Main loop on K, which goes from N to 1.
//
int k = n;
while (0 < k)
{
switch (k)
{
case 1:
{
kpvt[0] = 1;
info = a[0 + 0 * lda] switch
{
0.0 => 1,
_ => info
};
return(info);
}
}
//
// This section of code determines the kind of
// elimination to be performed. When it is completed,
// KSTEP will be set to the size of the pivot block, and
// SWAP will be set to .true. if an interchange is required.
//
double absakk = Math.Abs(a[k - 1 + (k - 1) * lda]);
//
// Determine the largest off-diagonal element in column K.
//
int imax = BLAS1D.idamax(k - 1, a, 1, index: +0 + (k - 1) * lda);
double colmax = Math.Abs(a[imax - 1 + (k - 1) * lda]);
int j;
int kstep;
bool swap;
if (alpha * colmax <= absakk)
{
kstep = 1;
swap = false;
}
//
// Determine the largest off-diagonal element in row IMAX.
//
else
{
double rowmax = 0.0;
int imaxp1 = imax + 1;
for (j = imaxp1; j <= k; j++)
{
rowmax = Math.Max(rowmax, Math.Abs(a[imax - 1 + (j - 1) * lda]));
}
if (imax != 1)
{
int jmax = BLAS1D.idamax(imax - 1, a, 1, index: +0 + (imax - 1) * lda);
rowmax = Math.Max(rowmax, Math.Abs(a[jmax - 1 + (imax - 1) * lda]));
}
if (alpha * rowmax <= Math.Abs(a[imax - 1 + (imax - 1) * lda]))
{
kstep = 1;
swap = true;
}
else if (alpha * colmax * (colmax / rowmax) <= absakk)
{
kstep = 1;
swap = false;
}
else
{
kstep = 2;
swap = imax != k - 1;
}
}
switch (Math.Max(absakk, colmax))
{
//
// Column K is zero.
// Set INFO and iterate the loop.
//
case 0.0:
kpvt[k - 1] = k;
info = k;
break;
//
default:
{
int jj;
double mulk;
double t;
if (kstep != 2)
{
switch (swap)
{
case true:
{
BLAS1D.dswap(imax, ref a, 1, ref a, 1, xIndex: +0 + (imax - 1) * lda,
yIndex: +0 + (k - 1) * lda);
for (jj = imax; jj <= k; jj++)
{
j = k + imax - jj;
t = a[j - 1 + (k - 1) * lda];
a[j - 1 + (k - 1) * lda] = a[imax - 1 + (j - 1) * lda];
a[imax - 1 + (j - 1) * lda] = t;
}
break;
}
}
//
// Perform the elimination.
//
for (jj = 1; jj <= k - 1; jj++)
{
j = k - jj;
mulk = -a[j - 1 + (k - 1) * lda] / a[k - 1 + (k - 1) * lda];
t = mulk;
BLAS1D.daxpy(j, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
a[j - 1 + (k - 1) * lda] = mulk;
}
kpvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => imax,
_ => k
};
}
//
// 2 x 2 pivot block.
//
// Perform an interchange.
//
else
{
switch (swap)
{
case true:
{
BLAS1D.dswap(imax, ref a, 1, ref a, 1, xIndex: +0 + (imax - 1) * lda,
yIndex: +0 + (k - 2) * lda);
for (jj = imax; jj <= k - 1; jj++)
{
j = k - 1 + imax - jj;
t = a[j - 1 + (k - 1) * lda];
a[j - 1 + (k - 1) * lda] = a[imax - 1 + (j - 1) * lda];
a[imax - 1 + (j - 1) * lda] = t;
}
t = a[k - 2 + (k - 1) * lda];
a[k - 2 + (k - 1) * lda] = a[imax - 1 + (k - 1) * lda];
a[imax - 1 + (k - 1) * lda] = t;
break;
}
}
//
// Perform the elimination.
//
if (k - 2 != 0)
{
double ak = a[k - 1 + (k - 1) * lda] / a[k - 2 + (k - 1) * lda];
double akm1 = a[k - 2 + (k - 2) * lda] / a[k - 2 + (k - 1) * lda];
double denom = 1.0 - ak * akm1;
for (jj = 1; jj <= k - 2; jj++)
{
j = k - 1 - jj;
double bk = a[j - 1 + (k - 1) * lda] / a[k - 2 + (k - 1) * lda];
double bkm1 = a[j - 1 + (k - 2) * lda] / a[k - 2 + (k - 1) * lda];
mulk = (akm1 * bk - bkm1) / denom;
double mulkm1 = (ak * bkm1 - bk) / denom;
t = mulk;
BLAS1D.daxpy(j, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
t = mulkm1;
BLAS1D.daxpy(j, t, a, 1, ref a, 1, xIndex: +0 + (k - 2) * lda, yIndex: +0 + (j - 1) * lda);
a[j - 1 + (k - 1) * lda] = mulk;
a[j - 1 + (k - 2) * lda] = mulkm1;
}
}
kpvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => - imax,
_ => 1 - k
};
kpvt[k - 2] = kpvt[k - 1];
}
break;
}
}
k -= kstep;
}
return(info);
}
}