public static int zpbfa(ref Complex[] abd, int lda, int n, int m)
//****************************************************************************80
//
// Purpose:
//
// ZPBFA factors a complex hermitian positive definite band matrix.
//
// Discussion:
//
// ZPBFA is usually called by ZPBCO, but it can be called
// directly with a saving in time if RCOND is not needed.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex 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 = hermitian(R)*R.
//
// Input, int LDA, the leading dimension of ABD.
// LDA must be at least M+1.
//
// Input, int N, the order of the matrix.
//
// Input, int M, the number of diagonals above the main diagonal.
// 0 <= M < N.
//
// Output, int ZSPFA.
// 0, for normal return.
// K, if the leading minor of order K is not positive definite.
//
{
int j;
int info = 0;
for (j = 1; j <= n; j++)
{
double s = 0.0;
int ik = m + 1;
int jk = Math.Max(j - m, 1);
int mu = Math.Max(m + 2 - j, 1);
int k;
for (k = mu; k <= m; k++)
{
Complex t = abd[k - 1 + (j - 1) * lda]
- BLAS1Z.zdotc(k - mu, abd, 1, abd, 1, xIndex: +ik - 1 + (jk - 1) * lda,
yIndex: +mu - 1 + (j - 1) * lda);
t /= abd[m + (jk - 1) * lda];
abd[k - 1 + (j - 1) * lda] = t;
s += (t * Complex.Conjugate(t)).Real;
ik -= 1;
jk += 1;
}
s = abd[m + (j - 1) * lda].Real - s;
if (s <= 0.0 || abd[m + (j - 1) * lda].Imaginary != 0.0)
{
info = j;
break;
}
abd[m + (j - 1) * lda] = new Complex(Math.Sqrt(s), 0.0);
}
return(info);
}
public static void zpodi(ref Complex[] a, int lda, int n, ref double[] det, int job)
//****************************************************************************80
//
// Purpose:
//
// ZPODI: determinant, inverse of a complex hermitian positive definite matrix.
//
// Discussion:
//
// The matrix is assumed to have been factored by ZPOCO, ZPOFA or ZQRDC.
//
// 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 ZPOCO or ZPOFA has set INFO == 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the output A from ZPOCO or
// ZPOFA, or the output X from ZQRDC. On output, if ZPOCO or ZPOFA was
// used to factor A, then ZPODI produces the upper half of inverse(A).
// If ZQRDC was used to decompose X, then ZPODI produces the upper half
// of inverse(hermitian(X)*X) where hermitian(X) is the conjugate transpose.
// Elements of A below the diagonal are unchanged.
// If the units digit of JOB is zero, A is unchanged.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Output, double DET[2], if requested, the determinant of A or of
// hermitian(X)*X. Determinant = DET(1) * 10.0**DET(2) with
// 1.0 <= abs ( DET(1) ) < 10.0 or DET(1) = 0.0.
//
// Input, int JOB.
// 11, both determinant and inverse.
// 01, inverse only.
// 10, determinant only.
//
{
//
// Compute determinant
//
if (job / 10 != 0)
{
det[0] = 1.0;
det[1] = 0.0;
int i;
for (i = 0; i < n; i++)
{
det[0] = det[0] * a[i + i * lda].Real * a[i + i * lda].Real;
if (det[0] == 0.0)
{
break;
}
while (det[0] < 1.0)
{
det[0] *= 10.0;
det[1] -= 1.0;
}
while (10.0 <= det[0])
{
det[0] /= 10.0;
det[1] += 1.0;
}
}
}
//
// Compute inverse(R).
//
if (job % 10 == 0)
{
return;
}
int j;
int k;
Complex t;
for (k = 1; k <= n; k++)
{
a[k - 1 + (k - 1) * lda] = new Complex(1.0, 0.0) / a[k - 1 + (k - 1) * lda];
t = -a[k - 1 + (k - 1) * lda];
BLAS1Z.zscal(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] = new Complex(0.0, 0.0);
BLAS1Z.zaxpy(k, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
}
}
//
// Form inverse(R) * hermitian(inverse(R)).
//
for (j = 1; j <= n; j++)
{
for (k = 1; k <= j - 1; k++)
{
t = Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
BLAS1Z.zaxpy(k, t, a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda, yIndex: +0 + (k - 1) * lda);
}
t = Complex.Conjugate(a[j - 1 + (j - 1) * lda]);
BLAS1Z.zscal(j, t, ref a, 1, index: +0 + (j - 1) * lda);
}
}
public static double zgeco(ref Complex[] a, int lda, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZGECO factors a complex matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, ZGEFA is slightly faster.
//
// To solve A*X = B, follow ZGECO by ZGESL.
//
// To compute inverse(A)*C, follow ZGECO by ZGESL.
//
// To compute determinant(A), follow ZGECO by ZGEDI.
//
// To compute inverse(A), follow ZGECO by ZGEDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N], on input, the matrix to be
// factored. On output, an upper triangular matrix and the multipliers
// 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 A.
//
// Input, int N, the order of the matrix.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, double SGECO, 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.0 + RCOND == 1.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate
// underflows.
//
// Local Parameters:
//
// Workspace, Complex 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 ).
//
{
int i;
int j;
int k;
int l;
double rcond;
double s;
Complex t;
Complex[] z = new Complex [n];
//
// Compute the 1-norm of A.
//
double anorm = 0.0;
for (j = 0; j < n; j++)
{
anorm = Math.Max(anorm, BLAS1Z.dzasum(n, a, 1, index: +0 + j * lda));
}
//
// Factor.
//
ZGEFA.zgefa(ref a, lda, n, ref ipvt);
//
// RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
//
// Estimate = norm(Z)/norm(Y) where A*Z = Y and hermitian(A)*Y = E.
//
// Hermitian(A) is the Complex.Conjugateugate transpose of A.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where hermitian(U)*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve hermitian(U)*W = E.
//
Complex ek = new(1.0, 0.0);
for (i = 0; i < n; i++)
{
z[i] = new Complex(0.0, 0.0);
}
for (k = 1; k <= n; k++)
{
if (typeMethods.zabs1(z[k - 1]) != 0.0)
{
ek = typeMethods.zsign1(ek, -z[k - 1]);
}
if (typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) < typeMethods.zabs1(ek - z[k - 1]))
{
s = typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) / typeMethods.zabs1(ek - z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ek = new Complex(s, 0.0) * ek;
}
Complex wk = ek - z[k - 1];
Complex wkm = -ek - z[k - 1];
s = typeMethods.zabs1(wk);
double sm = typeMethods.zabs1(wkm);
if (typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) != 0.0)
{
wk /= Complex.Conjugate(a[k - 1 + (k - 1) * lda]);
wkm /= Complex.Conjugate(a[k - 1 + (k - 1) * lda]);
}
else
{
wk = new Complex(1.0, 0.0);
wkm = new Complex(1.0, 0.0);
}
for (j = k + 1; j <= n; j++)
{
sm += typeMethods.zabs1(z[j - 1] + wkm * Complex.Conjugate(a[k - 1 + (j - 1) * lda]));
z[j - 1] += wk * Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
s += typeMethods.zabs1(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
for (j = k + 1; j <= n; j++)
{
z[j - 1] += t * Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
}
}
z[k - 1] = wk;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
//
// Solve hermitian(L) * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (k < n)
{
z[k - 1] += BLAS1Z.zdotc(n - k, a, 1, z, 1, xIndex: +k + (k - 1) * lda, yIndex: +k);
}
if (1.0 < typeMethods.zabs1(z[k - 1]))
{
s = 1.0 / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
}
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
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;
if (k < n)
{
BLAS1Z.zaxpy(n - k, t, a, 1, ref z, 1, xIndex: +k + (k - 1) * lda, yIndex: +k);
}
if (!(1.0 < typeMethods.zabs1(z[k - 1])))
{
continue;
}
s = 1.0 / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
//
// Solve U * Z = V.
//
for (k = n; 1 <= k; k--)
{
if (typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) < typeMethods.zabs1(z[k - 1]))
{
s = typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
if (typeMethods.zabs1(a[k - 1 + (k - 1) * lda]) != 0.0)
{
z[k - 1] /= a[k - 1 + (k - 1) * lda];
}
else
{
z[k - 1] = new Complex(1.0, 0.0);
}
t = -z[k - 1];
BLAS1Z.zaxpy(k - 1, t, a, 1, ref z, 1, xIndex: +0 + (k - 1) * lda);
}
//
// Make ZNORM = 1.
//
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static void zsisl(Complex[] a, int lda, int n, int[] ipvt,
ref Complex[] b)
//****************************************************************************80
//
// Purpose:
//
// ZSISL solves a complex symmetric system that was factored by ZSIFA.
//
// Discussion:
//
// A division by zero may occur if ZSICO has set RCOND == 0.0
// or ZSIFA has set INFO != 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex A[LDA*N], the output from ZSICO or ZSIFA.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Input, int IPVT[N], the pivot vector from ZSICO or ZSIFA.
//
// Input/output, Complex B[N]. On input, the right hand side.
// On output, the solution.
//
{
int kp;
Complex t;
//
// Loop backward applying the transformations and D inverse to B.
//
int k = n;
while (0 < k)
{
switch (ipvt[k - 1])
{
//
// 1 x 1 pivot block.
//
case >= 0:
{
if (k != 1)
{
kp = ipvt[k - 1];
if (kp != k)
{
t = b[k - 1];
b[k - 1] = b[kp - 1];
b[kp - 1] = t;
}
BLAS1Z.zaxpy(k - 1, b[k - 1], a, 1, ref b, 1, xIndex: +0 + (k - 1) * lda);
}
b[k - 1] /= a[k - 1 + (k - 1) * lda];
k -= 1;
break;
}
//
default:
{
if (k != 2)
{
kp = Math.Abs(ipvt[k - 1]);
if (kp != k - 1)
{
t = b[k - 2];
b[k - 2] = b[kp - 1];
b[kp - 1] = t;
}
BLAS1Z.zaxpy(k - 2, b[k - 1], a, 1, ref b, 1, xIndex: +0 + (k - 1) * lda);
BLAS1Z.zaxpy(k - 2, b[k - 2], a, 1, ref b, 1, xIndex: +0 + (k - 2) * lda);
}
Complex ak = a[k - 1 + (k - 1) * lda] / a[k - 2 + (k - 1) * lda];
Complex akm1 = a[k - 2 + (k - 2) * lda] / a[k - 2 + (k - 1) * lda];
Complex bk = b[k - 1] / a[k - 2 + (k - 1) * lda];
Complex bkm1 = b[k - 2] / a[k - 2 + (k - 1) * lda];
Complex denom = ak * akm1 - new Complex(1.0, 0.0);
b[k - 1] = (akm1 * bk - bkm1) / denom;
b[k - 2] = (ak * bkm1 - bk) / denom;
k -= 2;
break;
}
}
}
//
// Loop forward applying the transformations.
//
k = 1;
while (k <= n)
{
switch (ipvt[k - 1])
{
case >= 0:
{
//
// 1 x 1 pivot block.
//
if (k != 1)
{
b[k - 1] += BLAS1Z.zdotu(k - 1, a, 1, b, 1, xIndex: +0 + (k - 1) * lda);
kp = ipvt[k - 1];
if (kp != k)
{
t = b[k - 1];
b[k - 1] = b[kp - 1];
b[kp - 1] = t;
}
}
k += 1;
break;
}
//
default:
{
if (k != 1)
{
b[k - 1] += BLAS1Z.zdotu(k - 1, a, 1, b, 1, xIndex: +0 + (k - 1) * lda);
b[k] += BLAS1Z.zdotu(k - 1, a, 1, b, 1, xIndex: +0 + k * lda);
kp = Math.Abs(ipvt[k - 1]);
if (kp != k)
{
t = b[k - 1];
b[k - 1] = b[kp - 1];
b[kp - 1] = t;
}
}
k += 2;
break;
}
}
}
}
public static void zppdi(ref Complex[] ap, int n, ref double[] det, int job)
//****************************************************************************80
//
// Purpose:
//
// ZPPDI: determinant, inverse of a complex hermitian positive definite matrix.
//
// Discussion:
//
// The matrix is assumed to have been factored by ZPPCO or ZPPFA.
//
// 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 ZPOCO or ZPOFA has set INFO == 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, complex <double> A[(N*(N+1))/2]; on input, the output from ZPPCO
// or ZPPFA. On output, the upper triangular half of the inverse.
// The strict lower triangle is unaltered.
//
// Input, int N, the order of the matrix.
//
// Output, double DET[2], the determinant of original matrix if requested.
// Otherwise not referenced. Determinant = DET(1) * 10.0**DET(2)
// with 1.0 <= DET(1) < 10.0 or DET(1) == 0.0.
//
// Input, int JOB.
// 11, both determinant and inverse.
// 01, inverse only.
// 10, determinant only.
//
{
//
// Compute determinant.
//
if (job / 10 != 0)
{
det[0] = 1.0;
det[1] = 0.0;
int ii = 0;
int i;
for (i = 1; i <= n; i++)
{
ii += i;
det[0] = det[0] * ap[ii - 1].Real * ap[ii - 1].Real;
if (det[0] == 0.0)
{
break;
}
while (det[0] < 1.0)
{
det[0] *= 10.0;
det[1] -= 1.0;
}
while (10.0 <= det[0])
{
det[0] /= 10.0;
det[1] += 1.0;
}
}
}
//
// Compute inverse ( R ).
//
if (job % 10 == 0)
{
return;
}
int kk = 0;
int k1;
int kj;
int k;
Complex t;
int j;
int j1;
for (k = 1; k <= n; k++)
{
k1 = kk + 1;
kk += k;
ap[kk - 1] = new Complex(1.0, 0.0) / ap[kk - 1];
t = -ap[kk - 1];
BLAS1Z.zscal(k - 1, t, ref ap, 1, index: +k1 - 1);
int kp1 = k + 1;
j1 = kk + 1;
kj = kk + k;
for (j = kp1; j <= n; j++)
{
t = ap[kj - 1];
ap[kj - 1] = new Complex(0.0, 0.0);
BLAS1Z.zaxpy(k, t, ap, 1, ref ap, 1, xIndex: +k1 - 1, yIndex: +j1 - 1);
j1 += j;
kj += j;
}
}
//
// Form inverse ( R ) * hermitian ( inverse ( R ) ).
//
int jj = 0;
for (j = 1; j <= n; j++)
{
j1 = jj + 1;
jj += j;
k1 = 1;
kj = j1;
for (k = 1; k <= j - 1; k++)
{
t = Complex.Conjugate(ap[kj - 1]);
BLAS1Z.zaxpy(k, t, ap, 1, ref ap, 1, xIndex: +j1 - 1, yIndex: k1 - 1);
k1 += k;
kj += 1;
}
t = Complex.Conjugate(ap[jj - 1]);
BLAS1Z.zscal(j, t, ref ap, 1, index: +j1 - 1);
}
}
public static double zpbco(ref Complex[] abd, int lda, int n, int m, ref int info)
//****************************************************************************80
//
// Purpose:
//
// ZPBCO factors a Complex hermitian positive definite band matrix.
//
// Discussion:
//
// The routine also estimates the condition number of the matrix.
//
// If RCOND is not needed, ZPBFA is slightly faster.
//
// To solve A*X = B, follow ZPBCO by ZPBSL.
//
// To compute inverse(A)*C, follow ZPBCO by ZPBSL.
//
// To compute determinant(A), follow ZPBCO by ZPBDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex 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 = hermitian(R) * R. If INFO != 0, the factorization is not complete.
//
// Input, int LDA, the leading dimension of ABD.
// LDA must be at least M+1.
//
// Input, int N, the order of the matrix.
//
// Input, int M, the number of diagonals above the main diagonal.
// 0 <= M < N.
//
// Output, double ZPBCO, an estimate of RCOND, the reciprocal condition of
// the matrix. 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.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
// Output, int *INFO.
// 0, for normal return.
// K, signals an error condition. The leading minor of order K is not
// positive definite.
//
// Local Parameter:
//
// Workspace, Complex 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.
//
{
int i;
int j;
int k;
int la;
int lb;
int lm;
double rcond;
double s;
Complex t;
//
// Find the norm of A.
//
Complex[] z = new Complex [n];
for (j = 1; j <= n; j++)
{
int l = Math.Min(j, m + 1);
int mu = Math.Max(m + 2 - j, 1);
z[j - 1] = new Complex(BLAS1Z.dzasum(l, abd, 1, index: +mu - 1 + (j - 1) * lda), 0.0);
k = j - l;
for (i = mu; i <= m; i++)
{
k += 1;
z[k - 1] = new Complex(z[k - 1].Real
+ typeMethods.zabs1(abd[i - 1 + (j - 1) * lda]), 0.0);
}
}
double anorm = 0.0;
for (j = 0; j < n; j++)
{
anorm = Math.Max(anorm, z[j].Real);
}
//
// Factor.
//
info = ZPBFA.zpbfa(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 hermitian(R)*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve hermitian(R)*W = E.
//
Complex ek = new(1.0, 0.0);
for (i = 0; i < n; i++)
{
z[i] = new Complex(0.0, 0.0);
}
for (k = 1; k <= n; k++)
{
if (typeMethods.zabs1(z[k - 1]) != 0.0)
{
ek = typeMethods.zsign1(ek, -z[k - 1]);
}
if (abd[m + (k - 1) * lda].Real < typeMethods.zabs1(ek - z[k - 1]))
{
s = abd[m + (k - 1) * lda].Real / typeMethods.zabs1(ek - z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ek = new Complex(s, 0.0) * ek;
}
Complex wk = ek - z[k - 1];
Complex wkm = -ek - z[k - 1];
s = typeMethods.zabs1(wk);
double sm = typeMethods.zabs1(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 += typeMethods.zabs1(z[j - 1] + wkm * Complex.Conjugate(abd[i - 1 + (j - 1) * lda]));
z[j - 1] += wk * Complex.Conjugate(abd[i - 1 + (j - 1) * lda]);
s += typeMethods.zabs1(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 * Complex.Conjugate(abd[i - 1 + (j - 1) * lda]);
}
}
}
z[k - 1] = wk;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
//
// Solve R * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (abd[m + (k - 1) * lda].Real < typeMethods.zabs1(z[k - 1]))
{
s = abd[m + (k - 1) * lda].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 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];
BLAS1Z.zaxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
double ynorm = 1.0;
//
// Solve hermitian(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] -= BLAS1Z.zdotc(lm, abd, 1, z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
if (abd[m + (k - 1) * lda].Real < typeMethods.zabs1(z[k - 1]))
{
s = abd[m + (k - 1) * lda].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
z[k - 1] /= abd[m + (k - 1) * lda];
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
//
// Solve R * Z = W.
//
for (k = n; 1 <= k; k--)
{
if (abd[m + (k - 1) * lda].Real < typeMethods.zabs1(z[k - 1]))
{
s = abd[m + (k - 1) * lda].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 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];
BLAS1Z.zaxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
//
// Make ZNORM = 1.
//
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static void zchud(ref Complex[] r, int ldr, int p, Complex[] x,
ref Complex[] z, int ldz, int nz, ref Complex[] y, ref double[] rho,
ref double[] c, ref Complex[] s)
//****************************************************************************80
//
// Purpose:
//
// ZCHUD updates an augmented Cholesky decomposition.
//
// Discussion:
//
// ZCHUD updates an augmented Cholesky decomposition of the
// triangular part of an augmented QR decomposition. Specifically,
// given an upper triangular matrix R of order P, a row vector
// X, a column vector Z, and a scalar Y, ZCHUD determines a
// unitary matrix U and a scalar ZETA such that
//
// ( R Z ) ( RR ZZ )
// U * ( ) = ( ),
// ( X Y ) ( 0 ZETA )
//
// where RR is upper triangular. If R and Z have been
// obtained from the factorization of a least squares
// problem, then RR and ZZ are the factors corresponding to
// the problem with the observation (X,Y) appended. In this
// case, if RHO is the norm of the residual vector, then the
// norm of the residual vector of the updated problem is
// sqrt ( RHO**2 + ZETA**2 ). ZCHUD will simultaneously update
// several triplets (Z,Y,RHO).
//
// For a less terse description of what ZCHUD does and how
// it may be applied see the LINPACK guide.
//
// The matrix U is determined as the product U(P)*...*U(1),
// where U(I) is a rotation in the (I,P+1) plane of the
// form
//
// ( C(I) S(I) )
// ( ).
// ( -Complex.Conjugateg ( S(I) ) C(I) )
//
// The rotations are chosen so that C(I) is real.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex R[LDR*P], the upper triangular matrix
// that is to be updated. The part of R below the diagonal is
// not referenced.
//
// Input, int LDR, the leading dimension of R.
// P <= LDR.
//
// Input, int P, the order of the matrix.
//
// Input, Complex X[P], the row to be added to R.
//
// Input/output, Complex Z[LDZ*NZ], NZ P-vectors to
// be updated with R.
//
// Input, int LDZ, the leading dimension of Z.
// P <= LDZ.
//
// Input, int NZ, the number of vectors to be updated.
// NZ may be zero, in which case Z, Y, and RHO are not referenced.
//
// Input, Complex Y[NZ], the scalars for updating the vectors Z.
//
// Input/output, double RHO[NZ]; on input, the norms of the residual
// vectors that are to be updated. If RHO(J) is negative, it is
// left unaltered. On output, the updated values.
//
// Output, double C[P]. the cosines of the transforming rotations.
//
// Output, Complex S[P], the sines of the transforming rotations.
//
{
int i;
int j;
Complex t;
//
// Update R.
//
for (j = 1; j <= p; j++)
{
Complex xj = x[j - 1];
//
// Apply the previous rotations.
//
for (i = 1; i <= j - 1; i++)
{
t = c[i - 1] * r[i - 1 + (j - 1) * ldr] + s[i - 1] * xj;
xj = c[i - 1] * xj - Complex.Conjugate(s[i - 1]) * r[i - 1 + (j - 1) * ldr];
r[i - 1 + (j - 1) * ldr] = t;
}
//
// Compute the next rotation.
//
BLAS1Z.zrotg(ref r[+j - 1 + (j - 1) * ldr], xj, ref c[+j - 1], ref s[+j - 1]);
}
//
// If required, update Z and RHO.
//
for (j = 1; j <= nz; j++)
{
Complex zeta = y[j - 1];
for (i = 1; i <= p; i++)
{
t = c[i - 1] * z[i - 1 + (j - 1) * ldz] + s[i - 1] * zeta;
zeta = c[i - 1] * zeta - Complex.Conjugate(s[i - 1]) * z[i - 1 + (j - 1) * ldz];
z[i - 1 + (j - 1) * ldz] = t;
}
double azeta = Complex.Abs(zeta);
if (azeta == 0.0 || !(0.0 <= rho[j - 1]))
{
continue;
}
double scale = azeta + rho[j - 1];
rho[j - 1] = scale * Math.Sqrt(Math.Pow(azeta / scale, 2)
+ Math.Pow(rho[j - 1] / scale, 2));
}
}
public static int zhifa(ref Complex[] a, int lda, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZHIFA factors a complex hermitian matrix.
//
// Discussion:
//
// ZHIFA performs the factoring by elimination with symmetric pivoting.
//
// To solve A*X = B, follow ZHIFA by ZHISL.
//
// To compute inverse(A)*C, follow ZHIFA by ZHISL.
//
// To compute determinant(A), follow ZHIFA by ZHIDI.
//
// To compute inertia(A), follow ZHIFA by ZHIDI.
//
// To compute inverse(A), follow ZHIFA by ZHIDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, complex <double> A[LDA*N]; on input, the hermitian matrix to be
// factored. On output, a block diagonal matrix and the multipliers which
// were used to obtain it. The factorization can be written
// A = U*D*hermitian(U) where U is a product of permutation and unit upper
// triangular matrices, hermitian(U) is the Complex.Conjugateugate transpose of U, and
// D is block diagonal with 1 by 1 and 2 by 2 blocks. Only the diagonal
// and upper triangle are used.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, int ZHIFA.
// 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 ZHISL or ZHIDI may
// divide by zero if called.
//
{
//
// Initialize.
//
// 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;
for (;;)
{
//
// Leave the loop if K = 0 or K = 1.
//
if (k == 0)
{
break;
}
if (k == 1)
{
ipvt[0] = 1;
if (typeMethods.zabs1(a[0 + 0 * lda]) == 0.0)
{
info = 1;
}
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;
double absakk = typeMethods.zabs1(a[k - 1 + (k - 1) * lda]);
//
// Determine the largest off-diagonal element in column K.
//
int imax = BLAS1Z.izamax(k - 1, a, 1, index: +0 + (k - 1) * lda);
double colmax = typeMethods.zabs1(a[imax - 1 + (k - 1) * lda]);
int j;
int kstep;
bool swap;
if (alpha * colmax <= absakk)
{
kstep = 1;
swap = false;
}
else
{
//
// Determine the largest off-diagonal element in row IMAX.
//
double rowmax = 0.0;
for (j = imax + 1; j <= k; j++)
{
rowmax = Math.Max(rowmax, typeMethods.zabs1(a[imax - 1 + (j - 1) * lda]));
}
if (imax != 1)
{
int jmax = BLAS1Z.izamax(imax - 1, a, 1, index: +0 + (imax - 1) * lda);
rowmax = Math.Max(rowmax, typeMethods.zabs1(a[jmax - 1 + (imax - 1) * lda]));
}
if (alpha * rowmax <= typeMethods.zabs1(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 != km1;
}
}
switch (Math.Max(absakk, colmax))
{
//
// Column K is zero. Set INFO and iterate the loop.
//
case 0.0:
ipvt[k - 1] = k;
info = k;
k -= kstep;
continue;
}
int jj;
Complex mulk;
Complex t;
if (kstep != 2)
{
switch (swap)
{
//
// 1 x 1 pivot block.
//
case true:
{
BLAS1Z.zswap(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 = Complex.Conjugate(a[j - 1 + (k - 1) * lda]);
a[j - 1 + (k - 1) * lda] = Complex.Conjugate(a[imax - 1 + (j - 1) * lda]);
a[imax - 1 + (j - 1) * lda] = t;
}
break;
}
}
//
// Perform the elimination.
//
for (jj = 1; jj <= km1; jj++)
{
j = k - jj;
mulk = -a[j - 1 + (k - 1) * lda] / a[k - 1 + (k - 1) * lda];
t = Complex.Conjugate(mulk);
BLAS1Z.zaxpy(j, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
a[j - 1 + (j - 1) * lda] = new Complex(a[j - 1 + (j - 1) * lda].Real, 0.0);
a[j - 1 + (k - 1) * lda] = mulk;
}
ipvt[k - 1] = swap switch
{
true => imax,
//
// Set the pivot array.
//
_ => k
};
}
else
{
switch (swap)
{
//
// 2 x 2 pivot block.
//
case true:
{
BLAS1Z.zswap(imax, ref a, 1, ref a, 1, xIndex: +0 + (imax - 1) * lda, yIndex: +0 + (k - 2) * lda);
for (jj = imax; jj <= km1; jj++)
{
j = km1 + imax - jj;
t = Complex.Conjugate(a[j - 1 + (k - 2) * lda]);
a[j - 1 + (k - 2) * lda] = Complex.Conjugate(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;
}
}
switch (k - 2)
{
//
// Perform the elimination.
//
case > 0:
{
Complex ak = a[k - 1 + (k - 1) * lda] / a[k - 2 + (k - 1) * lda];
Complex akm1 = a[k - 2 + (k - 2) * lda] / Complex.Conjugate(a[k - 2 + (k - 1) * lda]);
Complex denom = new Complex(1.0, 0.0) - ak * akm1;
for (jj = 1; jj <= k - 2; jj++)
{
j = km1 - jj;
Complex bk = a[j - 1 + (k - 1) * lda] / a[k - 2 + (k - 1) * lda];
Complex bkm1 = a[j - 1 + (k - 2) * lda] / Complex.Conjugate(a[k - 2 + (k - 1) * lda]);
mulk = (akm1 * bk - bkm1) / denom;
Complex mulkm1 = (ak * bkm1 - bk) / denom;
t = Complex.Conjugate(mulk);
BLAS1Z.zaxpy(j, t, a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (j - 1) * lda);
t = Complex.Conjugate(mulkm1);
BLAS1Z.zaxpy(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;
a[j - 1 + (j - 1) * lda] = new Complex(a[j - 1 + (j - 1) * lda].Real, 0.0);
}
break;
}
}
ipvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => - imax,
_ => 1 - k
};
ipvt[k - 2] = ipvt[k - 1];
}
k -= kstep;
}
return(info);
}
}
public static int zppfa(ref Complex[] ap, int n)
//****************************************************************************80
//
// Purpose:
//
// ZPPFA factors a complex hermitian positive definite packed matrix.
//
// Discussion:
//
// The following program segment will pack the upper triangle of a
// hermitian 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:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex AP[N*(N+1)/2]; on input, the packed form
// of a hermitian 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 = hermitian(R) * R.
//
// Input, int N, the order of the matrix.
//
// Output, int ZPPFA.
// 0, for normal return.
// K, if the leading minor of order K is not positive definite.
//
{
int j;
int info = 0;
int jj = 0;
for (j = 1; j <= n; j++)
{
double s = 0.0;
int kj = jj;
int kk = 0;
int k;
for (k = 1; k <= j - 1; k++)
{
kj += 1;
Complex t = ap[kj - 1] - BLAS1Z.zdotc(k - 1, ap, 1, ap, 1, xIndex: +kk, yIndex: +jj);
kk += k;
t /= ap[kk - 1];
ap[kj - 1] = t;
s += (t * Complex.Conjugate(t)).Real;
}
jj += j;
s = ap[jj - 1].Real - s;
if (s <= 0.0 || ap[jj - 1].Imaginary != 0.0)
{
info = j;
break;
}
ap[jj - 1] = new Complex(Math.Sqrt(s), 0.0);
}
return(info);
}
public static double ztrco(Complex[] t, int ldt, int n, int job)
//****************************************************************************80
//
// Purpose:
//
// ZTRCO estimates the condition of a complex triangular matrix.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex 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 T.
//
// Input, int N, the order of the matrix.
//
// Input, int JOB, indicates if matrix is upper or lower triangular.
// 0, lower triangular.
// nonzero, upper triangular.
//
// Output, double ZTRCO, an estimate of RCOND, the reciprocal condition 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.0 + RCOND == 1.0
// is true, then T may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate
// underflows.
//
// Local Parameters:
//
// Workspace, Complex 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).
//
{
int i;
int i1;
int j;
int k;
int kk;
double rcond;
double s;
Complex w;
bool lower = job == 0;
//
// Compute 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,
BLAS1Z.dzasum(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 hermitian(T)*Y = E.
//
// Hermitian(T) is the Complex.Conjugateugate 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 hermitian(T)*Y = E.
//
Complex ek = new(1.0, 0.0);
Complex[] z = new Complex[n];
for (i = 0; i < n; i++)
{
z[i] = new Complex(0.0, 0.0);
}
for (kk = 1; kk <= n; kk++)
{
k = lower switch
{
true => n + 1 - kk,
_ => kk
};
if (typeMethods.zabs1(z[k - 1]) != 0.0)
{
ek = typeMethods.zsign1(ek, -z[k - 1]);
}
if (typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) < typeMethods.zabs1(ek - z[k - 1]))
{
s = typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) / typeMethods.zabs1(ek - z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ek = new Complex(s, 0.0) * ek;
}
Complex wk = ek - z[k - 1];
Complex wkm = -ek - z[k - 1];
s = typeMethods.zabs1(wk);
double sm = typeMethods.zabs1(wkm);
if (typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) != 0.0)
{
wk /= Complex.Conjugate(t[k - 1 + (k - 1) * ldt]);
wkm /= Complex.Conjugate(t[k - 1 + (k - 1) * ldt]);
}
else
{
wk = new Complex(1.0, 0.0);
wkm = new Complex(1.0, 0.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 += typeMethods.zabs1(z[j - 1] + wkm * Complex.Conjugate(t[k - 1 + (j - 1) * ldt]));
z[j - 1] += wk * Complex.Conjugate(t[k - 1 + (j - 1) * ldt]);
s += typeMethods.zabs1(z[j - 1]);
}
if (s < sm)
{
w = wkm - wk;
wk = wkm;
for (j = j1; j <= j2; j++)
{
z[j - 1] += w * Complex.Conjugate(t[k - 1 + (j - 1) * ldt]);
}
}
}
z[k - 1] = wk;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
double ynorm = 1.0;
//
// Solve T*Z = Y.
//
for (kk = 1; kk <= n; kk++)
{
k = lower switch
{
true => kk,
_ => n + 1 - kk
};
if (typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) < typeMethods.zabs1(z[k - 1]))
{
s = typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
if (typeMethods.zabs1(t[k - 1 + (k - 1) * ldt]) != 0.0)
{
z[k - 1] /= t[k - 1 + (k - 1) * ldt];
}
else
{
z[k - 1] = new Complex(1.0, 0.0);
}
i1 = lower switch
{
true => k + 1,
_ => 1
};
if (kk >= n)
{
continue;
}
w = -z[k - 1];
BLAS1Z.zaxpy(n - kk, w, t, 1, ref z, 1, xIndex: +i1 - 1 + (k - 1) * ldt, yIndex: +i1 - 1);
}
//
// Make ZNORM = 1.
//
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
if (tnorm != 0.0)
{
rcond = ynorm / tnorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
}
public static double zgbco(ref Complex[] abd, int lda, int n, int ml, int mu,
ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZGBCO factors a complex band matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, ZGBFA is slightly faster.
//
// To solve A*X = B, follow ZGBCO by ZGBSL.
//
// To compute inverse(A)*C, follow ZGBCO by ZGBSL.
//
// To compute determinant(A), follow ZGBCO by ZGBDI.
//
// 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.
//
// Example:
//
// If the original matrix A 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 N = 6, ML = 1, MU = 2, 5 <= LDA and ABD should contain
//
// * * * + + +
// * * 13 24 35 46
// * 12 23 34 45 56
// 11 22 33 44 55 66
// 21 32 43 54 65 *
//
// * = not used,
// + = used for pivoting.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex ABD[LDA*N], on input, contains 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 ABD.
// LDA must be at least 2*ML+MU+1.
//
// Input, int N, the order of the matrix.
//
// Input, int ML, the number of diagonals below the main diagonal.
// 0 <= ML < N.
//
// Input, int MU, the number of diagonals above the main diagonal.
// 0 <= MU < N.
// More efficient if ML <= MU.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, double ZGBCO, an estimate of the reciprocal condition 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.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate
// underflows.
//
// Local Parameters:
//
// Workspace, Complex 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 ).
//
{
int j;
int k;
int lm;
double rcond;
double s;
Complex t;
Complex[] z = new Complex [n];
//
// Compute 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, BLAS1Z.dzasum(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
//
ZGBFA.zgbfa(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 hermitian(A)*Y = E.
//
// Hermitian(A) is the Complex.Conjugateugate transpose of A.
//
// The components of E are chosen to cause maximum local
// growth in the elements of W where hermitian(U)*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve hermitian(U) * W = E.
//
Complex ek = new(1.0, 0.0);
for (j = 1; j <= n; j++)
{
z[j - 1] = new Complex(0.0, 0.0);
}
int m = ml + mu + 1;
int ju = 0;
for (k = 1; k <= n; k++)
{
if (typeMethods.zabs1(z[k - 1]) != 0.0)
{
ek = typeMethods.zsign1(ek, -z[k - 1]);
}
if (typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) < typeMethods.zabs1(ek - z[k - 1]))
{
s = typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) / typeMethods.zabs1(ek - z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ek = new Complex(s, 0.0) * ek;
}
Complex wk = ek - z[k - 1];
Complex wkm = -ek - z[k - 1];
s = typeMethods.zabs1(wk);
double sm = typeMethods.zabs1(wkm);
if (typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) != 0.0)
{
wk /= Complex.Conjugate(abd[m - 1 + (k - 1) * lda]);
wkm /= Complex.Conjugate(abd[m - 1 + (k - 1) * lda]);
}
else
{
wk = new Complex(1.0, 0.0);
wkm = new Complex(1.0, 0.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 += typeMethods.zabs1(z[j - 1] + wkm * Complex.Conjugate(abd[mm - 1 + (j - 1) * lda]));
z[j - 1] += wk * Complex.Conjugate(abd[mm - 1 + (j - 1) * lda]);
s += typeMethods.zabs1(z[j - 1]);
}
if (s < sm)
{
t = wkm - wk;
wk = wkm;
mm = m;
for (j = k + 1; j <= ju; j++)
{
mm -= 1;
z[j - 1] += t * Complex.Conjugate(abd[mm - 1 + (j - 1) * lda]);
}
}
}
z[k - 1] = wk;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
//
// Solve hermitian(L) * Y = W.
//
for (k = n; 1 <= k; k--)
{
lm = Math.Min(ml, n - k);
if (k < n)
{
z[k - 1] += BLAS1Z.zdotc(lm, abd, 1, z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
}
if (1.0 < typeMethods.zabs1(z[k - 1]))
{
s = 1.0 / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
}
l = ipvt[k - 1];
t = z[l - 1];
z[l - 1] = z[k - 1];
z[k - 1] = t;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
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)
{
BLAS1Z.zaxpy(lm, t, abd, 1, ref z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
}
if (!(1.0 < typeMethods.zabs1(z[k - 1])))
{
continue;
}
s = 1.0 / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
//
// Solve U * Z = W.
//
for (k = n; 1 <= k; k--)
{
if (typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) < typeMethods.zabs1(z[k - 1]))
{
s = typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
if (typeMethods.zabs1(abd[m - 1 + (k - 1) * lda]) != 0.0)
{
z[k - 1] /= abd[m - 1 + (k - 1) * lda];
}
else
{
z[k - 1] = new Complex(1.0, 0.0);
}
lm = Math.Min(k, m) - 1;
int la = m - lm;
int lz = k - lm;
t = -z[k - 1];
BLAS1Z.zaxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lz - 1);
}
//
// Make ZNORM = 1.
//
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static void zgedi(ref Complex[] a, int lda, int n, int[] ipvt,
ref Complex[] det, int job)
//****************************************************************************80
//
// Purpose:
//
// ZGEDI computes the determinant and inverse of a matrix.
//
// Discussion:
//
// The matrix must have been factored by ZGECO or ZGEFA.
//
// 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 ZGECO has set 0.0 < RCOND or ZGEFA has set
// INFO == 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the factor information
// from ZGECO or ZGEFA. On output, the inverse matrix, if it
// was requested,
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Input, int IPVT[N], the pivot vector from ZGECO or ZGEFA.
//
// Output, Complex DET[2], the determinant of the original matrix,
// if requested. Otherwise not referenced.
// Determinant = DET(1) * 10.0**DET(2) with
// 1.0 <= typeMethods.zabs1 ( DET(1) ) < 10.0 or DET(1) == 0.0.
// Also, DET(2) is strictly real.
//
// Input, int JOB.
// 11, both determinant and inverse.
// 01, inverse only.
// 10, determinant only.
//
{
int i;
//
// Compute the determinant.
//
if (job / 10 != 0)
{
det[0] = new Complex(1.0, 0.0);
det[1] = new Complex(0.0, 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] * det[0];
if (typeMethods.zabs1(det[0]) == 0.0)
{
break;
}
while (typeMethods.zabs1(det[0]) < 1.0)
{
det[0] *= new Complex(10.0, 0.0);
det[1] -= new Complex(1.0, 0.0);
}
while (10.0 <= typeMethods.zabs1(det[0]))
{
det[0] /= new Complex(10.0, 0.0);
det[1] += new Complex(1.0, 0.0);
}
}
}
//
// Compute inverse(U).
//
if (job % 10 == 0)
{
return;
}
Complex[] work = new Complex[n];
int j;
Complex t;
int k;
for (k = 1; k <= n; k++)
{
a[k - 1 + (k - 1) * lda] = new Complex(1.0, 0.0) / a[k - 1 + (k - 1) * lda];
t = -a[k - 1 + (k - 1) * lda];
BLAS1Z.zscal(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] = new Complex(0.0, 0.0);
BLAS1Z.zaxpy(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] = new Complex(0.0, 0.0);
}
for (j = k + 1; j <= n; j++)
{
t = work[j - 1];
BLAS1Z.zaxpy(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)
{
BLAS1Z.zswap(n, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (l - 1) * lda);
}
}
}
public static int ztrdi(ref Complex[] t, int ldt, int n, ref Complex[] det,
int job)
//****************************************************************************80
//
// Purpose:
//
// ZTRDI computes the determinant and inverse of a complex triangular matrix.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex 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.
// On output, if an inverse was requested, then T has been overwritten
// by its inverse.
//
// Input, int LDT, the leading dimension of T.
//
// Input, int N, the order of the matrix.
//
// Input, int JOB.
// 010, no determinant, inverse, matrix is lower triangular.
// 011, no determinant, inverse, matrix is upper triangular.
// 100, determinant, no inverse.
// 110, determinant, inverse, matrix is lower triangular.
// 111, determinant, inverse, matrix is upper triangular.
//
// Output, Complex DET[2], the determinant of the original matrix,
// if requested. Otherwise not referenced.
// Determinant = DET(1) * 10.0**DET(2) with 1.0 <= typeMethods.zabs1 ( DET(1) ) < 10.0
// or DET(1) == 0.0. Also, DET(2) is strictly real.
//
// Output, int ZTRDI.
// 0, an inverse was requested and the matrix is nonsingular.
// K, an inverse was requested, but the K-th diagonal element
// of T is zero.
//
{
int info = 0;
if (job / 100 != 0)
{
det[0] = new Complex(1.0, 0.0);
det[1] = new Complex(0.0, 0.0);
int i;
for (i = 0; i < n; i++)
{
det[0] *= t[i + i * ldt];
if (typeMethods.zabs1(det[0]) == 0.0)
{
break;
}
while (typeMethods.zabs1(det[0]) < 1.0)
{
det[0] *= new Complex(10.0, 0.0);
det[1] -= new Complex(1.0, 0.0);
}
while (10.0 <= typeMethods.zabs1(det[0]))
{
det[0] /= new Complex(10.0, 0.0);
det[1] += new Complex(1.0, 0.0);
}
}
}
//
// Compute inverse of upper triangular matrix.
//
if (job / 10 % 10 == 0)
{
return(info);
}
Complex temp;
int j;
int k;
if (job % 10 != 0)
{
info = 0;
for (k = 0; k < n; k++)
{
if (typeMethods.zabs1(t[k + k * ldt]) == 0.0)
{
info = k + 1;
break;
}
t[k + k * ldt] = new Complex(1.0, 0.0) / t[k + k * ldt];
temp = -t[k + k * ldt];
BLAS1Z.zscal(k, temp, ref t, 1, index: +0 + k * ldt);
for (j = k + 1; j < n; j++)
{
temp = t[k + j * ldt];
t[k + j * ldt] = new Complex(0.0, 0.0);
BLAS1Z.zaxpy(k + 1, temp, t, 1, ref t, 1, xIndex: +0 + k * ldt, yIndex: +0 + j * ldt);
}
}
}
//
// Compute inverse of lower triangular matrix.
//
else
{
info = 0;
for (k = n - 1; 0 <= k; k--)
{
if (typeMethods.zabs1(t[k + k * ldt]) == 0.0)
{
info = k + 1;
break;
}
t[k + k * ldt] = new Complex(1.0, 0.0) / t[k + k * ldt];
if (k != n - 1)
{
temp = -t[k + k * ldt];
BLAS1Z.zscal(n - k - 1, temp, ref t, 1, index: +k + 1 + k * ldt);
}
for (j = 0; j < k; j++)
{
temp = t[k + j * ldt];
t[k + j * ldt] = new Complex(0.0, 0.0);
BLAS1Z.zaxpy(n - k, temp, t, 1, ref t, 1, xIndex: +k + k * ldt, yIndex: +k + j * ldt);
}
}
}
return(info);
}
public static int zpofa(ref Complex[] a, int lda, int n)
//****************************************************************************80
//
// Purpose:
//
// ZPOFA factors a complex hermitian positive definite matrix.
//
// Discussion:
//
// ZPOFA is usually called by ZPOCO, but it can be called
// directly with a saving in time if RCOND is not needed.
// (time for ZPOCO) = (1 + 18/N) * (time for ZPOFA).
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; On input, the hermitian matrix to be
// factored. On output, an upper triangular matrix R so that
// A = hermitian(R)*R
// where hermitian(R) is the conjugate transpose. The strict lower
// triangle is unaltered. If INFO /= 0, the factorization is not
// complete. Only the diagonal and upper triangle are used.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Output, int ZPOFA.
// 0, for normal return.
// K, signals an error condition. The leading minor of order K is
// not positive definite.
//
{
int j;
int info = 0;
for (j = 1; j <= n; j++)
{
double s = 0.0;
int k;
for (k = 1; k <= j - 1; k++)
{
Complex t = a[k - 1 + (j - 1) * lda] - BLAS1Z.zdotc(k - 1, a, 1, a, 1, xIndex: +0 + (k - 1) * lda,
yIndex: +0 + (j - 1) * lda);
t /= a[k - 1 + (k - 1) * lda];
a[k - 1 + (j - 1) * lda] = t;
s += (t * Complex.Conjugate(t)).Real;
}
s = a[j - 1 + (j - 1) * lda].Real - s;
if (s <= 0.0 || a[j - 1 + (j - 1) * lda].Imaginary != 0.0)
{
info = j;
break;
}
a[j - 1 + (j - 1) * lda] = new Complex(Math.Sqrt(s), 0.0);
}
return(info);
}
public static int zgbfa(ref Complex[] abd, int lda, int n, int ml, int mu, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZGBFA factors a complex band matrix by elimination.
//
// Discussion:
//
// ZGBFA is usually called by ZGBCO, but it can be called
// directly with a saving in time if RCOND is not needed.
//
// 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)
// end do
// end do
//
// 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:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, new Complex ABD[LDA*N], on input, contains 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 ABD.
// LDA must be at least 2*ML+MU+1.
//
// Input, int N, the order of the matrix.
//
// Input, int ML, the number of diagonals below the main diagonal.
// 0 <= ML < N.
//
// Input, int MU, the number of diagonals above the main diagonal.
// 0 <= MU < N. More efficient if ML <= MU.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, int ZGBFA.
// 0, normal value.
// K, if U(K,K) == 0.0. This is not an error condition for this
// subroutine, but it does indicate that ZGBSL will divide by zero if
// called. Use RCOND in ZGBCO for a reliable indication of singularity.
//
{
int i;
int jz;
int k;
int m = ml + mu + 1;
int info = 0;
//
// Zero initial fill-in columns.
//
int j0 = mu + 2;
int j1 = Math.Min(n, m) - 1;
for (jz = j0; jz <= j1; jz++)
{
int i0 = m + 1 - jz;
for (i = i0; i <= ml; i++)
{
abd[i - 1 + (jz - 1) * lda] = new Complex(0.0, 0.0);
}
}
jz = j1;
int ju = 0;
//
// Gaussian elimination with partial pivoting.
//
for (k = 1; k <= n - 1; k++)
{
//
// Zero next fill-in column
//
jz += 1;
if (jz <= n)
{
for (i = 1; i <= ml; i++)
{
abd[i - 1 + (jz - 1) * lda] = new Complex(0.0, 0.0);
}
}
//
// Find L = pivot index.
//
int lm = Math.Min(ml, n - k);
int l = BLAS1Z.izamax(lm + 1, abd, 1, index: +m - 1 + (k - 1) * lda) + m - 1;
ipvt[k - 1] = l + k - m;
//
// Zero pivot implies this column already triangularized.
//
if (typeMethods.zabs1(abd[l - 1 + (k - 1) * lda]) == 0.0)
{
info = k;
continue;
}
//
// Interchange if necessary.
//
Complex t;
if (l != m)
{
t = abd[l - 1 + (k - 1) * lda];
abd[l - 1 + (k - 1) * lda] = abd[m - 1 + (k - 1) * lda];
abd[m - 1 + (k - 1) * lda] = t;
}
//
// Compute multipliers.
//
t = -new Complex(1.0, 0.0) / abd[m - 1 + (k - 1) * lda];
BLAS1Z.zscal(lm, t, ref abd, 1, index: +m + (k - 1) * lda);
//
// Row elimination with column indexing.
//
ju = Math.Min(Math.Max(ju, mu + ipvt[k - 1]), n);
int mm = m;
int j;
for (j = k + 1; j <= ju; j++)
{
l -= 1;
mm -= 1;
t = abd[l - 1 + (j - 1) * lda];
if (l != mm)
{
abd[l - 1 + (j - 1) * lda] = abd[mm - 1 + (j - 1) * lda];
abd[mm - 1 + (j - 1) * lda] = t;
}
BLAS1Z.zaxpy(lm, t, abd, 1, ref abd, 1, xIndex: +m + (k - 1) * lda, yIndex: +mm + (j - 1) * lda);
}
}
ipvt[n - 1] = n;
if (typeMethods.zabs1(abd[m - 1 + (n - 1) * lda]) == 0.0)
{
info = n;
}
return(info);
}
public static int zgefa(ref Complex[] a, int lda, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZGEFA factors a complex matrix by Gaussian elimination.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the matrix to be factored.
// On output, an upper triangular matrix 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 A.
//
// Input, int N, the order of the matrix.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, int ZGEFA,
// 0, normal value.
// K, if U(K,K) == 0.0. This is not an error condition for this
// subroutine, but it does indicate that ZGESL or ZGEDI will divide by zero
// if called. Use RCOND in ZGECO for a reliable indication of singularity.
//
{
int k;
//
// Gaussian elimination with partial pivoting.
//
int info = 0;
for (k = 1; k <= n - 1; k++)
{
//
// Find L = pivot index.
//
int l = BLAS1Z.izamax(n - k + 1, a, 1, index: +(k - 1) + (k - 1) * lda) + k - 1;
ipvt[k - 1] = l;
//
// Zero pivot implies this column already triangularized.
//
if (typeMethods.zabs1(a[l - 1 + (k - 1) * lda]) == 0.0)
{
info = k;
continue;
}
//
// Interchange if necessary.
//
Complex t;
if (l != k)
{
t = a[l - 1 + (k - 1) * lda];
a[l - 1 + (k - 1) * lda] = a[k - 1 + (k - 1) * lda];
a[k - 1 + (k - 1) * lda] = t;
}
//
// Compute multipliers
//
t = -new Complex(1.0, 0.0) / a[k - 1 + (k - 1) * lda];
BLAS1Z.zscal(n - k, t, ref a, 1, index: +k + (k - 1) * lda);
//
// Row elimination with column indexing
//
int j;
for (j = k + 1; j <= n; j++)
{
t = a[l - 1 + (j - 1) * lda];
if (l != k)
{
a[l - 1 + (j - 1) * lda] = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = t;
}
BLAS1Z.zaxpy(n - k, t, a, 1, ref a, 1, xIndex: +k + (k - 1) * lda, yIndex: +k + (j - 1) * lda);
}
}
ipvt[n - 1] = n;
if (typeMethods.zabs1(a[n - 1 + (n - 1) * lda]) == 0.0)
{
info = n;
}
return(info);
}
public static void zpbsl(Complex[] abd, int lda, int n, int m,
ref Complex[] b)
//****************************************************************************80
//
// Purpose:
//
// ZPBSL solves a complex hermitian positive definite band system.
//
// Discussion:
//
// The system matrix must have been factored by ZPBCO or ZPBFA.
//
// A division by zero will occur if the input factor contains
// a zero on the diagonal. Technically this indicates
// singularity but it is usually caused by improper subroutine
// arguments. It will not occur if the subroutines are called
// correctly and INFO == 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex ABD[LDA*N], the output from ZPBCO or ZPBFA.
//
// Input, int LDA, the leading dimension of ABD.
//
// Input, int N, the order of the matrix.
//
// Input, int M, the number of diagonals above the main diagonal.
//
// Input/output, Complex B[N]. On input, the right hand side.
// On output, the solution.
//
{
int k;
int la;
int lb;
int lm;
Complex t;
//
// Solve hermitian(R) * Y = B.
//
for (k = 1; k <= n; k++)
{
lm = Math.Min(k - 1, m);
la = m + 1 - lm;
lb = k - lm;
t = BLAS1Z.zdotc(lm, abd, 1, b, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
b[k - 1] = (b[k - 1] - t) / abd[m + (k - 1) * lda];
}
//
// Solve R * X = Y.
//
for (k = n; 1 <= k; k--)
{
lm = Math.Min(k - 1, m);
la = m + 1 - lm;
lb = k - lm;
b[k - 1] /= abd[m + (k - 1) * lda];
t = -b[k - 1];
BLAS1Z.zaxpy(lm, t, abd, 1, ref b, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
}
public static int zqrsl(Complex[] x, int ldx, int n, int k,
Complex[] qraux, Complex[] y, ref Complex[] qy,
ref Complex[] qty, ref Complex[] b, ref Complex[] rsd,
ref Complex[] xb, int job)
//****************************************************************************80
//
// Purpose:
//
// ZQRSL solves, transforms or projects systems factored by ZQRDC.
//
// Discussion:
//
// The routine applies the output of ZQRDC to compute coordinate
// transformations, projections, and least squares solutions.
//
// For K <= min ( N, P ), let XK be the matrix
//
// XK = ( X(IPVT(1)), X(IPVT(2)), ... ,X(IPVT(k)) )
//
// formed from columnns IPVT(1), ... ,IPVT(K) of the original
// N by P matrix X that was input to ZQRDC (if no pivoting was
// done, XK consists of the first K columns of X in their
// original order). ZQRDC produces a factored unitary matrix Q
// and an upper triangular matrix R such that
//
// XK = Q * ( R )
// ( 0 )
//
// This information is contained in coded form in the arrays
// X and QRAUX.
//
// The parameters QY, QTY, B, RSD, and XB are not referenced
// if their computation is not requested and in this case
// can be replaced by dummy variables in the calling program.
//
// To save storage, the user may in some cases use the same
// array for different parameters in the calling sequence. A
// frequently occuring example is when one wishes to compute
// any of B, RSD, or XB and does not need Y or QTY. In this
// case one may identify Y, QTY, and one of B, RSD, or XB, while
// providing separate arrays for anything else that is to be
// computed. Thus the calling sequence
//
// zqrsl ( x, ldx, n, k, qraux, y, dum, y, b, y, dum, 110, info )
//
// will result in the computation of B and RSD, with RSD
// overwriting Y. More generally, each item in the following
// list contains groups of permissible identifications for
// a single callinng sequence.
//
// 1. ( Y, QTY, B ) ( RSD ) ( XB ) ( QY )
// 2. ( Y, QTY, RSD ) ( B ) ( XB ) ( QY )
// 3. ( Y, QTY, XB ) ( B ) ( RSD ) ( QY )
// 4. ( Y, QY ) ( QTY, B ) ( RSD ) ( XB )
// 5. ( Y, QY ) ( QTY, RSD ) ( B ) ( XB )
// 6. ( Y, QY ) ( QTY, XB ) ( B ) ( RSD )
//
// In any group the value returned in the array allocated to
// the group corresponds to the last member of the group.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex X[LDX*P], the output of ZQRDC.
//
// Input, int LDX, the leading dimension of X.
//
// Input, int N, the number of rows of the matrix XK, which
// must have the same value as N in ZQRDC.
//
// Input, int K, the number of columns of the matrix XK. K must not
// be greater than min ( N, P), where P is the same as in the calling
// sequence to ZQRDC.
//
// Input, Complex QRAUX[P], the auxiliary output from ZQRDC.
//
// Input, Complex Y[N], a vector that is to be manipulated by ZQRSL.
//
// Output, Complex QY[N], contains Q*Y, if it has been requested.
//
// Output, Complex QTY[N], contains hermitian(Q)*Y, if it has
// been requested. Here hermitian(Q) is the conjugate transpose
// of the matrix Q.
//
// Output, Complex B[K], the solution of the least squares problem
// minimize norm2 ( Y - XK * B ),
// if it has been requested. If pivoting was requested in ZQRDC,
// the J-th component of B will be associated with column IPVT(J)
// of the original matrix X that was input into ZQRDC.
//
// Output, Complex RSD[N], the least squares residual Y - XK*B,
// if it has been requested. RSD is also the orthogonal projection
// of Y onto the orthogonal complement of the column space of XK.
//
// Output, Complex XB[N], the least squares approximation XK*N,
// if its computation has been requested. XB is also the orthogonal
// projection of Y onto the column space of X.
//
// Input, int JOB, specifies what is to be computed. JOB has
// the decimal expansion ABCDE, meaning:
// if A != 0, compute QY.
// if B, D, D, or E != 0, compute QTY.
// if C != 0, compute B.
// if D != 0, compute RSD.
// if E != 0, compute XB.
// A request to compute B, RSD, or XB automatically triggers the
// computation of QTY, for which an array must be provided in the
// calling sequence.
//
// Output, int ZQRSL, the value of INFO, which is zero unless
// the computation of B has been requested and R is exactly singular.
// In this case, INFO is the index of the first zero diagonal element
// of R and B is left unaltered.
//
{
int i;
int j;
int jj;
Complex t;
Complex temp;
int info = 0;
//
// Determine what is to be computed.
//
bool cqy = job / 10000 != 0;
bool cqty = job % 10000 != 0;
bool cb = job % 1000 / 100 != 0;
bool cr = job % 100 / 10 != 0;
bool cxb = job % 10 != 0;
int ju = Math.Min(k, n - 1);
switch (ju)
{
//
// Special action when N=1.
//
case 0:
{
qy[0] = cqy switch
{
true => y[0],
_ => qy[0]
};
qty[0] = cqty switch
{
true => y[0],
_ => qty[0]
};
xb[0] = cxb switch
{
true => y[0],
_ => xb[0]
};
switch (cb)
{
case true when typeMethods.zabs1(x[0 + 0 * ldx]) == 0.0:
info = 1;
break;
case true:
b[0] = y[0] / x[0 + 0 * ldx];
break;
}
rsd[0] = cr switch
{
true => new Complex(0.0, 0.0),
_ => rsd[0]
};
return(info);
}
}
switch (cqy)
{
//
// Set up to compute QY or QTY.
//
case true:
{
for (i = 0; i < n; i++)
{
qy[i] = y[i];
}
break;
}
}
switch (cqty)
{
case true:
{
for (i = 0; i < n; i++)
{
qty[i] = y[i];
}
break;
}
}
switch (cqy)
{
//
// Compute QY.
//
case true:
{
for (jj = 1; jj <= ju; jj++)
{
j = ju - jj + 1;
if (typeMethods.zabs1(qraux[j - 1]) == 0.0)
{
continue;
}
temp = x[j - 1 + (j - 1) * ldx];
x[j - 1 + (j - 1) * ldx] = qraux[j - 1];
t = -BLAS1Z.zdotc(n - j + 1, x, 1, qy, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1) /
x[j - 1 + (j - 1) * ldx];
BLAS1Z.zaxpy(n - j + 1, t, x, 1, ref qy, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1);
x[j - 1 + (j - 1) * ldx] = temp;
}
break;
}
}
switch (cqty)
{
//
// Compute hermitian ( A ) * Y.
//
case true:
{
for (j = 1; j <= ju; j++)
{
if (typeMethods.zabs1(qraux[j - 1]) == 0.0)
{
continue;
}
temp = x[j - 1 + (j - 1) * ldx];
x[j - 1 + (j - 1) * ldx] = qraux[j - 1];
t = -BLAS1Z.zdotc(n - j + 1, x, 1, qty, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1) /
x[j - 1 + (j - 1) * ldx];
BLAS1Z.zaxpy(n - j + 1, t, x, 1, ref qty, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1);
x[j - 1 + (j - 1) * ldx] = temp;
}
break;
}
}
switch (cb)
{
//
// Set up to compute B, RSD, or XB.
//
case true:
{
for (i = 0; i < k; i++)
{
b[i] = qty[i];
}
break;
}
}
switch (cxb)
{
case true:
{
for (i = 0; i < k; i++)
{
xb[i] = qty[i];
}
break;
}
}
switch (cr)
{
case true when k < n:
{
for (i = k; i < n; i++)
{
rsd[i] = qty[i];
}
break;
}
}
switch (cxb)
{
case true:
{
for (i = k; i < n; i++)
{
xb[i] = new Complex(0.0, 0.0);
}
break;
}
}
switch (cr)
{
case true:
{
for (i = 0; i < k; i++)
{
rsd[i] = new Complex(0.0, 0.0);
}
break;
}
}
switch (cb)
{
//
// Compute B.
//
case true:
{
for (jj = 1; jj <= k; jj++)
{
j = k - jj + 1;
if (typeMethods.zabs1(x[j - 1 + (j - 1) * ldx]) == 0.0)
{
info = j;
break;
}
b[j - 1] /= x[j - 1 + (j - 1) * ldx];
if (j == 1)
{
continue;
}
t = -b[j - 1];
BLAS1Z.zaxpy(j - 1, t, x, 1, ref b, 1, xIndex: +0 + (j - 1) * ldx);
}
break;
}
}
if (!cr && !cxb)
{
return(info);
}
//
// Compute RSD or XB as required.
//
for (jj = 1; jj <= ju; jj++)
{
j = ju - jj + 1;
if (typeMethods.zabs1(qraux[j - 1]) == 0.0)
{
continue;
}
temp = x[j - 1 + (j - 1) * ldx];
x[j - 1 + (j - 1) * ldx] = qraux[j - 1];
switch (cr)
{
case true:
t = -BLAS1Z.zdotc(n - j + 1, x, 1, rsd, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1)
/ x[j - 1 + (j - 1) * ldx];
BLAS1Z.zaxpy(n - j + 1, t, x, 1, ref rsd, 1, xIndex: +j - 1 + (j - 1) * ldx,
yIndex: +j - 1);
break;
}
switch (cxb)
{
case true:
t = -BLAS1Z.zdotc(n - j + 1, x, 1, xb, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1)
/ x[j - 1 + (j - 1) * ldx];
BLAS1Z.zaxpy(n - j + 1, t, x, 1, ref xb, 1, xIndex: +j - 1 + (j - 1) * ldx, yIndex: +j - 1);
break;
}
x[j - 1 + (j - 1) * ldx] = temp;
}
return(info);
}
}
public static double zsico(ref Complex[] a, int lda, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZSICO factors a complex symmetric matrix.
//
// Discussion:
//
// The factorization is done by symmetric pivoting.
//
// The routine also estimates the condition of the matrix.
//
// If RCOND is not needed, ZSIFA is slightly faster.
//
// To solve A*X = B, follow ZSICO by ZSISL.
//
// To compute inverse(A)*C, follow ZSICO by ZSISL.
//
// To compute inverse(A), follow ZSICO by ZSIDI.
//
// To compute determinant(A), follow ZSICO by ZSIDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the symmetric matrix to be
// factored. 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. Only the diagonal and upper triangle are used.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Output, int IPVT[N], the pivot indices.
//
// Output, double ZSICO, an estimate of RCOND, the reciprocal condition of
// the matrix. 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.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
// Local Parameters:
//
// Workspace, Complex 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).
//
{
Complex ak;
Complex akm1;
Complex bk;
Complex bkm1;
Complex denom;
int j;
int kp;
int kps;
int ks;
double rcond;
double s;
Complex t;
Complex[] z = new Complex [n];
//
// Find norm of A using only upper half.
//
for (j = 1; j <= n; j++)
{
z[j - 1] = new Complex(BLAS1Z.dzasum(j, a, 1, index: +0 + (j - 1) * lda), 0.0);
int i;
for (i = 1; i <= j - 1; i++)
{
z[i - 1] =
new Complex(z[i - 1].Real + typeMethods.zabs1(a[i - 1 + (j - 1) * lda]), 0.0);
}
}
double anorm = 0.0;
for (j = 0; j < n; j++)
{
anorm = Math.Max(anorm, z[j].Real);
}
//
// Factor.
//
ZSIFA.zsifa(ref a, lda, n, ref ipvt);
//
// 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.
//
Complex ek = new(1.0, 0.0);
for (j = 0; j < n; j++)
{
z[j] = new Complex(0.0, 0.0);
}
int k = n;
while (0 < k)
{
ks = ipvt[k - 1] switch
{
public static void zsidi(ref Complex[] a, int lda, int n, int[] ipvt,
ref Complex[] det, int job)
//****************************************************************************80
//
// Purpose:
//
// ZSIDI computes the determinant and inverse of a matrix factored by ZSIFA.
//
// Discussion:
//
// It is assumed the complex symmetric matrix has already been factored
// by ZSIFA.
//
// A division by zero may occur if the inverse is requested
// and ZSICO set RCOND == 0.0 or ZSIFA set INFO nonzero.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the output from ZSIFA.
// If the inverse was requested, then on output, A contains the upper triangle
// of the inverse of the original matrix. The strict lower triangle
// is never referenced.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Input, int IPVT[N], the pivot vector from ZSIFA.
//
// Output, Complex DET[2], if requested, the determinant of the matrix.
// Determinant = DET(1) * 10.0**DET(2) with 1.0 <= abs ( DET(1) ) < 10.0
// or DET(1) = 0.0. Also, DET(2) is strictly real.
//
// Input, int JOB, has the decimal expansion AB where
// if B != 0, the inverse is computed,
// if A != 0, the determinant is computed,
// For example, JOB = 11 gives both.
//
{
Complex d;
int k;
Complex t;
bool noinv = job % 10 == 0;
bool nodet = job % 100 / 10 == 0;
switch (nodet)
{
case false:
{
det[0] = new Complex(1.0, 0.0);
det[1] = new Complex(0.0, 0.0);
t = new Complex(0.0, 0.0);
for (k = 1; k <= n; k++)
{
d = a[k - 1 + (k - 1) * lda];
switch (ipvt[k - 1])
{
//
// 2 by 2 block.
// Use det ( D T ) = ( D / T * C - T ) * T
// ( T C )
// to avoid underflow/overflow troubles.
// Take two passes through scaling. Use T for flag.
//
case <= 0 when typeMethods.zabs1(t) == 0.0:
t = a[k - 1 + k * lda];
d = d / t * a[k + k * lda] - t;
break;
case <= 0:
d = t;
t = new Complex(0.0, 0.0);
break;
}
det[0] *= d;
if (typeMethods.zabs1(det[0]) == 0.0)
{
continue;
}
while (typeMethods.zabs1(det[0]) < 1.0)
{
det[0] *= new Complex(10.0, 0.0);
det[1] -= new Complex(1.0, 0.0);
}
while (10.0 <= typeMethods.zabs1(det[0]))
{
det[0] /= new Complex(10.0, 0.0);
det[1] += new Complex(1.0, 0.0);
}
}
break;
}
}
switch (noinv)
{
//
// Compute inverse ( A ).
//
case false:
{
Complex[] work = new Complex [n];
k = 1;
while (k <= n)
{
int km1 = k - 1;
int kstep;
int j;
int i;
switch (ipvt[k - 1])
{
//
// 1 by 1
//
case >= 0:
{
a[k - 1 + (k - 1) * lda] = new Complex(1.0, 0.0) / a[k - 1 + (k - 1) * lda];
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + (k - 1) * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1Z.zdotu(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(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] += BLAS1Z.zdotu(km1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda);
break;
}
}
kstep = 1;
break;
}
//
default:
{
t = a[k - 1 + k * lda];
Complex ak = a[k - 1 + (k - 1) * lda] / t;
Complex akp1 = a[k + k * lda] / t;
Complex akkp1 = a[k - 1 + k * lda] / t;
d = t * (ak * akp1 - new Complex(1.0, 0.0));
a[k - 1 + (k - 1) * lda] = akp1 / d;
a[k + k * lda] = ak / d;
a[k - 1 + k * lda] = -akkp1 / d;
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + k * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + k * lda] = BLAS1Z.zdotu(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(j - 1, work[j - 1], a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda,
yIndex: +0 + k * lda);
}
a[k + k * lda] += BLAS1Z.zdotu(km1, work, 1, a, 1, yIndex: +0 + k * lda);
a[k - 1 + k * lda] += BLAS1Z.zdotu(km1, a, 1, a, 1, xIndex: +0 + (k - 1) * lda,
yIndex: +0 + k * lda);
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + (k - 1) * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1Z.zdotu(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(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] += BLAS1Z.zdotu(km1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda);
break;
}
}
kstep = 2;
break;
}
}
//
// Swap.
//
int ks = Math.Abs(ipvt[k - 1]);
if (ks != k)
{
BLAS1Z.zswap(ks, ref a, 1, ref a, 1, xIndex: +0 + (ks - 1) * lda, yIndex: +0 + (k - 1) * lda);
int jb;
for (jb = ks; jb <= k; jb++)
{
j = k + ks - jb;
t = a[j - 1 + (k - 1) * lda];
a[j - 1 + (k - 1) * lda] = a[ks - 1 + (j - 1) * lda];
a[ks - 1 + (j - 1) * lda] = t;
}
if (kstep != 1)
{
t = a[ks - 1 + k * lda];
a[ks - 1 + k * lda] = a[k - 1 + k * lda];
a[k - 1 + k * lda] = t;
}
}
k += kstep;
}
break;
}
}
}
public static int zchdc(ref Complex[] a, int lda, int p, ref int[] ipvt, int job)
//****************************************************************************80
//
// Purpose:
//
// ZCHDC: Cholesky decomposition of a Hermitian positive definite matrix.
//
// Discussion:
//
// A pivoting option allows the user to estimate the condition of a
// Hermitian positive definite matrix or determine the rank of a
// Hermitian positive semidefinite matrix.
//
// For Hermitian positive definite matrices, INFO = P is the normal return.
//
// For pivoting with Hermitian 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:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, complex <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 matrix A as it has been permuted by pivoting.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int P, the order of the matrix.
//
// Input/output, int IPVT[P]. IPVT is not referenced if JOB == 0.
// 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 input
// value of IPVT(K):
// IPVT(K) > 0, X(K) is an initial element.
// IPVT(K) == 0, X(K) is a free element.
// IPVT(K) < 0, 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.
// On output, IPVT(K) contains the index of the diagonal element
// of A that was moved into the J-th position, if pivoting was requested.
//
// Input, int JOB, specifies whether column pivoting is to be done.
// 0, no pivoting is done.
// nonzero, pivoting is done.
//
// Output, int ZCHDC, contains the index of the last positive
// diagonal element of the Cholesky factor.
//
{
int i_temp;
int j;
int k;
Complex temp;
int pl = 1;
int pu = 0;
int info = p;
Complex[] work = new Complex[p];
if (job != 0)
{
//
// Pivoting has been requested. Rearrange the elements according to IPVT.
//
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)
{
BLAS1Z.zswap(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;
a[pl - 1 + (k - 1) * lda] = Complex.Conjugate(a[pl - 1 + (k - 1) * lda]);
int plp1 = pl + 1;
for (j = plp1; j <= p; j++)
{
if (j < k)
{
temp = Complex.Conjugate(a[pl - 1 + (j - 1) * lda]);
a[pl - 1 + (j - 1) * lda] = Complex.Conjugate(a[j - 1 + (k - 1) * lda]);
a[j - 1 + (k - 1) * lda] = temp;
}
else if (j != k)
{
temp = a[pl - 1 + (j - 1) * lda];
a[pl - 1 + (j - 1) * lda] = a[k - 1 + (j - 1) * lda];
a[k - 1 + (j - 1) * lda] = temp;
}
}
ipvt[k - 1] = ipvt[pl - 1];
ipvt[pl - 1] = k;
}
pl += 1;
break;
}
}
}
pu = p;
int kb;
for (kb = pl; kb <= p; kb++)
{
k = p - kb + pl;
switch (ipvt[k - 1])
{
case < 0:
{
ipvt[k - 1] = -ipvt[k - 1];
if (pu != k)
{
BLAS1Z.zswap(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;
a[k - 1 + (pu - 1) * lda] = Complex.Conjugate(a[k - 1 + (pu - 1) * lda]);
for (j = k + 1; j <= p; j++)
{
if (j < pu)
{
temp = Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
a[k - 1 + (j - 1) * lda] = Complex.Conjugate(a[j - 1 + (pu - 1) * lda]);
a[j - 1 + (pu - 1) * lda] = temp;
}
else if (j != pu)
{
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;
}
}
i_temp = ipvt[k - 1];
ipvt[k - 1] = ipvt[pu - 1];
ipvt[pu - 1] = i_temp;
}
pu -= 1;
break;
}
}
}
}
for (k = 1; k <= p; k++)
{
//
// Reduction loop.
//
double maxdia = a[k - 1 + (k - 1) * lda].Real;
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].Real))
{
continue;
}
maxdia = a[l - 1 + (l - 1) * lda].Real;
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)
{
BLAS1Z.zswap(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] = new Complex(maxdia, 0.0);
i_temp = ipvt[maxl - 1];
ipvt[maxl - 1] = ipvt[k - 1];
ipvt[k - 1] = i_temp;
a[k - 1 + (maxl - 1) * lda] = Complex.Conjugate(a[k - 1 + (maxl - 1) * lda]);
}
//
// Reduction step. Pivoting is contained across the rows.
//
work[k - 1] = new Complex(Math.Sqrt(a[k - 1 + (k - 1) * lda].Real), 0.0);
a[k - 1 + (k - 1) * lda] = work[k - 1];
for (j = k + 1; j <= p; j++)
{
if (k != maxl)
{
if (j < maxl)
{
temp = Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
a[k - 1 + (j - 1) * lda] = Complex.Conjugate(a[j - 1 + (maxl - 1) * lda]);
a[j - 1 + (maxl - 1) * lda] = temp;
}
else if (j != maxl)
{
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] = Complex.Conjugate(a[k - 1 + (j - 1) * lda]);
temp = -a[k - 1 + (j - 1) * lda];
BLAS1Z.zaxpy(j - k, temp, work, 1, ref a, 1, xIndex: +k, yIndex: +k + (j - 1) * lda);
}
}
return(info);
}
}
public static void zhidi(ref Complex[] a, int lda, int n, int[] ipvt, ref double[] det,
ref int[] inert, int job)
//****************************************************************************80
//
// Purpose:
//
// ZHIDI computes the determinant and inverse of a matrix factored by ZHIFA.
//
// Discussion:
//
// ZHIDI computes the determinant, inertia (number of positive, zero,
// and negative eigenvalues) and inverse of a complex hermitian matrix
// using the factors from ZHIFA.
//
// A division by zero may occur if the inverse is requested
// and ZHICO has set RCOND == 0.0 or ZHIFA has set INFO /= 0.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex A[LDA*N]; on input, the factored matrix
// from ZHIFA. On output, if the inverse was requested, A contains
// the inverse matrix. The strict lower triangle of A is never
// referenced.
//
// Input, int LDA, the leading dimension of A.
//
// Input, int N, the order of the matrix.
//
// Input, int IPVT[N], the pivot vector from ZHIFA.
//
// Output, double DET[2], the determinant of the original matrix.
// Determinant = det[0] * 10.0**det[1] with 1.0 <= Math.Abs ( det[0] ) < 10.0
// or det[0] = 0.0.
//
// Output, int INERT[3], the inertia of the original matrix.
// INERT(1) = number of positive eigenvalues.
// INERT(2) = number of negative eigenvalues.
// INERT(3) = number of zero eigenvalues.
//
// Input, int 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 i;
int k;
double t;
bool noinv = job % 10 == 0;
bool nodet = job % 100 / 10 == 0;
bool noert = job % 1000 / 100 == 0;
if (!nodet || !noert)
{
switch (noert)
{
case false:
{
for (i = 0; i < 3; i++)
{
inert[i] = 0;
}
break;
}
}
switch (nodet)
{
case false:
det[0] = 1.0;
det[1] = 0.0;
break;
}
t = 0.0;
for (k = 0; k < n; k++)
{
d = a[k + k * lda].Real;
switch (ipvt[k])
{
//
// Check if 1 by 1.
//
//
// 2 by 2 block
// Use DET = ( D / T * C - T ) * T, T = Math.Abs ( S )
// to avoid underflow/overflow troubles.
// Take two passes through scaling. Use T for flag.
//
case <= 0 when t == 0.0:
t = Complex.Abs(a[k + (k + 1) * lda]);
d = d / t * a[k + 1 + (k + 1) * lda].Real - t;
break;
case <= 0:
d = t;
t = 0.0;
break;
}
switch (noert)
{
case false:
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 (nodet)
{
case false:
{
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 (noinv)
{
//
// Compute inverse(A).
//
case false:
{
Complex[] work = new Complex [n];
k = 1;
while (k <= n)
{
int km1 = k - 1;
int kstep;
int j;
switch (ipvt[k - 1])
{
case >= 0:
{
//
// 1 by 1
//
a[k - 1 + (k - 1) * lda] =
new Complex(1.0 / a[k - 1 + (k - 1) * lda].Real, 0.0);
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + (k - 1) * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1Z.zdotc(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(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] += new Complex(
BLAS1Z.zdotc(km1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda).Real, 0.0);
break;
}
}
kstep = 1;
break;
}
default:
{
//
// 2 by 2
//
t = Complex.Abs(a[k - 1 + k * lda]);
double ak = a[k - 1 + (k - 1) * lda].Real / t;
double akp1 = a[k + k * lda].Real / t;
Complex akkp1 = a[k - 1 + k * lda] / t;
d = t * (ak * akp1 - 1.0);
a[k - 1 + (k - 1) * lda] = new Complex(akp1 / d, 0.0);
a[k + k * lda] = new Complex(ak / d, 0.0);
a[k - 1 + k * lda] = -akkp1 / d;
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + k * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + k * lda] = BLAS1Z.zdotc(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(j - 1, work[j - 1], a, 1, ref a, 1, xIndex: +0 + (j - 1) * lda,
yIndex: +0 + k * lda);
}
a[k + k * lda] += new Complex(
BLAS1Z.zdotc(km1, work, 1, a, 1, yIndex: +0 + k * lda).Real, 0.0);
a[k - 1 + k * lda] += BLAS1Z.zdotc(km1, a, 1, a, 1, xIndex: +0 + (k - 1) * lda,
yIndex: +0 + k * lda);
for (i = 1; i <= km1; i++)
{
work[i - 1] = a[i - 1 + (k - 1) * lda];
}
for (j = 1; j <= km1; j++)
{
a[j - 1 + (k - 1) * lda] = BLAS1Z.zdotc(j, a, 1, work, 1, xIndex: +0 + (j - 1) * lda);
BLAS1Z.zaxpy(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] += new Complex(
BLAS1Z.zdotc(km1, work, 1, a, 1, yIndex: +0 + (k - 1) * lda).Real, 0.0);
break;
}
}
kstep = 2;
break;
}
}
//
// Swap
//
int ks = Math.Abs(ipvt[k - 1]);
if (ks != k)
{
BLAS1Z.zswap(ks, ref a, 1, ref a, 1, xIndex: +0 + (ks - 1) * lda, yIndex: +0 + (k - 1) * lda);
Complex t2;
for (j = k; ks <= j; j--)
{
t2 = Complex.Conjugate(a[j - 1 + (k - 1) * lda]);
a[j - 1 + (k - 1) * lda] = Complex.Conjugate(a[ks - 1 + (j - 1) * lda]);
a[ks - 1 + (j - 1) * lda] = t2;
}
if (kstep != 1)
{
t2 = a[ks - 1 + k * lda];
a[ks - 1 + k * lda] = a[k - 1 + k * lda];
a[k - 1 + k * lda] = t2;
}
}
k += kstep;
}
break;
}
}
}
public static double zppco(ref Complex[] ap, int n, ref int info)
//****************************************************************************80
//
// Purpose:
//
// ZPPCO factors a complex <double> hermitian positive definite matrix.
//
// Discussion:
//
// The routine also estimates the condition of the matrix.
//
// The matrix is stored in packed form.
//
// If RCOND is not needed, ZPPFA is slightly faster.
//
// To solve A*X = B, follow ZPPCO by ZPPSL.
//
// To compute inverse(A)*C, follow ZPPCO by ZPPSL.
//
// To compute determinant(A), follow ZPPCO by ZPPDI.
//
// To compute inverse(A), follow ZPPCO by ZPPDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, complex <double> AP[N*(N+1)/2]; on input, the packed form of a
// hermitian matrix. 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 = hermitian(R) * R.
// If INFO != 0 , the factorization is not complete.
//
// Input, int N, the order of the matrix.
//
// Output, double ZPPCO, an estimate of RCOND, the reciprocal condition of
// the matrix. 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.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
// Output, int *INFO.
// 0, for normal return.
// K, signals an error condition. The leading minor of order K is not
// positive definite.
//
// Local Parameters:
//
// Local, complex <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).
//
{
int j;
int k;
double rcond;
double s;
Complex t;
//
// Find norm of A.
//
Complex[] z = new Complex [n];
int j1 = 1;
for (j = 1; j <= n; j++)
{
z[j - 1] = new Complex(BLAS1Z.dzasum(j, ap, 1, index: +j1 - 1), 0.0);
int ij = j1;
j1 += j;
int i;
for (i = 1; i <= j - 1; i++)
{
z[i - 1] = new Complex(z[i - 1].Real + typeMethods.zabs1(ap[ij - 1]), 0.0);
ij += 1;
}
}
double anorm = 0.0;
for (j = 0; j < n; j++)
{
anorm = Math.Max(anorm, z[j].Real);
}
//
// Factor.
//
info = ZPPFA.zppfa(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 hermitian(R)*W = E.
//
// The vectors are frequently rescaled to avoid overflow.
//
// Solve hermitian(R)*W = E.
//
Complex ek = new(1.0, 0.0);
for (j = 0; j < n; j++)
{
z[j] = new Complex(0.0, 0.0);
}
int kk = 0;
for (k = 1; k <= n; k++)
{
kk += k;
if (typeMethods.zabs1(z[k - 1]) != 0.0)
{
ek = typeMethods.zsign1(ek, -z[k - 1]);
}
if (ap[kk - 1].Real < typeMethods.zabs1(ek - z[k - 1]))
{
s = ap[kk - 1].Real / typeMethods.zabs1(ek - z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ek = new Complex(s, 0.0) * ek;
}
Complex wk = ek - z[k - 1];
Complex wkm = -ek - z[k - 1];
s = typeMethods.zabs1(wk);
double sm = typeMethods.zabs1(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 += typeMethods.zabs1(z[j - 1] + wkm * Complex.Conjugate(ap[kj - 1]));
z[j - 1] += wk * Complex.Conjugate(ap[kj - 1]);
s += typeMethods.zabs1(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 * Complex.Conjugate(ap[kj - 1]);
kj += j;
}
}
}
z[k - 1] = wk;
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
//
// Solve R * Y = W.
//
for (k = n; 1 <= k; k--)
{
if (ap[kk - 1].Real < typeMethods.zabs1(z[k - 1]))
{
s = ap[kk - 1].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
}
z[k - 1] /= ap[kk - 1];
kk -= k;
t = -z[k - 1];
BLAS1Z.zaxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk);
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
double ynorm = 1.0;
//
// Solve hermitian(R) * V = Y.
//
for (k = 1; k <= n; k++)
{
z[k - 1] -= BLAS1Z.zdotc(k - 1, ap, 1, z, 1, xIndex: +kk);
kk += k;
if (ap[kk - 1].Real < typeMethods.zabs1(z[k - 1]))
{
s = ap[kk - 1].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
z[k - 1] /= ap[kk - 1];
}
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
//
// Solve R * Z = V.
//
for (k = n; 1 <= k; k--)
{
if (ap[kk - 1].Real < typeMethods.zabs1(z[k - 1]))
{
s = ap[kk - 1].Real / typeMethods.zabs1(z[k - 1]);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
}
z[k - 1] /= ap[kk - 1];
kk -= k;
t = -z[k - 1];
BLAS1Z.zaxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk);
}
//
// Make ZNORM = 1.
//
s = 1.0 / BLAS1Z.dzasum(n, z, 1);
BLAS1Z.zdscal(n, s, ref z, 1);
ynorm = s * ynorm;
if (anorm != 0.0)
{
rcond = ynorm / anorm;
}
else
{
rcond = 0.0;
}
return(rcond);
}
public static int zcdhd(ref Complex[] r, int ldr, int p, Complex[] x,
ref Complex[] z, int ldz, int nz, Complex[] y, ref double[] rho,
ref double[] c, ref Complex[] s)
//****************************************************************************80
//
// Purpose:
//
// ZCHDD downdates an augmented Cholesky decomposition.
//
// Discussion:
//
// zcdhD downdates an augmented Cholesky decomposition or the
// triangular factor of an augmented QR decomposition.
// Specifically, given an upper triangular matrix R of order P, a
// row vector X, a column vector Z, and a scalar Y, ZCHDD
// determines a unitary matrix U and a scalar ZETA such that
//
// ( R Z ) ( RR ZZ )
// U * ( ) = ( ),
// ( 0 ZETA ) ( X Y )
//
// where RR is upper triangular. If R and Z have been obtained
// from the factorization of a least squares problem, then
// RR and ZZ are the factors corresponding to the problem
// with the observation (X,Y) removed. In this case, if RHO
// is the norm of the residual vector, then the norm of
// the residual vector of the downdated problem is
// Math.Sqrt ( RHO**2 - ZETA**2 ).
// zcdhD will simultaneously downdate several triplets (Z,Y,RHO)
// along with R.
//
// For a less terse description of what ZCHDD does and how
// it may be applied, see the LINPACK guide.
//
// The matrix U is determined as the product U(1)*...*U(P)
// where U(I) is a rotation in the (P+1,I)-plane of the
// form
//
// ( C(I) -Complex.Conjugate ( S(I) ) )
// ( ).
// ( S(I) C(I) )
//
// The rotations are chosen so that C(I) is real.
//
// The user is warned that a given downdating problem may
// be impossible to accomplish or may produce
// inaccurate results. For example, this can happen
// if X is near a vector whose removal will reduce the
// rank of R. Beware.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex R[LDR*P]; on input, the upper triangular matrix
// that is to be downdated. On output, the downdated matrix. The
// part of R below the diagonal is not referenced.
//
// Input, int LDR, the leading dimension of R. P <= LDR.
//
// Input, int P, the order of the matrix.
//
// Input, Complex X(P), the row vector that is to
// be removed from R.
//
// Input/output, Complex Z[LDZ*NZ]; on input, an array of NZ
// P-vectors which are to be downdated along with R. On output,
// the downdated vectors.
//
// Input, int LDZ, the leading dimension of Z. P <= LDZ.
//
// Input, int NZ, the number of vectors to be downdated.
// NZ may be zero, in which case Z, Y, and R are not referenced.
//
// Input, Complex Y[NZ], the scalars for the downdating
// of the vectors Z.
//
// Input/output, double RHO[NZ]. On input, the norms of the residual
// vectors that are to be downdated. On output, the downdated norms.
//
// Output, double C[P], the cosines of the transforming rotations.
//
// Output, Complex S[P], the sines of the transforming rotations.
//
// Output, int ZCHDD:
// 0, if the entire downdating was successful.
// -1, if R could not be downdated. In this case, all quantities
// are left unaltered.
// 1, if some RHO could not be downdated. The offending RHO's are
// set to -1.
//
{
int i;
int ii;
int j;
//
// Solve the system hermitian(R) * A = X, placing the result in S.
//
int info = 0;
s[0] = Complex.Conjugate(x[0]) / Complex.Conjugate(r[0 + 0 * ldr]);
for (j = 2; j <= p; j++)
{
s[j - 1] = Complex.Conjugate(x[j - 1]) - BLAS1Z.zdotc(j - 1, r, 1, s, 1, xIndex: +0 + (j - 1) * ldr);
s[j - 1] /= Complex.Conjugate(r[j - 1 + (j - 1) * ldr]);
}
double norm = BLAS1Z.dznrm2(p, s, 1);
switch (norm)
{
case >= 1.0:
info = -1;
return(info);
}
double alpha = Math.Sqrt(1.0 - norm * norm);
//
// Determine the transformations.
//
for (ii = 1; ii <= p; ii++)
{
i = p - ii + 1;
double scale = alpha + Complex.Abs(s[i - 1]);
double a = alpha / scale;
Complex b = s[i - 1] / scale;
norm = Math.Sqrt(a * a + b.Real * b.Real + b.Imaginary * b.Imaginary);
c[i - 1] = a / norm;
s[i - 1] = Complex.Conjugate(b) / norm;
alpha = scale * norm;
}
//
// Apply the transformations to R.
//
for (j = 1; j <= p; j++)
{
Complex xx = new(0.0, 0.0);
for (ii = 1; ii <= j; ii++)
{
i = j - ii + 1;
Complex t = c[i - 1] * xx + s[i - 1] * r[i - 1 + (j - 1) * ldr];
r[i - 1 + (j - 1) * ldr] = c[i - 1] * r[i - 1 + (j - 1) * ldr] - Complex.Conjugate(s[i - 1]) * xx;
xx = t;
}
}
//
// If required, downdate Z and RHO.
//
for (j = 1; j <= nz; j++)
{
Complex zeta = y[j - 1];
for (i = 1; i <= p; i++)
{
z[i - 1 + (j - 1) * ldz] = (z[i - 1 + (j - 1) * ldz]
- Complex.Conjugate(s[i - 1]) * zeta) / c[i - 1];
zeta = c[i - 1] * zeta - s[i - 1] * z[i - 1 + (j - 1) * ldz];
}
double azeta = Complex.Abs(zeta);
if (rho[j - 1] < azeta)
{
info = 1;
rho[j - 1] = -1.0;
}
else
{
rho[j - 1] *= Math.Sqrt(1.0 - azeta / rho[j - 1] * (azeta / rho[j - 1]));
}
}
return(info);
}
public static double zhpco(ref Complex[] ap, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZHPCO factors a complex hermitian packed matrix and estimates its condition.
//
// Discussion:
//
// If RCOND is not needed, ZHPFA is slightly faster.
//
// To solve A*X = B, follow ZHPCO by ZHPSL.
//
// To compute inverse(A)*C, follow ZHPCO by ZHPSL.
//
// To compute inverse(A), follow ZHPCO by ZHPDI.
//
// To compute determinant(A), follow ZHPCO by ZHPDI.
//
// To compute inertia(A), follow ZHPCO by ZHPDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex AP[N*(N+1)/2]; on input, the packed form of a
// hermitian matrix A. The columns of the upper triangle are stored
// sequentially in a one-dimensional array of length N*(N+1)/2. 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*hermitian(U) where U is a product of permutation and unit
// upper triangular matrices, hermitian(U) is the Complex.Conjugateugate 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 IPVT[N], the pivot indices.
//
// Output, double ZHPCO, an estimate of RCOND, the reciprocal condition of
// the matrix. 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.0
// is true, then A may be singular to working precision. In particular,
// RCOND is zero if exact singularity is detected or the estimate underflows.
//
// Local Parameters:
//
// Workspace, Complex 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).
//
{
Complex ak;
Complex akm1;
Complex bk;
Complex bkm1;
Complex 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;
Complex t;
Complex[] z = new Complex [n];
//
// Find norm of A using only upper half.
//
int j1 = 1;
for (j = 1; j <= n; j++)
{
z[j - 1] = new Complex(BLAS1Z.dzasum(j, ap, 1, index: +j1 - 1), 0.0);
int ij = j1;
j1 += j;
for (i = 1; i <= j - 1; i++)
{
z[i - 1] = new Complex(z[i - 1].Real + typeMethods.zabs1(ap[ij - 1]), 0.0);
ij += 1;
}
}
double anorm = 0.0;
for (j = 0; j < n; j++)
{
anorm = Math.Max(anorm, z[j].Real);
}
//
// Factor.
//
ZHPFA.zhpfa(ref ap, n, ref ipvt);
//
// 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.
//
Complex ek = new(1.0, 0.0);
for (i = 0; i < n; i++)
{
z[i] = new Complex(0.0, 0.0);
}
int k = n;
int ik = n * (n - 1) / 2;
while (0 < k)
{
kk = ik + k;
ikm1 = ik - (k - 1);
ks = ipvt[k - 1] switch
{
public static void zqrdc(ref Complex[] x, int ldx, int n, int p,
ref Complex[] qraux, ref int[] ipvt, int job)
//****************************************************************************80
//
// Purpose:
//
// ZQRDC computes the QR factorization of an N by P complex <double> matrix.
//
// Discussion:
//
// ZQRDC uses Householder transformations to compute the QR factorization
// of an N by P matrix X. Column pivoting based on the 2-norms of the
// reduced columns may be performed at the user's option.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, complex <double> X[LDX*P]; on input, the matrix whose decomposition
// is to be computed. On output, the upper triangle contains the upper
// triangular matrix R of the QR factorization. Below its diagonal, X
// contains information from which the unitary part of the decomposition
// can be recovered. If pivoting has been requested, the decomposition is
// not that of the original matrix X, but that of X with its columns
// permuted as described by IPVT.
//
// Input, int LDX, the leading dimension of X. N <= LDX.
//
// Input, int N, the number of rows of the matrix.
//
// Input, int P, the number of columns in the matrix X.
//
// Output, complex <double> QRAUX[P], further information required to recover
// the unitary part of the decomposition.
//
// Input/output, int IPVT[P]; on input, ints that control the
// selection of the pivot columns. The K-th column X(K) of X is placed
// in one of three classes according to the value of IPVT(K):
// IPVT(K) > 0, then X(K) is an initial column.
// IPVT(K) == 0, then X(K) is a free column.
// IPVT(K) < 0, then X(K) is a final column.
// Before the decomposition is computed, initial columns are moved to the
// beginning of the array X and final columns to the end. Both initial
// and final columns are frozen in place during the computation and only
// free columns are moved. At the K-th stage of the reduction, if X(K)
// is occupied by a free column it is interchanged with the free column
// of largest reduced norm.
// On output, IPVT(K) contains the index of the column of the
// original matrix that has been interchanged into
// the K-th column, if pivoting was requested.
// IPVT is not referenced if JOB == 0.
//
// Input, int JOB, initiates column pivoting.
// 0, no pivoting is done.
// nonzero, pivoting is done.
//
{
int itemp;
int j;
int l;
int pl = 1;
int pu = 0;
Complex[] work = new Complex [p];
if (job != 0)
{
//
// Pivoting has been requested. Rearrange the columns according to IPVT.
//
for (j = 1; j <= p; j++)
{
bool swapj = 0 < ipvt[j - 1];
bool negj = ipvt[j - 1] < 0;
ipvt[j - 1] = negj switch
{
true => - j,
_ => j
};
switch (swapj)
{
case true:
{
if (j != pl)
{
BLAS1Z.zswap(n, ref x, 1, ref x, 1, xIndex: +0 + (pl - 1) * ldx, yIndex: +0 + (j - 1) * ldx);
}
ipvt[j - 1] = ipvt[pl - 1];
ipvt[pl - 1] = j;
pl += 1;
break;
}
}
}
pu = p;
int jj;
for (jj = 1; jj <= p; jj++)
{
j = p - jj + 1;
switch (ipvt[j - 1])
{
case < 0:
{
ipvt[j - 1] = -ipvt[j - 1];
if (j != pu)
{
BLAS1Z.zswap(n, ref x, 1, ref x, 1, xIndex: +0 + (pu - 1) * ldx, yIndex: +0 + (j - 1) * ldx);
itemp = ipvt[pu - 1];
ipvt[pu - 1] = ipvt[j - 1];
ipvt[j - 1] = itemp;
}
pu -= 1;
break;
}
}
}
}
//
// Compute the norms of the free columns.
//
for (j = pl; j <= pu; j++)
{
qraux[j - 1] = new Complex(BLAS1Z.dznrm2(n, x, 1, index: +0 + (j - 1) * ldx), 0.0);
work[j - 1] = qraux[j - 1];
}
//
// Perform the Householder reduction of X.
//
int lup = Math.Min(n, p);
for (l = 1; l <= lup; l++)
{
//
// Locate the column of largest norm and bring it
// into the pivot position.
//
if (pl <= l && l < pu)
{
double maxnrm = 0.0;
int maxj = l;
for (j = l; j <= pu; j++)
{
if (!(maxnrm < qraux[j - 1].Real))
{
continue;
}
maxnrm = qraux[j - 1].Real;
maxj = j;
}
if (maxj != l)
{
BLAS1Z.zswap(n, ref x, 1, ref x, 1, xIndex: +0 + (l - 1) * ldx, yIndex: +0 + (maxj - 1) * ldx);
qraux[maxj - 1] = qraux[l - 1];
work[maxj - 1] = work[l - 1];
itemp = ipvt[maxj - 1];
ipvt[maxj - 1] = ipvt[l - 1];
ipvt[l - 1] = itemp;
}
}
qraux[l - 1] = new Complex(0.0, 0.0);
if (l == n)
{
continue;
}
//
// Compute the Householder transformation for column L.
//
Complex nrmxl = new(BLAS1Z.dznrm2(n - l + 1, x, 1, index: +l - 1 + (l - 1) * ldx), 0.0);
if (typeMethods.zabs1(nrmxl) == 0.0)
{
continue;
}
if (typeMethods.zabs1(x[l - 1 + (l - 1) * ldx]) != 0.0)
{
nrmxl = typeMethods.zsign2(nrmxl, x[l - 1 + (l - 1) * ldx]);
}
Complex t = new Complex(1.0, 0.0) / nrmxl;
BLAS1Z.zscal(n - l + 1, t, ref x, 1, index: +l - 1 + (l - 1) * ldx);
x[l - 1 + (l - 1) * ldx] = new Complex(1.0, 0.0) + x[l - 1 + (l - 1) * ldx];
//
// Apply the transformation to the remaining columns,
// updating the norms.
//
for (j = l + 1; j <= p; j++)
{
t = -BLAS1Z.zdotc(n - l + 1, x, 1, x, 1, xIndex: +l - 1 + (l - 1) * ldx, yIndex: +l - 1 + (j - 1) * ldx)
/ x[l - 1 + (l - 1) * ldx];
BLAS1Z.zaxpy(n - l + 1, t, x, 1, ref x, 1, xIndex: +l - 1 + (l - 1) * ldx, yIndex: +l - 1 + (j - 1) * ldx);
if (j < pl || pu < j)
{
continue;
}
if (typeMethods.zabs1(qraux[j - 1]) == 0.0)
{
continue;
}
double tt = 1.0 - Math.Pow(Complex.Abs(x[l - 1 + (j - 1) * ldx]) / qraux[j - 1].Real, 2);
tt = Math.Max(tt, 0.0);
t = new Complex(tt, 0.0);
tt = 1.0 + 0.05 * tt
* Math.Pow(qraux[j - 1].Real / work[j - 1].Real, 2);
if (Math.Abs(tt - 1.0) > double.Epsilon)
{
qraux[j - 1] *= Complex.Sqrt(t);
}
else
{
qraux[j - 1] =
new Complex(BLAS1Z.dznrm2(n - l, x, 1, index: +l + (j - 1) * ldx), 0.0);
work[j - 1] = qraux[j - 1];
}
}
//
// Save the transformation.
//
qraux[l - 1] = x[l - 1 + (l - 1) * ldx];
x[l - 1 + (l - 1) * ldx] = -nrmxl;
}
}
}
public static void zgbsl(Complex[] abd, int lda, int n, int ml, int mu,
int[] ipvt, ref Complex[] b, int job)
//****************************************************************************80
//
// Purpose:
//
// ZGBSL solves a complex band system factored by ZGBCO or ZGBFA.
//
// Discussion:
//
// ZGBSL can solve A * X = B or hermitan ( A ) * X = B.
//
// A division by zero will occur if the input factor contains a
// zero on the diagonal. Technically this indicates singularity
// but it is often caused by improper arguments or improper
// setting of LDA. It will not occur if the subroutines are
// called correctly and if ZGBCO has set 0.0 < RCOND
// or ZGBFA has set INFO = 0.
//
// To compute inverse ( A ) * C where C is a matrix with P columns:
//
// call zgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
//
// if ( rcond is not too small ) then
// do j = 1, p
// call zgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
// end do
// end if
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex ABD[LDA*N], the output from ZGBCO or ZGBFA.
//
// Input, int LDA, the leading dimension of ABD.
//
// Input, int N, the order of the matrix.
//
// Input, int ML, the number of diagonals below the main diagonal.
//
// Input, int MU, the number of diagonals above the main diagonal.
//
// Input, int IPVT[N], the pivot vector from ZGBCO or ZGBFA.
//
// Input/output, Complex B[N]. On input, the right hand side.
// On output, the solution.
//
// Input, int JOB.
// 0, to solve A*x = b,
// nonzero, to solve hermitian(A)*x = b, where hermitian(A) is the
// conjugate transpose.
//
{
int k;
int l;
int la;
int lb;
int lm;
Complex t;
int m = mu + ml + 1;
switch (job)
{
//
// JOB = 0, solve A * X = B.
//
case 0:
{
//
// First solve L * Y = B.
//
if (ml != 0)
{
for (k = 1; k <= n - 1; k++)
{
lm = Math.Min(ml, n - k);
l = ipvt[k - 1];
t = b[l - 1];
if (l != k)
{
b[l - 1] = b[k - 1];
b[k - 1] = t;
}
BLAS1Z.zaxpy(lm, t, abd, 1, ref b, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
}
}
//
// Now solve U * X = Y.
//
for (k = n; 1 <= k; k--)
{
b[k - 1] /= abd[m - 1 + (k - 1) * lda];
lm = Math.Min(k, m) - 1;
la = m - lm;
lb = k - lm;
t = -b[k - 1];
BLAS1Z.zaxpy(lm, t, abd, 1, ref b, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
}
break;
}
//
default:
{
//
// First solve hermitian ( U ) * Y = B.
//
for (k = 1; k <= n; k++)
{
lm = Math.Min(k, m) - 1;
la = m - lm;
lb = k - lm;
t = BLAS1Z.zdotc(lm, abd, 1, b, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1);
b[k - 1] = (b[k - 1] - t) / Complex.Conjugate(abd[m - 1 + (k - 1) * lda]);
}
//
// Now solve hermitian ( L ) * X = Y.
//
if (ml != 0)
{
for (k = n - 1; 1 <= k; k--)
{
lm = Math.Min(ml, n - k);
b[k - 1] += BLAS1Z.zdotc(lm, abd, 1, b, 1, xIndex: +m + (k - 1) * lda, yIndex: +k);
l = ipvt[k - 1];
if (l == k)
{
continue;
}
t = b[l - 1];
b[l - 1] = b[k - 1];
b[k - 1] = t;
}
}
break;
}
}
}
public static int zspfa(ref Complex[] ap, int n, ref int[] ipvt)
//****************************************************************************80
//
// Purpose:
//
// ZSPFA factors a complex symmetric matrix stored in packed form.
//
// Discussion:
//
// The factorization is done by elimination with symmetric pivoting.
//
// To solve A*X = B, follow ZSPFA by ZSPSL.
//
// To compute inverse(A)*C, follow ZSPFA by ZSPSL.
//
// To compute determinant(A), follow ZSPFA by ZSPDI.
//
// To compute inverse(A), follow ZSPFA by ZSPDI.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex 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 IPVT[N], the pivot indices.
//
// Output, int ZSPFA.
// 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 ZSPSL or ZSPDI may
// divide by zero if called.
//
{
int im = 0;
//
// Initialize.
//
// 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)
{
ipvt[0] = 1;
if (typeMethods.zabs1(ap[0]) == 0.0)
{
info = 1;
}
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 = typeMethods.zabs1(ap[kk - 1]);
//
// Determine the largest off-diagonal element in column K.
//
int imax = BLAS1Z.izamax(k - 1, ap, 1, index: +ik);
int imk = ik + imax;
double colmax = typeMethods.zabs1(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;
im = imax * (imax - 1) / 2;
imj = im + 2 * imax;
for (j = imax + 1; j <= k; j++)
{
rowmax = Math.Max(rowmax, typeMethods.zabs1(ap[imj - 1]));
imj += j;
}
if (imax != 1)
{
int jmax = BLAS1Z.izamax(imax - 1, ap, 1, index: +im);
int jmim = jmax + im;
rowmax = Math.Max(rowmax, typeMethods.zabs1(ap[jmim - 1]));
}
int imim = imax + im;
if (alpha * rowmax <= typeMethods.zabs1(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:
{
ipvt[k - 1] = k;
info = k;
ik -= k - 1;
switch (kstep)
{
case 2:
ik -= k - 2;
break;
}
k -= kstep;
continue;
}
}
Complex mulk;
Complex t;
int jk;
int jj;
int ij;
if (kstep != 2)
{
switch (swap)
{
//
// 1 x 1 pivot block.
//
case true:
{
BLAS1Z.zswap(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;
BLAS1Z.zaxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij);
ap[jk - 1] = mulk;
ij -= j - 1;
}
ipvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => imax,
_ => k
};
}
//
// 2 x 2 pivot block.
//
else
{
int km1k = ik + k - 1;
int ikm1 = ik - (k - 1);
int jkm1;
switch (swap)
{
case true:
{
BLAS1Z.zswap(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.
//
int km2 = k - 2;
if (km2 != 0)
{
Complex ak = ap[kk - 1] / ap[km1k - 1];
int km1km1 = ikm1 + k - 1;
Complex akm1 = ap[km1km1 - 1] / ap[km1k - 1];
Complex denom = new Complex(1.0, 0.0) - ak * akm1;
ij = ik - (k - 1) - (k - 2);
for (jj = 1; jj <= km2; jj++)
{
j = km1 - jj;
jk = ik + j;
Complex bk = ap[jk - 1] / ap[km1k - 1];
jkm1 = ikm1 + j;
Complex bkm1 = ap[jkm1 - 1] / ap[km1k - 1];
mulk = (akm1 * bk - bkm1) / denom;
Complex mulkm1 = (ak * bkm1 - bk) / denom;
t = mulk;
BLAS1Z.zaxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij);
t = mulkm1;
BLAS1Z.zaxpy(j, t, ap, 1, ref ap, 1, xIndex: +ikm1, yIndex: +ij);
ap[jk - 1] = mulk;
ap[jkm1 - 1] = mulkm1;
ij -= j - 1;
}
}
ipvt[k - 1] = swap switch
{
//
// Set the pivot array.
//
true => - imax,
_ => 1 - k
};
ipvt[k - 2] = ipvt[k - 1];
}
ik -= k - 1;
switch (kstep)
{
case 2:
ik -= k - 2;
break;
}
k -= kstep;
}
return(info);
}
}
public static void zspdi(ref Complex[] ap, int n, int[] ipvt, ref Complex[] det,
int job)
//****************************************************************************80
//
// Purpose:
//
// ZSPDI sets the determinant and inverse of a complex symmetric packed matrix.
//
// Discussion:
//
// ZSPDI uses the factors from ZSPFA.
//
// The matrix is stored in packed form.
//
// A division by zero will occur if the inverse is requested and ZSPCO has
// set RCOND to 0.0 or ZSPFA has set INFO nonzero.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input/output, Complex AP[N*(N+1)/2]; on input, the matrix factors
// from ZSPFA. On output, if the inverse was requested, the upper
// triangle of the inverse of the original matrix, stored in packed
// form. The columns of the upper triangle are stored sequentially
// in a one-dimensional array.
//
// Input, int N, the order of the matrix.
//
// Input, int IPVT[N], the pivot vector from ZSPFA.
//
// Output, Complex DET[2], the determinant of the original matrix.
// Determinant = DET(1) * 10.0**DET(2) with 1.0 <= abs ( DET(1) ) < 10.0
// or DET(1) = 0.0. Also, DET(2) is strictly real.
//
// Input, int JOB, has the decimal expansion AB where
// if B != 0, the inverse is computed,
// if A != 0, the determinant is computed,
// For example, JOB = 11 gives both.
//
{
Complex d;
int ik;
int ikp1;
int k;
int kk;
int kkp1 = 0;
Complex t;
bool noinv = job % 10 == 0;
bool nodet = job % 100 / 10 == 0;
switch (nodet)
{
case false:
{
det[0] = new Complex(1.0, 0.0);
det[1] = new Complex(0.0, 0.0);
t = new Complex(0.0, 0.0);
ik = 0;
for (k = 1; k <= n; k++)
{
kk = ik + k;
d = ap[kk - 1];
switch (ipvt[k - 1])
{
//
// 2 by 2 block
// Use det (D T) = ( D / T * C - T ) * T
// (T C)
// to avoid underflow/overflow troubles.
// Take two passes through scaling. Use T for flag.
//
case <= 0 when typeMethods.zabs1(t) == 0.0:
ikp1 = ik + k;
kkp1 = ikp1 + k;
t = ap[kkp1 - 1];
d = d / t * ap[kkp1] - t;
break;
case <= 0:
d = t;
t = new Complex(0.0, 0.0);
break;
}
switch (nodet)
{
case false:
{
det[0] *= d;
if (typeMethods.zabs1(det[0]) != 0.0)
{
while (typeMethods.zabs1(det[0]) < 1.0)
{
det[0] *= new Complex(10.0, 0.0);
det[1] -= new Complex(1.0, 0.0);
}
while (10.0 <= typeMethods.zabs1(det[0]))
{
det[0] /= new Complex(10.0, 0.0);
det[1] += new Complex(1.0, 0.0);
}
}
break;
}
}
ik += k;
}
break;
}
}
switch (noinv)
{
//
// Compute inverse ( A ).
//
case false:
{
Complex[] work = new Complex[n];
k = 1;
ik = 0;
while (k <= n)
{
int km1 = k - 1;
kk = ik + k;
ikp1 = ik + k;
int j;
int jk;
int i;
int ij;
int kstep;
switch (ipvt[k - 1])
{
case >= 0:
{
//
// 1 by 1
//
ap[kk - 1] = new Complex(1.0, 0.0) / ap[kk - 1];
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = ap[ik + i - 1];
}
ij = 0;
for (j = 1; j <= km1; j++)
{
jk = ik + j;
ap[jk - 1] = BLAS1Z.zdotu(j, ap, 1, work, 1, xIndex: +ij);
BLAS1Z.zaxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik);
ij += j;
}
ap[kk - 1] += BLAS1Z.zdotu(km1, work, 1, ap, 1, yIndex: +ik);
break;
}
}
kstep = 1;
break;
}
//
default:
{
kkp1 = ikp1 + k;
t = ap[kkp1 - 1];
Complex ak = ap[kk - 1] / t;
Complex akp1 = ap[kkp1] / t;
Complex akkp1 = ap[kkp1 - 1] / t;
d = t * (ak * akp1 - new Complex(1.0, 0.0));
ap[kk - 1] = akp1 / d;
ap[kkp1] = ak / d;
ap[kkp1 - 1] = -akkp1 / d;
switch (km1)
{
case >= 1:
{
for (i = 1; i <= km1; i++)
{
work[i - 1] = ap[ikp1 - 1];
}
ij = 0;
for (j = 1; j <= km1; j++)
{
int jkp1 = ikp1 + j;
ap[jkp1 - 1] = BLAS1Z.zdotu(j, ap, 1, work, 1, xIndex: +ij);
BLAS1Z.zaxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ikp1);
ij += j;
}
ap[kkp1] += BLAS1Z.zdotu(km1, work, 1, ap, 1, yIndex: +ikp1);
ap[kkp1 - 1] += BLAS1Z.zdotu(km1, ap, 1, ap, 1, xIndex: +ik, yIndex: +ikp1);
for (i = 1; i <= km1; i++)
{
work[i - 1] = ap[ik + i - 1];
}
ij = 0;
for (j = 1; j <= km1; j++)
{
jk = ik + j;
ap[jk - 1] = BLAS1Z.zdotu(j, ap, 1, work, 1, xIndex: +ij);
BLAS1Z.zaxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik);
ij += j;
}
ap[kk - 1] += BLAS1Z.zdotu(km1, work, 1, ap, 1, yIndex: +ik);
break;
}
}
kstep = 2;
break;
}
}
//
// Swap.
//
int ks = Math.Abs(ipvt[k - 1]);
if (ks != k)
{
int iks = ks * (ks - 1) / 2;
BLAS1Z.zswap(ks, ref ap, 1, ref ap, 1, xIndex: +iks, yIndex: +ik);
int ksj = ik + ks;
int jb;
for (jb = ks; jb <= k; jb++)
{
j = k + ks - jb;
jk = ik + j;
t = ap[jk - 1];
ap[jk - 1] = ap[ksj - 1];
ap[ksj - 1] = t;
ksj -= j - 1;
}
if (kstep != 1)
{
int kskp1 = ikp1 + ks;
t = ap[kskp1 - 1];
ap[kskp1 - 1] = ap[kkp1 - 1];
ap[kkp1 - 1] = t;
}
}
ik += k;
ik = kstep switch
{
2 => ik + k + 1,
_ => ik
};
k += kstep;
}
break;
}
}
}
}
public static int ztrsl(Complex[] t, int ldt, int n, ref Complex[] b,
int job)
//****************************************************************************80
//
// Purpose:
//
// ZTRSL solves triangular systems T*X=B or Hermitian(T)*X=B.
//
// Discussion:
//
// Hermitian ( T ) denotes the Complex.Conjugateugate transpose of the matrix T.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 21 May 2006
//
// Author:
//
// 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.
//
// Parameters:
//
// Input, Complex T[LDT*N], the matrix of the system. 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 T.
//
// Input, int N, the order of the matrix.
//
// Input/output, Complex B[N]. On input, the right hand side.
// On output, the solution.
//
// Input, int JOB, specifies what kind of system is to be solved.
// 00, solve T*X=B, T lower triangular,
// 01, solve T*X=B, T upper triangular,
// 10, solve hermitian(T)*X=B, T lower triangular,
// 11, solve hermitian(T)*X=B, T upper triangular.
//
// Output, int ZTRSL.
// 0, the system is nonsingular.
// K, the index of the first zero diagonal element of T.
//
{
int i;
int info;
int j;
int jj;
Complex temp;
//
// Check for zero diagonal elements.
//
for (i = 0; i < n; i++)
{
if (typeMethods.zabs1(t[i + i * ldt]) != 0.0)
{
continue;
}
info = i + 1;
return(info);
}
info = 0;
//
// Determine the task and go to it.
//
int kase = 1;
if (job % 10 != 0)
{
kase = 2;
}
if (job % 100 / 10 != 0)
{
kase += 2;
}
switch (kase)
{
//
// Solve T * X = B for T lower triangular.
//
case 1:
{
b[0] /= t[0 + 0 * ldt];
for (j = 2; j <= n; j++)
{
temp = -b[j - 2];
BLAS1Z.zaxpy(n - j + 1, temp, t, 1, ref b, 1, xIndex: +j - 1 + (j - 2) * ldt, yIndex: +j - 1);
b[j - 1] /= t[j - 1 + (j - 1) * ldt];
}
break;
}
//
// Solve T * X = B for T upper triangular.
//
case 2:
{
b[n - 1] /= t[n - 1 + (n - 1) * ldt];
for (jj = 2; jj <= n; jj++)
{
j = n - jj + 1;
temp = -b[j];
BLAS1Z.zaxpy(j, temp, t, 1, ref b, 1, xIndex: +0 + j * ldt);
b[j - 1] /= t[j - 1 + (j - 1) * ldt];
}
break;
}
//
// Solve hermitian(T) * X = B for T lower triangular.
//
case 3:
{
b[n - 1] /= Complex.Conjugate(t[n - 1 + (n - 1) * ldt]);
for (jj = 2; jj <= n; jj++)
{
j = n - jj + 1;
b[j - 1] -= BLAS1Z.zdotc(jj - 1, t, 1, b, 1, xIndex: +j + (j - 1) * ldt, yIndex: +j);
b[j - 1] /= Complex.Conjugate(t[j - 1 + (j - 1) * ldt]);
}
break;
}
//
// Solve hermitian(T) * X = B for T upper triangular.
//
case 4:
{
b[0] /= Complex.Conjugate(t[0 + 0 * ldt]);
for (j = 2; j <= n; j++)
{
b[j - 1] -= BLAS1Z.zdotc(j - 1, t, 1, b, 1, xIndex: +0 + (j - 1) * ldt);
b[j - 1] /= Complex.Conjugate(t[j - 1 + (j - 1) * ldt]);
}
break;
}
}
return(info);
}
