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 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 zhisl(Complex[] a, int lda, int n, int[] ipvt, ref Complex[] b) //***************************************************************************** // // Purpose: // // ZHISL solves a complex hermitian system factored by ZHIFA. // // Discussion: // // A division by zero may occur if ZHICO has set RCOND == 0.0 // or ZHIFA has set INFO != 0. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 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 ZHIFA. // // 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. // // 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); } // // Apply D inverse. // 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); } // // Apply D inverse. // Complex ak = a[k - 1 + (k - 1) * lda] / Complex.Conjugate(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] / Complex.Conjugate(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]) { // // 1 x 1 pivot block. // case >= 0: { if (k != 1) { b[k - 1] += BLAS1Z.zdotc(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: { // // 2 x 2 pivot block. // if (k != 1) { b[k - 1] += BLAS1Z.zdotc(k - 1, a, 1, b, 1, xIndex: +0 + (k - 1) * lda); b[k] += BLAS1Z.zdotc(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 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 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 void zhpdi(ref Complex[] ap, int n, int[] ipvt, ref double[] det, ref int[] inert, int job) //****************************************************************************80 // // Purpose: // // ZHPDI: determinant, inertia and inverse of a complex hermitian matrix. // // Discussion: // // The routine uses the factors from ZHPFA. // // The matrix is stored in packed form. // // A division by zero will occur if the inverse is requested and ZHPCO has // set RCOND == 0.0 or ZHPFA 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 AP[N*(N+1)/2]; on input, the factored matrix // from ZHPFA. If the inverse was requested, then on output, AP contains // 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 ZHPFA. // // Output, double DET[2], if requested, 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. // // Output, int INERT[3], if requested, 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 ik; int ikp1; int k; int kk; int kkp1; 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: inert[0] = 0; inert[1] = 0; inert[2] = 0; break; } switch (nodet) { case false: det[0] = 1.0; det[1] = 0.0; break; } t = 0.0; ik = 0; for (k = 1; k <= n; k++) { kk = ik + k; d = ap[kk - 1].Real; switch (ipvt[k - 1]) { // // Check if 1 by 1 // // // 2 by 2 block // Use DET (D S; S C) = ( D / T * C - T ) * T, T = abs ( S ) // to avoid underflow/overflow troubles. // Take two passes through scaling. Use T for flag. // case <= 0 when t == 0.0: ikp1 = ik + k; kkp1 = ikp1 + k; t = Complex.Abs(ap[kkp1 - 1]); d = d / t * ap[kkp1].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; } } ik += k; } } 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; kkp1 = ikp1 + k; int kstep; int jk; int j; int ij; switch (ipvt[k - 1]) { // // 1 by 1 // case >= 0: { ap[kk - 1] = new Complex(1.0 / ap[kk - 1].Real, 0.0); switch (km1) { case >= 1: { for (j = 1; j <= km1; j++) { work[j - 1] = ap[ik + j - 1]; } ij = 0; for (j = 1; j <= km1; j++) { jk = ik + j; ap[jk - 1] = BLAS1Z.zdotc(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] += new Complex (BLAS1Z.zdotc(km1, work, 1, ap, 1, yIndex: +ik).Real, 0.0); break; } } kstep = 1; break; } // default: { t = Complex.Abs(ap[kkp1 - 1]); double ak = ap[kk - 1].Real / t; double akp1 = ap[kkp1].Real / t; Complex akkp1 = ap[kkp1 - 1] / t; d = t * (ak * akp1 - 1.0); ap[kk - 1] = new Complex(akp1 / d, 0.0); ap[kkp1] = new Complex(ak / d, 0.0); ap[kkp1 - 1] = -akkp1 / d; switch (km1) { case >= 1: { for (j = 1; j <= km1; j++) { work[j - 1] = ap[ikp1 + j - 1]; } ij = 0; for (j = 1; j <= km1; j++) { int jkp1 = ikp1 + j; ap[jkp1 - 1] = BLAS1Z.zdotc(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] += new Complex (BLAS1Z.zdotc(km1, work, 1, ap, 1, xIndex: +ikp1).Real, 0.0); ap[kkp1 - 1] += BLAS1Z.zdotc(km1, ap, 1, ap, 1, xIndex: +ik, yIndex: +ikp1); for (j = 1; j <= km1; j++) { work[j - 1] = ap[ik + j - 1]; } ij = 0; for (j = 1; j <= km1; j++) { jk = ik + j; ap[jk - 1] = BLAS1Z.zdotc(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] += new Complex (BLAS1Z.zdotc(km1, work, 1, ap, 1, yIndex: +ik).Real, 0.0); 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; Complex t2; int jb; for (jb = ks; jb <= k; jb++) { j = k + ks - jb; jk = ik + j; t2 = Complex.Conjugate(ap[jk - 1]); ap[jk - 1] = Complex.Conjugate(ap[ksj - 1]); ap[ksj - 1] = t2; ksj -= j - 1; } if (kstep != 1) { int kskp1 = ikp1 + ks; t2 = ap[kskp1 - 1]; ap[kskp1 - 1] = ap[kkp1 - 1]; ap[kkp1 - 1] = t2; } } ik += k; ik = kstep switch { 2 => ik + k + 1, _ => ik }; k += kstep; } break; } } } }
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 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 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 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 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 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 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); }
public static void zppsl(Complex[] ap, int n, ref Complex[] b) //****************************************************************************80 // // Purpose: // // ZPPSL solves a complex hermitian positive definite linear system. // // 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. 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. // // To compute inverse(A) * C where C is a matrix with P columns: // // call zppco(ap,n,rcond,z,info) // // if (rcond is too small .or. info /= 0) then // error // end if // // do j = 1, p // call zppsl(ap,n,c(1,j)) // 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, Complex AP[N*(N+1)/2], the output from ZPPCO or ZPPFA. // // Input, int N, the order of the matrix. // // Input/output, Complex B[N]. On input, the right hand side. // On output, the solution. // { int k; Complex t; int kk = 0; for (k = 1; k <= n; k++) { t = BLAS1Z.zdotc(k - 1, ap, 1, b, 1, xIndex: +kk); kk += k; b[k - 1] = (b[k - 1] - t) / ap[kk - 1]; } for (k = n; 1 <= k; k--) { b[k - 1] /= ap[kk - 1]; kk -= k; t = -b[k - 1]; BLAS1Z.zaxpy(k - 1, t, ap, 1, ref b, 1, xIndex: +kk); } }
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 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 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 zhpsl(Complex[] ap, int n, int[] ipvt, ref Complex[] b) //****************************************************************************80 // // Purpose: // // ZHPSL solves a complex hermitian system factored by ZHPFA. // // Discussion: // // A division by zero may occur if ZHPCO set RCOND to 0.0 // or ZHPFA set INFO nonzero. // // To compute // // inverse ( A ) * C // // where C is a matrix with P columns // // call zhpfa(ap,n,ipvt,info) // // if ( info == 0 ) // do j = 1, p // call zhpsl(ap,n,ipvt,c(1,j)) // 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, Complex AP[N*(N+1)/2], the output from ZHPFA. // // Input, int N, the order of the matrix. // // Input, int IPVT[N], the pivot vector from ZHPFA. // // 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 inverse ( D ) to B. // int k = n; int ik = n * (n - 1) / 2; while (0 < k) { int kk = ik + 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], ap, 1, ref b, 1, xIndex: +ik); } // // Apply D inverse. // b[k - 1] /= ap[kk - 1]; k -= 1; ik -= k; break; } default: { // // 2 x 2 pivot block. // int ikm1 = ik - (k - 1); 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], ap, 1, ref b, 1, xIndex: +ik); BLAS1Z.zaxpy(k - 2, b[k - 2], ap, 1, ref b, 1, xIndex: +ikm1); } // // Apply D inverse. // int km1k = ik + k - 1; kk = ik + k; Complex ak = ap[kk - 1] / Complex.Conjugate(ap[km1k - 1]); int km1km1 = ikm1 + k - 1; Complex akm1 = ap[km1km1 - 1] / ap[km1k - 1]; Complex bk = b[k - 1] / Complex.Conjugate(ap[km1k - 1]); Complex bkm1 = b[k - 2] / ap[km1k - 1]; 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; ik = ik - (k + 1) - k; break; } } } // // Loop forward applying the transformations. // k = 1; ik = 0; while (k <= n) { switch (ipvt[k - 1]) { // // 1 x 1 pivot block. // case >= 0: { if (k != 1) { b[k - 1] += BLAS1Z.zdotc(k - 1, ap, 1, b, 1, xIndex: +ik); kp = ipvt[k - 1]; if (kp != k) { t = b[k - 1]; b[k - 1] = b[kp - 1]; b[kp - 1] = t; } } ik += k; k += 1; break; } // default: { if (k != 1) { b[k - 1] += BLAS1Z.zdotc(k - 1, ap, 1, b, 1, xIndex: +ik); int ikp1 = ik + k; b[k] += BLAS1Z.zdotc(k - 1, ap, 1, b, 1, xIndex: +ikp1); kp = Math.Abs(ipvt[k - 1]); if (kp != k) { t = b[k - 1]; b[k - 1] = b[kp - 1]; b[kp - 1] = t; } } ik = ik + k + k + 1; k += 2; break; } } } }