private static void drotg_test() //****************************************************************************80 // // Purpose: // // DROTG_TEST tests DROTG. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { double c = 0; double s = 0; int test_num = 5; Console.WriteLine(""); Console.WriteLine("DROTG_TEST"); Console.WriteLine(" DROTG generates a real Givens rotation"); Console.WriteLine(" ( C S ) * ( A ) = ( R )"); Console.WriteLine(" ( -S C ) ( B ) ( 0 )"); Console.WriteLine(""); int seed = 123456789; for (int test = 1; test <= test_num; test++) { double a = UniformRNG.r8_uniform_01(ref seed); double b = UniformRNG.r8_uniform_01(ref seed); double sa = a; double sb = b; BLAS1D.drotg(ref sa, ref sb, ref c, ref s); double r = sa; double z = sb; Console.WriteLine(""); Console.WriteLine(" A = " + a + " B = " + b + ""); Console.WriteLine(" C = " + c + " S = " + s + ""); Console.WriteLine(" R = " + r + " Z = " + z + ""); Console.WriteLine(" C*A+S*B = " + (c * a + s * b) + ""); Console.WriteLine(" -S*A+C*B = " + (-s * a + c * b) + ""); } }
private static void idamax_test() //****************************************************************************80 // // Purpose: // // IDAMAX_TEST demonstrates IDAMAX. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 February 2006 // // Author: // // John Burkardt // { int N = 11; double[] x = new double[N]; Console.WriteLine(""); Console.WriteLine("IDAMAX_TEST"); Console.WriteLine(" IDAMAX returns the index of maximum magnitude;"); for (int i = 1; i <= N; i++) { x[i - 1] = 7 * i % 11 - (double)(N / 2); } Console.WriteLine(""); Console.WriteLine(" The vector X:"); Console.WriteLine(""); for (int i = 1; i <= N; i++) { Console.WriteLine(" " + i.ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i - 1].ToString(CultureInfo.InvariantCulture).PadLeft(8) + ""); } int incx = 1; int i1 = BLAS1D.idamax(N, x, incx); Console.WriteLine(""); Console.WriteLine(" The index of maximum magnitude = " + i1 + ""); }
public static void dchex(ref double[] r, int ldr, int p, int k, int l, ref double[] z, int ldz, int nz, ref double[] c, ref double[] s, int job) //****************************************************************************80 // // Purpose: // // DCHEX updates the Cholesky factorization of a positive definite matrix. // // Discussion: // // The factorization has the form // // A = R' * R // // where A is a positive definite matrix of order P. // // The updating involves diagonal permutations of the form // // E' * A * E // // where E is a permutation matrix. Specifically, given // an upper triangular matrix R and a permutation matrix // E (which is specified by K, L, and JOB), DCHEX determines // an orthogonal matrix U such that // // U * R * E = RR, // // where RR is upper triangular. At the user's option, the // transformation U will be multiplied into the array Z. // If A = X'*X, so that R is the triangular part of the // QR factorization of X, then RR is the triangular part of the // QR factorization of X*E, that is, X with its columns permuted. // // For a less terse description of what DCHEX does and how // it may be applied, see the LINPACK guide. // // The matrix Q is determined as the product U(L-K)*...*U(1) // of plane rotations of the form // // ( C(I) S(I) ) // ( ), // ( -S(I) C(I) ) // // where C(I) is real, the rows these rotations operate on // are described below. // // There are two types of permutations, which are determined // by the value of JOB. // // 1, right circular shift. The columns are rearranged in the order: // // 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. // // U is the product of L-K rotations U(I), where U(I) // acts in the (L-I,L-I+1)-plane. // // 2, left circular shift: the columns are rearranged in the order // // 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. // // U is the product of L-K rotations U(I), where U(I) // acts in the (K+I-1,K+I)-plane. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 June 2009 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double R[LDR*P]. On input, the upper // triangular factor that is to be updated. Elements of R below the // diagonal are not referenced. On output, R has been updated. // // Input, int LDR, the leading dimension of the array R. // LDR must be at least P. // // Input, int P, the order of the matrix R. // // Input, int K, the first column to be permuted. // // Input, int L, the last column to be permuted. // L must be strictly greater than K. // // Input/output double Z[LDZ*NZ], an array of NZ P-vectors into // which the transformation U is multiplied. Z is not referenced if NZ = 0. // On output, Z has been updated. // // Input, int LDZ, the leading dimension of the array Z. // LDZ must be at least P. // // Input, int NZ, the number of columns of the matrix Z. // // Output, double C[P], S[P], the cosines and sines of the // transforming rotations. // // Input, int JOB, determines the type of permutation. // 1, right circular shift. // 2, left circular shift. // { int i; int ii; int j; int jj; double t; // // Initialize // int lmk = l - k; int lm1 = l - 1; switch (job) { // // Right circular shift. // case 1: { // // Reorder the columns. // for (i = 1; i <= l; i++) { ii = l - i + 1; s[i - 1] = r[ii - 1 + (l - 1) * ldr]; } for (jj = k; jj <= lm1; jj++) { j = lm1 - jj + k; for (i = 1; i <= j; i++) { r[i - 1 + j * ldr] = r[i - 1 + (j - 1) * ldr]; } r[j + j * ldr] = 0.0; } for (i = 1; i <= k - 1; i++) { ii = l - i + 1; r[i - 1 + (k - 1) * ldr] = s[ii - 1]; } // // Calculate the rotations. // t = s[0]; for (i = 1; i <= lmk; i++) { BLAS1D.drotg(ref s[i], ref t, ref c[i - 1], ref s[i - 1]); t = s[i]; } r[k - 1 + (k - 1) * ldr] = t; for (j = k + 1; j <= p; j++) { int il = Math.Max(1, l - j + 1); for (ii = il; ii <= lmk; ii++) { i = l - ii; t = c[ii - 1] * r[i - 1 + (j - 1) * ldr] + s[ii - 1] * r[i + (j - 1) * ldr]; r[i + (j - 1) * ldr] = c[ii - 1] * r[i + (j - 1) * ldr] - s[ii - 1] * r[i - 1 + (j - 1) * ldr]; r[i - 1 + (j - 1) * ldr] = t; } } // // If required, apply the transformations to Z. // for (j = 1; j <= nz; j++) { for (ii = 1; ii <= lmk; ii++) { i = l - ii; t = c[ii - 1] * z[i - 1 + (j - 1) * ldr] + s[ii - 1] * z[i + (j - 1) * ldr]; z[i + (j - 1) * ldr] = c[ii - 1] * z[i + (j - 1) * ldr] - s[ii - 1] * z[i - 1 + (j - 1) * ldr]; z[i - 1 + (j - 1) * ldr] = t; } } break; } // default: { // // Reorder the columns. // for (i = 1; i <= k; i++) { ii = lmk + i; s[ii - 1] = r[i - 1 + (k - 1) * ldr]; } for (j = k; j <= lm1; j++) { for (i = 1; i <= j; i++) { r[i - 1 + (j - 1) * ldr] = r[i - 1 + j * ldr]; } jj = j - k + 1; s[jj - 1] = r[j + j * ldr]; } for (i = 1; i <= k; i++) { ii = lmk + i; r[i - 1 + (l - 1) * ldr] = s[ii - 1]; } for (i = k + 1; i <= l; i++) { r[i - 1 + (l - 1) * ldr] = 0.0; } // // Reduction loop. // for (j = k; j <= p; j++) { // // Apply the rotations. // if (j != k) { int iu = Math.Min(j - 1, l - 1); for (i = k; i <= iu; i++) { ii = i - k + 1; t = c[ii - 1] * r[i - 1 + (j - 1) * ldr] + s[ii - 1] * r[i + (j - 1) * ldr]; r[i + (j - 1) * ldr] = c[ii - 1] * r[i + (j - 1) * ldr] - s[ii - 1] * r[i - 1 + (j - 1) * ldr]; r[i - 1 + (j - 1) * ldr] = t; } } if (j >= l) { continue; } jj = j - k + 1; t = s[jj - 1]; BLAS1D.drotg(ref r[j - 1 + (j - 1) * ldr], ref t, ref c[jj - 1], ref s[jj - 1]); } // // Apply the rotations to Z. // for (j = 1; j <= nz; j++) { for (i = k; i <= lm1; i++) { ii = i - k + 1; t = c[ii - 1] * z[i - 1 + (j - 1) * ldr] + s[ii - 1] * z[i + (j - 1) * ldr]; z[i + (j - 1) * ldr] = c[ii - 1] * z[i + (j - 1) * ldr] - s[ii - 1] * z[i - 1 + (j - 1) * ldr]; z[i - 1 + (j - 1) * ldr] = t; } } break; } } }
public static double dppco(ref double[] ap, int n, ref double[] z) //****************************************************************************80 // // Purpose: // // DPPCO factors a real symmetric positive definite matrix in packed form. // // Discussion: // // DPPCO also estimates the condition of the matrix. // // If RCOND is not needed, DPPFA is slightly faster. // // To solve A*X = B, follow DPPCO by DPPSL. // // To compute inverse(A)*C, follow DPPCO by DPPSL. // // To compute determinant(A), follow DPPCO by DPPDI. // // To compute inverse(A), follow DPPCO by DPPDI. // // Packed storage: // // The following program segment will pack the upper triangle of // a symmetric matrix. // // k = 0 // do j = 1, n // do i = 1, j // k = k + 1 // ap[k-1] = a(i,j) // } // } // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 07 June 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double AP[N*(N+1)/2]. On input, the packed // form of a symmetric matrix A. The columns of the upper triangle are // stored sequentially in a one-dimensional array. On output, an upper // triangular matrix R, stored in packed form, so that A = R'*R. // If INFO /= 0, the factorization is not complete. // // Input, int N, the order of the matrix. // // Output, double Z[N], a work vector whose contents are usually // unimportant. If A is singular to working precision, then Z is an // approximate null vector in the sense that // norm(A*Z) = RCOND * norm(A) * norm(Z). // If INFO /= 0, Z is unchanged. // // Output, double DPPCO, an estimate of the reciprocal condition number RCOND // of A. For the system A*X = B, relative perturbations in A and B of size // EPSILON may cause relative perturbations in X of size EPSILON/RCOND. // If RCOND is so small that the logical expression // 1.0 + RCOND == 1.0D+00 // is true, then A may be singular to working precision. In particular, // RCOND is zero if exact singularity is detected or the estimate underflows. // { int i; int j; int k; double rcond; double s; double t; // // Find the norm of A. // int j1 = 1; for (j = 1; j <= n; j++) { z[j - 1] = BLAS1D.dasum(j, ap, 1, index: +j1 - 1); int ij = j1; j1 += j; for (i = 1; i <= j - 1; i++) { z[i - 1] += Math.Abs(ap[ij - 1]); ij += 1; } } double anorm = 0.0; for (i = 1; i <= n; i++) { anorm = Math.Max(anorm, z[i - 1]); } // // Factor. // int info = DPPFA.dppfa(ref ap, n); if (info != 0) { rcond = 0.0; return(rcond); } // // RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))). // // Estimate = norm(Z)/norm(Y) where A * Z = Y and A * Y = E. // // The components of E are chosen to cause maximum local // growth in the elements of W where R'*W = E. // // The vectors are frequently rescaled to avoid overflow. // // Solve R' * W = E. // double ek = 1.0; for (i = 1; i <= n; i++) { z[i - 1] = 0.0; } int kk = 0; for (k = 1; k <= n; k++) { kk += k; if (z[k - 1] != 0.0) { ek *= typeMethods.r8_sign(-z[k - 1]); } if (ap[kk - 1] < Math.Abs(ek - z[k - 1])) { s = ap[kk - 1] / Math.Abs(ek - z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ek = s * ek; } double wk = ek - z[k - 1]; double wkm = -ek - z[k - 1]; s = Math.Abs(wk); double sm = Math.Abs(wkm); wk /= ap[kk - 1]; wkm /= ap[kk - 1]; int kj = kk + k; if (k + 1 <= n) { for (j = k + 1; j <= n; j++) { sm += Math.Abs(z[j - 1] + wkm * ap[kj - 1]); z[j - 1] += wk * ap[kj - 1]; s += Math.Abs(z[j - 1]); kj += j; } if (s < sm) { t = wkm - wk; wk = wkm; kj = kk + k; for (j = k + 1; j <= n; j++) { z[j - 1] += t * ap[kj - 1]; kj += j; } } } z[k - 1] = wk; } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } // // Solve R * Y = W. // for (k = n; 1 <= k; k--) { if (ap[kk - 1] < Math.Abs(z[k - 1])) { s = ap[kk - 1] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } } z[k - 1] /= ap[kk - 1]; kk -= k; t = -z[k - 1]; BLAS1D.daxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk); } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } double ynorm = 1.0; // // Solve R' * V = Y. // for (k = 1; k <= n; k++) { z[k - 1] -= BLAS1D.ddot(k - 1, ap, 1, z, 1, xIndex: +kk); kk += k; if (ap[kk - 1] < Math.Abs(z[k - 1])) { s = ap[kk - 1] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } z[k - 1] /= ap[kk - 1]; } s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; // // Solve R * Z = V. // for (k = n; 1 <= k; k--) { if (ap[kk - 1] < Math.Abs(z[k - 1])) { s = ap[kk - 1] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } z[k - 1] /= ap[kk - 1]; kk -= k; t = -z[k - 1]; BLAS1D.daxpy(k - 1, t, ap, 1, ref z, 1, xIndex: +kk); } // // Make ZNORM = 1.0. // s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; if (anorm != 0.0) { rcond = ynorm / anorm; } else { rcond = 0.0; } return(rcond); }
public static double dpoco(ref double[] a, int lda, int n, ref double[] z) //****************************************************************************80 // // Purpose: // // DPOCO factors a real symmetric positive definite matrix and estimates its condition. // // Discussion: // // If RCOND is not needed, DPOFA is slightly faster. // // To solve A*X = B, follow DPOCO by DPOSL. // // To compute inverse(A)*C, follow DPOCO by DPOSL. // // To compute determinant(A), follow DPOCO by DPODI. // // To compute inverse(A), follow DPOCO by DPODI. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 06 June 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double A[LDA*N]. On input, the symmetric // matrix to be factored. Only the diagonal and upper triangle are used. // On output, an upper triangular matrix R so that A = R'*R where R' // is the transpose. The strict lower triangle is unaltered. // If INFO /= 0, the factorization is not complete. // // Input, int LDA, the leading dimension of the array A. // // Input, int N, the order of the matrix. // // Output, double Z[N], a work vector whose contents are usually // unimportant. If A is close to a singular matrix, then Z is an // approximate null vector in the sense that // norm(A*Z) = RCOND * norm(A) * norm(Z). // If INFO /= 0, Z is unchanged. // // Output, double DPOCO, an estimate of the reciprocal // condition of A. For the system A*X = B, relative perturbations in // A and B of size EPSILON may cause relative perturbations in X of // size EPSILON/RCOND. If RCOND is so small that the logical expression // 1.0D+00 + RCOND == 1.0D+00 // is true, then A may be singular to working precision. In particular, // RCOND is zero if exact singularity is detected or the estimate underflows. // { int i; int j; int k; double rcond; double s; double t; // // Find norm of A using only upper half. // for (j = 1; j <= n; j++) { z[j - 1] = BLAS1D.dasum(j, a, 1, index: +0 + (j - 1) * lda); for (i = 1; i <= j - 1; i++) { z[i - 1] += Math.Abs(a[i - 1 + (j - 1) * lda]); } } double anorm = 0.0; for (i = 1; i <= n; i++) { anorm = Math.Max(anorm, z[i - 1]); } // // Factor. // int info = DPOFA.dpofa(ref a, lda, n); if (info != 0) { rcond = 0.0; return(rcond); } // // RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))). // // Estimate = norm(Z)/norm(Y) where A*Z = Y and A*Y = E. // // The components of E are chosen to cause maximum local // growth in the elements of W where R'*W = E. // // The vectors are frequently rescaled to avoid overflow. // // Solve R' * W = E. // double ek = 1.0; for (i = 1; i <= n; i++) { z[i - 1] = 0.0; } for (k = 1; k <= n; k++) { if (z[k - 1] != 0.0) { ek *= typeMethods.r8_sign(-z[k - 1]); } if (a[k - 1 + (k - 1) * lda] < Math.Abs(ek - z[k - 1])) { s = a[k - 1 + (k - 1) * lda] / Math.Abs(ek - z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ek = s * ek; } double wk = ek - z[k - 1]; double wkm = -ek - z[k - 1]; s = Math.Abs(wk); double sm = Math.Abs(wkm); wk /= a[k - 1 + (k - 1) * lda]; wkm /= a[k - 1 + (k - 1) * lda]; if (k + 1 <= n) { for (j = k + 1; j <= n; j++) { sm += Math.Abs(z[j - 1] + wkm * a[k - 1 + (j - 1) * lda]); z[j - 1] += wk * a[k - 1 + (j - 1) * lda]; s += Math.Abs(z[j - 1]); } if (s < sm) { t = wkm - wk; wk = wkm; for (j = k + 1; j <= n; j++) { z[j - 1] += t * a[k - 1 + (j - 1) * lda]; } } } z[k - 1] = wk; } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } // // Solve R * Y = W. // for (k = n; 1 <= k; k--) { if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1])) { s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } } z[k - 1] /= a[k - 1 + (k - 1) * lda]; t = -z[k - 1]; BLAS1D.daxpy(k - 1, t, a, 1, ref z, 1, xIndex: +0 + (k - 1) * lda); } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } double ynorm = 1.0; // // Solve R' * V = Y. // for (k = 1; k <= n; k++) { z[k - 1] -= BLAS1D.ddot(k - 1, a, 1, z, 1, xIndex: +0 + (k - 1) * lda); if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1])) { s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } z[k - 1] /= a[k - 1 + (k - 1) * lda]; } s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; // // Solve R * Z = V. // for (k = n; 1 <= k; k--) { if (a[k - 1 + (k - 1) * lda] < Math.Abs(z[k - 1])) { s = a[k - 1 + (k - 1) * lda] / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } z[k - 1] /= a[k - 1 + (k - 1) * lda]; t = -z[k - 1]; BLAS1D.daxpy(k - 1, t, a, 1, ref z, 1, xIndex: +0 + (k - 1) * lda); } // // Make ZNORM = 1.0. // s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; if (anorm != 0.0) { rcond = ynorm / anorm; } else { rcond = 0.0; } return(rcond); }
public static double dgbco(ref double[] abd, int lda, int n, int ml, int mu, ref int[] ipvt, double[] z) //****************************************************************************80 // // Purpose: // // DGBCO factors a real band matrix and estimates its condition. // // Discussion: // // If RCOND is not needed, DGBFA is slightly faster. // // To solve A*X = B, follow DGBCO by DGBSL. // // To compute inverse(A)*C, follow DGBCO by DGBSL. // // To compute determinant(A), follow DGBCO by DGBDI. // // Example: // // If the original matrix is // // 11 12 13 0 0 0 // 21 22 23 24 0 0 // 0 32 33 34 35 0 // 0 0 43 44 45 46 // 0 0 0 54 55 56 // 0 0 0 0 65 66 // // then for proper band storage, // // N = 6, ML = 1, MU = 2, 5 <= LDA and ABD should contain // // * * * + + + * = not used // * * 13 24 35 46 + = used for pivoting // * 12 23 34 45 56 // 11 22 33 44 55 66 // 21 32 43 54 65 * // // Band storage: // // If A is a band matrix, the following program segment // will set up the input. // // ml = (band width below the diagonal) // mu = (band width above the diagonal) // m = ml + mu + 1 // // do j = 1, n // i1 = max ( 1, j-mu ) // i2 = min ( n, j+ml ) // do i = i1, i2 // k = i - j + m // abd(k,j) = a(i,j) // } // } // // This uses rows ML+1 through 2*ML+MU+1 of ABD. In addition, the first // ML rows in ABD are used for elements generated during the // triangularization. The total number of rows needed in ABD is // 2*ML+MU+1. The ML+MU by ML+MU upper left triangle and the ML by ML // lower right triangle are not referenced. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 07 June 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double ABD[LDA*N]. On input, the matrix in band // storage. The columns of the matrix are stored in the columns of ABD and // the diagonals of the matrix are stored in rows ML+1 through 2*ML+MU+1 // of ABD. On output, an upper triangular matrix in band storage and // the multipliers which were used to obtain it. The factorization can // be written A = L*U where L is a product of permutation and unit lower // triangular matrices and U is upper triangular. // // Input, int LDA, the leading dimension of the array ABD. // 2*ML + MU + 1 <= LDA is required. // // Input, int N, the order of the matrix. // // Input, int ML, MU, the number of diagonals below and above the // main diagonal. 0 <= ML < N, 0 <= MU < N. // // Output, int IPVT[N], the pivot indices. // // Workspace, double Z[N], a work vector whose contents are // usually unimportant. If A is close to a singular matrix, then Z is an // approximate null vector in the sense that // norm(A*Z) = RCOND * norm(A) * norm(Z). // // Output, double DGBCO, an estimate of the reciprocal condition number RCOND // of A. For the system A*X = B, relative perturbations in A and B of size // EPSILON may cause relative perturbations in X of size EPSILON/RCOND. // If RCOND is so small that the logical expression // 1.0 + RCOND == 1.0D+00 // is true, then A may be singular to working precision. In particular, // RCOND is zero if exact singularity is detected or the estimate underflows. // { int i; int j; int k; int lm; double rcond; double s; double t; // // Compute the 1-norm of A. // double anorm = 0.0; int l = ml + 1; int is_ = l + mu; for (j = 1; j <= n; j++) { anorm = Math.Max(anorm, BLAS1D.dasum(l, abd, 1, index: +is_ - 1 + (j - 1) * lda)); if (ml + 1 < is_) { is_ -= 1; } if (j <= mu) { l += 1; } if (n - ml <= j) { l -= 1; } } // // Factor. // DGBFA.dgbfa(ref abd, lda, n, ml, mu, ref ipvt); // // RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))). // // Estimate = norm(Z)/norm(Y) where a*z = y and A'*Y = E. // // A' is the transpose of A. The components of E are // chosen to cause maximum local growth in the elements of W where // U'*W = E. The vectors are frequently rescaled to avoid // overflow. // // Solve U' * W = E. // double ek = 1.0; for (i = 1; i <= n; i++) { z[i - 1] = 0.0; } int m = ml + mu + 1; int ju = 0; for (k = 1; k <= n; k++) { if (z[k - 1] != 0.0) { ek *= typeMethods.r8_sign(-z[k - 1]); } if (Math.Abs(abd[m - 1 + (k - 1) * lda]) < Math.Abs(ek - z[k - 1])) { s = Math.Abs(abd[m - 1 + (k - 1) * lda]) / Math.Abs(ek - z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ek = s * ek; } double wk = ek - z[k - 1]; double wkm = -ek - z[k - 1]; s = Math.Abs(wk); double sm = Math.Abs(wkm); if (abd[m - 1 + (k - 1) * lda] != 0.0) { wk /= abd[m - 1 + (k - 1) * lda]; wkm /= abd[m - 1 + (k - 1) * lda]; } else { wk = 1.0; wkm = 1.0; } ju = Math.Min(Math.Max(ju, mu + ipvt[k - 1]), n); int mm = m; if (k + 1 <= ju) { for (j = k + 1; j <= ju; j++) { mm -= 1; sm += Math.Abs(z[j - 1] + wkm * abd[mm - 1 + (j - 1) * lda]); z[j - 1] += wk * abd[mm - 1 + (j - 1) * lda]; s += Math.Abs(z[j - 1]); } if (s < sm) { t = wkm - wk; wk = wkm; mm = m; for (j = k + 1; j <= ju; ju++) { mm -= 1; z[j - 1] += t * abd[mm - 1 + (j - 1) * lda]; } } } z[k - 1] = wk; } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } // // Solve L' * Y = W. // for (k = n; 1 <= k; k--) { lm = Math.Min(ml, n - k); if (k < m) { z[k - 1] += BLAS1D.ddot(lm, abd, 1, z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k); } switch (Math.Abs(z[k - 1])) { case > 1.0: { s = 1.0 / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } break; } } l = ipvt[k - 1]; t = z[l - 1]; z[l - 1] = z[k - 1]; z[k - 1] = t; } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } double ynorm = 1.0; // // Solve L * V = Y. // for (k = 1; k <= n; k++) { l = ipvt[k - 1]; t = z[l - 1]; z[l - 1] = z[k - 1]; z[k - 1] = t; lm = Math.Min(ml, n - k); if (k < n) { BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +m + (k - 1) * lda, yIndex: +k); } switch (Math.Abs(z[k - 1])) { case > 1.0: { s = 1.0 / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; break; } } } s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; // // Solve U * Z = W. // for (k = n; 1 <= k; k--) { if (Math.Abs(abd[m - 1 + (k - 1) * lda]) < Math.Abs(z[k - 1])) { s = Math.Abs(abd[m - 1 + (k - 1) * lda]) / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } if (abd[m - 1 + (k - 1) * lda] != 0.0) { z[k - 1] /= abd[m - 1 + (k - 1) * lda]; } else { z[k - 1] = 1.0; } lm = Math.Min(k, m) - 1; int la = m - lm; int lz = k - lm; t = -z[k - 1]; BLAS1D.daxpy(lm, t, abd, 1, ref z, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lz - 1); } // // Make ZNORM = 1.0. // s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; if (anorm != 0.0) { rcond = ynorm / anorm; } else { rcond = 0.0; } return(rcond); }
public static int dgefa(ref double[] a, int lda, int n, ref int[] ipvt) //****************************************************************************80 // // Purpose: // // DGEFA factors a real general matrix. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 16 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double A[LDA*N]. // On intput, 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 A. // // Output, int IPVT[N], the pivot indices. // // Output, int DGEFA, singularity indicator. // 0, normal value. // K, if U(K,K) == 0. This is not an error condition for this subroutine, // but it does indicate that DGESL or DGEDI will divide by zero if called. // Use RCOND in DGECO 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 = BLAS1D.idamax(n - k + 1, a, 1, index: +(k - 1) + (k - 1) * lda) + k - 1; ipvt[k - 1] = l; switch (a[l - 1 + (k - 1) * lda]) { // // Zero pivot implies this column already triangularized. // case 0.0: info = k; continue; } // // Interchange if necessary. // double 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 = -1.0 / a[k - 1 + (k - 1) * lda]; BLAS1D.dscal(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; } BLAS1D.daxpy(n - k, t, a, 1, ref a, 1, xIndex: +k + (k - 1) * lda, yIndex: +k + (j - 1) * lda); } } ipvt[n - 1] = n; info = a[n - 1 + (n - 1) * lda] switch { 0.0 => n, _ => info }; return(info); } }
public static int r8po_fa(ref double[] a, int lda, int n) //****************************************************************************80 // // Purpose: // // R8PO_FA factors a real symmetric positive definite matrix. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 May 2005 // // Author: // // FORTRAN77 original version by Dongarra, Moler, Bunch, Stewart. // C++ version by John Burkardt. // // Reference: // // Dongarra, Moler, Bunch and Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double A[LDA*N]. On input, the symmetric matrix // to be factored. Only the diagonal and upper triangle are used. // On output, an upper triangular matrix R so that A = R'*R // where R' is the transpose. The strict lower triangle is unaltered. // If INFO /= 0, the factorization is not complete. // // Input, int LDA, the leading dimension of the array A. // // Input, int N, the order of the matrix. // // Output, int R8PO_FA, error flag. // 0, for normal return. // K, signals an error condition. The leading minor of order K is not // positive definite. // { int info; int j; for (j = 1; j <= n; j++) { double s = 0.0; int k; for (k = 1; k <= j - 1; k++) { double t = a[k - 1 + (j - 1) * lda] - BLAS1D.ddot(k - 1, a, 1, a, 1, +0 + (k - 1) * lda, +0 + (j - 1) * lda); t /= a[k - 1 + (k - 1) * lda]; a[k - 1 + (j - 1) * lda] = t; s += t * t; } s = a[j - 1 + (j - 1) * lda] - s; switch (s) { case <= 0.0: info = j; return(info); default: a[j - 1 + (j - 1) * lda] = Math.Sqrt(s); break; } } info = 0; return(info); }
public static void dposl(double[] a, int lda, int n, ref double[] b) //****************************************************************************80 // // Purpose: // // DPOSL solves a linear system factored by DPOCO or DPOFA. // // Discussion: // // To compute inverse(A) * C where C is a matrix with P columns: // // call dpoco ( a, lda, n, rcond, z, info ) // // if ( rcond is not too small .and. info == 0 ) then // do j = 1, p // call dposl ( a, lda, n, c(1,j) ) // end do // end if // // 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: // // 23 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input, double A[LDA*N], the output from DPOCO or DPOFA. // // Input, int LDA, the leading dimension of the array A. // // Input, int N, the order of the matrix. // // Input/output, double B[N]. On input, the right hand side. // On output, the solution. // { int k; double t; // // Solve R' * Y = B. // for (k = 1; k <= n; k++) { t = BLAS1D.ddot(k - 1, a, 1, b, 1, xIndex: +0 + (k - 1) * lda); b[k - 1] = (b[k - 1] - t) / a[k - 1 + (k - 1) * lda]; } // // Solve R * X = Y. // for (k = n; 1 <= k; k--) { b[k - 1] /= a[k - 1 + (k - 1) * lda]; t = -b[k - 1]; BLAS1D.daxpy(k - 1, t, a, 1, ref b, 1, xIndex: +0 + (k - 1) * lda); } }
private static void dasum_test() //****************************************************************************80 // // Purpose: // // DASUM_TEST tests DASUM. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { int LDA = 6; int MA = 5; int NA = 4; int NX = 10; double[] a = new double[LDA * NA]; double[] x = new double[NX]; for (int i = 0; i < NX; i++) { x[i] = Math.Pow(-1.0, i + 1) * (2 * (i + 1)); } Console.WriteLine(""); Console.WriteLine("DASUM_TEST"); Console.WriteLine(" DASUM adds the absolute values of elements of a vector."); Console.WriteLine(""); Console.WriteLine(" X = "); Console.WriteLine(""); for (int i = 0; i < NX; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } Console.WriteLine(""); Console.WriteLine(" DASUM ( NX, X, 1 ) = " + BLAS1D.dasum(NX, x, 1) + ""); Console.WriteLine(" DASUM ( NX/2, X, 2 ) = " + BLAS1D.dasum(NX / 2, x, 2) + ""); Console.WriteLine(" DASUM ( 2, X, NX/2 ) = " + BLAS1D.dasum(2, x, NX / 2) + ""); for (int i = 0; i < MA; i++) { for (int j = 0; j < NA; j++) { a[i + j * LDA] = Math.Pow(-1.0, i + 1 + j + 1) * (10 * (i + 1) + j + 1); } } Console.WriteLine(""); Console.WriteLine(" Demonstrate with a matrix A:"); Console.WriteLine(""); for (int i = 0; i < MA; i++) { string cout = ""; for (int j = 0; j < NA; j++) { cout += " " + a[i + j * LDA].ToString(CultureInfo.InvariantCulture).PadLeft(14); } Console.WriteLine(cout); } Console.WriteLine(""); Console.WriteLine(" DASUM(MA,A(1,2),1) = " + BLAS1D.dasum(MA, a, 1, 0 + 1 * LDA) + ""); Console.WriteLine(" DASUM(NA,A(2,1),LDA) = " + BLAS1D.dasum(NA, a, LDA, 1) + ""); }
private static void drot_test() //****************************************************************************80 // // Purpose: // // DROT_TEST tests DROT. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { const int N = 6; double[] x = new double[N]; double[] y = new double[N]; for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = (i + 1) * (i + 1) - 12; } Console.WriteLine(""); Console.WriteLine("DROT_TEST"); Console.WriteLine(" DROT carries out a Givens rotation."); Console.WriteLine(""); Console.WriteLine(" X and Y"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } double c = 0.5; double s = Math.Sqrt(1.0 - c * c); BLAS1D.drot(N, ref x, 1, ref y, 1, c, s); Console.WriteLine(""); Console.WriteLine(" DROT ( N, X, 1, Y, 1, " + c + "," + s + " )"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = (i + 1) * (i + 1) - 12; } c = x[0] / Math.Sqrt(x[0] * x[0] + y[0] * y[0]); s = y[0] / Math.Sqrt(x[0] * x[0] + y[0] * y[0]); BLAS1D.drot(N, ref x, 1, ref y, 1, c, s); Console.WriteLine(""); Console.WriteLine(" DROT ( N, X, 1, Y, 1, " + c + "," + s + " )"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } }
private static void ddot_test() //****************************************************************************80 // // Purpose: // // DDOT_TEST demonstrates DDOT. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { const int N = 5; const int LDA = 10; const int LDB = 7; const int LDC = 6; double[] a = new double[LDA * LDA]; double[] b = new double[LDB * LDB]; double[] c = new double[LDC * LDC]; double[] x = new double[N]; double[] y = new double[N]; Console.WriteLine(""); Console.WriteLine("DDOT_TEST"); Console.WriteLine(" DDOT computes the dot product of vectors."); Console.WriteLine(""); for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = -(double)(i + 1); } for (int i = 0; i < N; i++) { for (int j = 0; j < N; j++) { a[i + j * LDA] = i + 1 + j + 1; } } for (int i = 0; i < N; i++) { for (int j = 0; j < N; j++) { b[i + j * LDB] = i + 1 - (j + 1); } } double sum1 = BLAS1D.ddot(N, x, 1, y, 1); Console.WriteLine(""); Console.WriteLine(" Dot product of X and Y is " + sum1 + ""); // // To multiply a ROW of a matrix A times a vector X, we need to // specify the increment between successive entries of the row of A: // sum1 = BLAS1D.ddot(N, a, LDA, x, 1, 1); Console.WriteLine(""); Console.WriteLine(" Product of row 2 of A and X is " + sum1 + ""); // // Product of a column of A and a vector is simpler: // sum1 = BLAS1D.ddot(N, a, 1, x, 1, +0 + 1 * LDA); Console.WriteLine(""); Console.WriteLine(" Product of column 2 of A and X is " + sum1 + ""); // // Here's how matrix multiplication, c = a*b, could be done // with DDOT: // for (int i = 0; i < N; i++) { for (int j = 0; j < N; j++) { c[i + j * LDC] = BLAS1D.ddot(N, a, LDA, b, 1, +i, +0 + j * LDB); } } Console.WriteLine(""); Console.WriteLine(" Matrix product computed with DDOT:"); Console.WriteLine(""); for (int i = 0; i < N; i++) { string cout = ""; for (int j = 0; j < N; j++) { cout += " " + c[i + j * LDC].ToString(CultureInfo.InvariantCulture).PadLeft(14); } Console.WriteLine(cout); } }
private static void dnrm2_test() //****************************************************************************80 // // Purpose: // // DNRM2_TEST demonstrates DNRM2. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { int N = 5; int LDA = 10; // // These parameters illustrate the fact that matrices are typically // dimensioned with more space than the user requires. // double[] a = new double[LDA * LDA]; double[] x = new double[N]; Console.WriteLine(""); Console.WriteLine("DNRM2_TEST"); Console.WriteLine(" DNRM2 computes the Euclidean norm of a vector."); Console.WriteLine(""); // // Compute the euclidean norm of a vector: // for (int i = 0; i < N; i++) { x[i] = i + 1; } Console.WriteLine(""); Console.WriteLine(" X ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } Console.WriteLine(""); Console.WriteLine(" The 2-norm of X is " + BLAS1D.dnrm2(N, x, 1) + ""); // // Compute the euclidean norm of a row or column of a matrix: // for (int i = 0; i < N; i++) { for (int j = 0; j < N; j++) { a[i + j * LDA] = i + 1 + j + 1; } } Console.WriteLine(""); Console.WriteLine(" The 2-norm of row 2 of A is " + BLAS1D.dnrm2(N, a, LDA, +1) + ""); Console.WriteLine(""); Console.WriteLine(" The 2-norm of column 2 of A is " + BLAS1D.dnrm2(N, a, 1, +0 + 1 * LDA) + ""); }
private static void dcopy_test() //****************************************************************************80 // // Purpose: // // DCOPY_TEST demonstrates DCOPY. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { double[] a = new double[5 * 5]; double[] x = new double[10]; double[] y = new double[10]; Console.WriteLine(""); Console.WriteLine("DCOPY_TEST"); Console.WriteLine(" DCOPY copies one vector into another."); Console.WriteLine(""); for (int i = 0; i < 10; i++) { x[i] = i + 1; } for (int i = 0; i < 10; i++) { y[i] = 10 * (i + 1); } for (int i = 0; i < 5; i++) { for (int j = 0; j < 5; j++) { a[i + j * 5] = 10 * (i + 1) + j + 1; } } Console.WriteLine(""); Console.WriteLine(" X ="); Console.WriteLine(""); for (int i = 0; i < 10; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < 10; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } Console.WriteLine(""); Console.WriteLine(" A ="); Console.WriteLine(""); for (int i = 0; i < 5; i++) { string cout = ""; for (int j = 0; j < 5; j++) { cout += " " + a[i + j * 5].ToString(CultureInfo.InvariantCulture).PadLeft(14); } Console.WriteLine(cout); } BLAS1D.dcopy(5, x, 1, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DCOPY ( 5, X, 1, Y, 1 )"); Console.WriteLine(""); for (int i = 0; i < 10; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < 10; i++) { y[i] = 10 * (i + 1); } BLAS1D.dcopy(3, x, 2, ref y, 3); Console.WriteLine(""); Console.WriteLine(" DCOPY ( 3, X, 2, Y, 3 )"); Console.WriteLine(""); for (int i = 0; i < 10; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } BLAS1D.dcopy(5, x, 1, ref a, 1); Console.WriteLine(""); Console.WriteLine(" DCOPY ( 5, X, 1, A, 1 )"); Console.WriteLine(""); Console.WriteLine(" A ="); Console.WriteLine(""); for (int i = 0; i < 5; i++) { string cout = ""; for (int j = 0; j < 5; j++) { cout += " " + a[i + j * 5].ToString(CultureInfo.InvariantCulture).PadLeft(14); } Console.WriteLine(cout); } for (int i = 0; i < 5; i++) { for (int j = 0; j < 5; j++) { a[i + j * 5] = 10 * (i + 1) + j + 1; } } BLAS1D.dcopy(5, x, 2, ref a, 5); Console.WriteLine(""); Console.WriteLine(" DCOPY ( 5, X, 2, A, 5 )"); Console.WriteLine(""); Console.WriteLine(" A ="); Console.WriteLine(""); for (int i = 0; i < 5; i++) { string cout = ""; for (int j = 0; j < 5; j++) { cout += " " + a[i + j * 5].ToString(CultureInfo.InvariantCulture).PadLeft(14); } Console.WriteLine(cout); } }
private static void daxpy_test() //****************************************************************************80 // // Purpose: // // DAXPY_TEST tests DAXPY. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { const int N = 6; double[] x = new double[N]; double[] y = new double[N]; for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } Console.WriteLine(""); Console.WriteLine("DAXPY_TEST"); Console.WriteLine(" DAXPY adds a multiple of vector X to vector Y."); Console.WriteLine(""); Console.WriteLine(" X ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } double da = 1.0; BLAS1D.daxpy(N, da, x, 1, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DAXPY ( N, " + da + ", X, 1, Y, 1 )"); Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } da = -2.0; BLAS1D.daxpy(N, da, x, 1, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DAXPY ( N, " + da + ", X, 1, Y, 1 )"); Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } da = 3.0; BLAS1D.daxpy(3, da, x, 2, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DAXPY ( 3, " + da + ", X, 2, Y, 1 )"); Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } da = -4.0; BLAS1D.daxpy(3, da, x, 1, ref y, 2); Console.WriteLine(""); Console.WriteLine(" DAXPY ( 3, " + da + ", X, 1, Y, 2 )"); Console.WriteLine(""); Console.WriteLine(" Y ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } }
public static int dppfa(ref double[] ap, int n) //****************************************************************************80 // // Purpose: // // DPPFA factors a real symmetric positive definite matrix in packed form. // // Discussion: // // DPPFA is usually called by DPPCO, but it can be called // directly with a saving in time if RCOND is not needed. // // Packed storage: // // The following program segment will pack the upper // triangle of a symmetric matrix. // // k = 0 // do j = 1, n // do i = 1, j // k = k + 1 // ap(k) = a(i,j) // end do // end do // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 24 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double AP[N*(N+1)/2]. On input, the packed // form of a symmetric matrix A. The columns of the upper triangle are // stored sequentially in a one-dimensional array. On output, an upper // triangular matrix R, stored in packed form, so that A = R'*R. // // Input, int N, the order of the matrix. // // Output, int DPPFA, error flag. // 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; double t = ap[kj - 1] - BLAS1D.ddot(k - 1, ap, 1, ap, 1, xIndex: +kk, yIndex: +jj); kk += k; t /= ap[kk - 1]; ap[kj - 1] = t; s += t * t; } jj += j; s = ap[jj - 1] - s; switch (s) { case <= 0.0: info = j; return(info); default: ap[jj - 1] = Math.Sqrt(s); break; } } return(info); }
public static double dgeco(ref double[] a, int lda, int n, ref int[] ipvt, ref double[] z) //****************************************************************************80 // // Purpose: // // DGECO factors a real matrix and estimates its condition number. // // Discussion: // // If RCOND is not needed, DGEFA is slightly faster. // // To solve A * X = B, follow DGECO by DGESL. // // To compute inverse ( A ) * C, follow DGECO by DGESL. // // To compute determinant ( A ), follow DGECO by DGEDI. // // To compute inverse ( A ), follow DGECO by DGEDI. // // For the system A * X = B, relative perturbations in A and B // of size EPSILON may cause relative perturbations in X of size // EPSILON/RCOND. // // If RCOND is so small that the logical expression // 1.0D+00 + RCOND == 1.0D+00 // is true, then A may be singular to working precision. In particular, // RCOND is zero if exact singularity is detected or the estimate // underflows. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 25 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double A[LDA*N]. On input, a matrix to be // factored. On output, the LU factorization of the matrix. // // Input, int LDA, the leading dimension of the array A. // // Input, int N, the order of the matrix A. // // Output, int IPVT[N], the pivot indices. // // Output, double Z[N], a work vector whose contents are usually // unimportant. If A is close to a singular matrix, then Z is an // approximate null vector in the sense that // norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ). // // Output, double DGECO, the value of RCOND, an estimate // of the reciprocal condition number of A. // { int i; int j; int k; int l; double rcond; double s; double t; // // Compute the L1 norm of A. // double anorm = 0.0; for (j = 1; j <= n; j++) { anorm = Math.Max(anorm, BLAS1D.dasum(n, a, 1, index: +0 + (j - 1) * lda)); } // // Compute the LU factorization. // DGEFA.dgefa(ref a, lda, n, ref ipvt); // // RCOND = 1 / ( norm(A) * (estimate of norm(inverse(A))) ) // // estimate of norm(inverse(A)) = norm(Z) / norm(Y) // // where // A * Z = Y // and // A' * Y = E // // The components of E are chosen to cause maximum local growth in the // elements of W, where U'*W = E. The vectors are frequently rescaled // to avoid overflow. // // Solve U' * W = E. // double ek = 1.0; for (i = 1; i <= n; i++) { z[i - 1] = 0.0; } for (k = 1; k <= n; k++) { if (z[k - 1] != 0.0) { ek *= typeMethods.r8_sign(-z[k - 1]); } if (Math.Abs(a[k - 1 + (k - 1) * lda]) < Math.Abs(ek - z[k - 1])) { s = Math.Abs(a[k - 1 + (k - 1) * lda]) / Math.Abs(ek - z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ek = s * ek; } double wk = ek - z[k - 1]; double wkm = -ek - z[k - 1]; s = Math.Abs(wk); double sm = Math.Abs(wkm); if (a[k - 1 + (k - 1) * lda] != 0.0) { wk /= a[k - 1 + (k - 1) * lda]; wkm /= a[k - 1 + (k - 1) * lda]; } else { wk = 1.0; wkm = 1.0; } if (k + 1 <= n) { for (j = k + 1; j <= n; j++) { sm += Math.Abs(z[j - 1] + wkm * a[k - 1 + (j - 1) * lda]); z[j - 1] += wk * a[k - 1 + (j - 1) * lda]; s += Math.Abs(z[j - 1]); } if (s < sm) { t = wkm - wk; wk = wkm; for (i = k + 1; i <= n; i++) { z[i - 1] += t * a[k - 1 + (i - 1) * lda]; } } } z[k - 1] = wk; } t = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= t; } // // Solve L' * Y = W // for (k = n; 1 <= k; k--) { z[k - 1] += BLAS1D.ddot(n - k, a, 1, z, 1, xIndex: +k + (k - 1) * lda, yIndex: +k); switch (Math.Abs(z[k - 1])) { case > 1.0: { t = Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] /= t; } break; } } l = ipvt[k - 1]; t = z[l - 1]; z[l - 1] = z[k - 1]; z[k - 1] = t; } t = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= t; } double ynorm = 1.0; // // Solve L * V = Y. // for (k = 1; k <= n; k++) { l = ipvt[k - 1]; t = z[l - 1]; z[l - 1] = z[k - 1]; z[k - 1] = t; for (i = k + 1; i <= n; i++) { z[i - 1] += t * a[i - 1 + (k - 1) * lda]; } switch (Math.Abs(z[k - 1])) { case > 1.0: { ynorm /= Math.Abs(z[k - 1]); t = Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] /= t; } break; } } } s = BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] /= s; } ynorm /= s; // // Solve U * Z = V. // for (k = n; 1 <= k; k--) { if (Math.Abs(a[k - 1 + (k - 1) * lda]) < Math.Abs(z[k - 1])) { s = Math.Abs(a[k - 1 + (k - 1) * lda]) / Math.Abs(z[k - 1]); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; } if (a[k - 1 + (k - 1) * lda] != 0.0) { z[k - 1] /= a[k - 1 + (k - 1) * lda]; } else { z[k - 1] = 1.0; } for (i = 1; i <= k - 1; i++) { z[i - 1] -= z[k - 1] * a[i - 1 + (k - 1) * lda]; } } // // Normalize Z in the L1 norm. // s = 1.0 / BLAS1D.dasum(n, z, 1); for (i = 1; i <= n; i++) { z[i - 1] = s * z[i - 1]; } ynorm = s * ynorm; if (anorm != 0.0) { rcond = ynorm / anorm; } else { rcond = 0.0; } return(rcond); }
public static void dspdi(ref double[] ap, int n, int[] kpvt, ref double[] det, ref int[] inert, double[] work, int job) //****************************************************************************80 // // Purpose: // // DSPDI computes the determinant, inertia and inverse of a real symmetric matrix. // // Discussion: // // DSPDI uses the factors from DSPFA, where the matrix is stored in // packed form. // // A division by zero will occur if the inverse is requested // and DSPCO has set RCOND == 0.0D+00 or DSPFA has set INFO /= 0. // // Variables not requested by JOB are not used. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 25 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double AP[(N*(N+1))/2]. On input, the output from // DSPFA. On output, the upper triangle of the inverse of the original // matrix, stored in packed form, if requested. The columns of the upper // triangle are stored sequentially in a one-dimensional array. // // Input, int N, the order of the matrix. // // Input, int KPVT[N], the pivot vector from DSPFA. // // Output, double DET[2], the determinant of the original matrix, // if requested. // determinant = DET[0] * 10.0**DET[1] // with 1.0D+00 <= abs ( DET[0] ) < 10.0D+00 or DET[0] = 0.0. // // Output, int INERT[3], the inertia of the original matrix, if requested. // INERT(1) = number of positive eigenvalues. // INERT(2) = number of negative eigenvalues. // INERT(3) = number of zero eigenvalues. // // Workspace, double WORK[N]. // // Input, int JOB, has the decimal expansion ABC where: // if A /= 0, the inertia is computed, // if B /= 0, the determinant is computed, // if C /= 0, the inverse is computed. // For example, JOB = 111 gives all three. // { double d; int ik; int ikp1; int k; int kk; int kkp1; double t; bool doinv = job % 10 != 0; bool dodet = job % 100 / 10 != 0; bool doert = job % 1000 / 100 != 0; if (dodet || doert) { switch (doert) { case true: inert[0] = 0; inert[1] = 0; inert[2] = 0; break; } switch (dodet) { case true: det[0] = 1.0; det[1] = 0.0; break; } t = 0.0; ik = 0; for (k = 1; k <= n; k++) { kk = ik + k; d = ap[kk - 1]; switch (kpvt[k - 1]) { // // 2 by 2 block // use det (d s) = (d/t * c - t) * t, t = abs ( s ) // (s c) // to avoid underflow/overflow troubles. // // Take two passes through scaling. Use T for flag. // case <= 0 when t == 0.0: ikp1 = ik + k; kkp1 = ikp1 + k; t = Math.Abs(ap[kkp1 - 1]); d = d / t * ap[kkp1] - t; break; case <= 0: d = t; t = 0.0; break; } switch (doert) { case true: switch (d) { case > 0.0: inert[0] += 1; break; case < 0.0: inert[1] += 1; break; case 0.0: inert[2] += 1; break; } break; } switch (dodet) { case true: { det[0] *= d; if (det[0] != 0.0) { while (Math.Abs(det[0]) < 1.0) { det[0] *= 10.0; det[1] -= 1.0; } while (10.0 <= Math.Abs(det[0])) { det[0] /= 10.0; det[1] += 1.0; } } break; } } ik += k; } } switch (doinv) { // // Compute inverse(A). // case true: { k = 1; ik = 0; while (k <= n) { int km1 = k - 1; kk = ik + k; ikp1 = ik + k; kkp1 = ikp1 + k; int kstep; int jk; int j; int ij; switch (kpvt[k - 1]) { case >= 0: { // // 1 by 1. // ap[kk - 1] = 1.0 / ap[kk - 1]; switch (k) { case >= 2: { BLAS1D.dcopy(k - 1, ap, 1, ref work, 1, xIndex: +ik); ij = 0; for (j = 1; j <= k - 1; j++) { jk = ik + j; ap[jk - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij); BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik); ij += j; } ap[kk - 1] += BLAS1D.ddot(k - 1, work, 1, ap, 1, yIndex: +ik); break; } } kstep = 1; break; } default: { // // 2 by 2. // t = Math.Abs(ap[kkp1 - 1]); double ak = ap[kk - 1] / t; double akp1 = ap[kkp1] / t; double akkp1 = ap[kkp1 - 1] / t; d = t * (ak * akp1 - 1.0); ap[kk - 1] = akp1 / d; ap[kkp1] = ak / d; ap[kkp1 - 1] = -akkp1 / d; switch (km1) { case >= 1: { BLAS1D.dcopy(km1, ap, 1, ref work, 1, xIndex: +ikp1); ij = 0; for (j = 1; j <= km1; j++) { int jkp1 = ikp1 + j; ap[jkp1 - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij); BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ikp1); ij += j; } ap[kkp1] += BLAS1D.ddot(km1, work, 1, ap, 1, yIndex: +ikp1); ap[kkp1 - 1] += BLAS1D.ddot(km1, ap, 1, ap, 1, xIndex: +ik, yIndex: +ikp1); BLAS1D.dcopy(km1, ap, 1, ref work, 1, xIndex: +ik); ij = 0; for (j = 1; j <= km1; j++) { jk = ik + j; ap[jk - 1] = BLAS1D.ddot(j, ap, 1, work, 1, xIndex: +ij); BLAS1D.daxpy(j - 1, work[j - 1], ap, 1, ref ap, 1, xIndex: +ij, yIndex: +ik); ij += j; } ap[kk - 1] += BLAS1D.ddot(km1, work, 1, ap, 1, yIndex: +ik); break; } } kstep = 2; break; } } // // Swap. // int ks = Math.Abs(kpvt[k - 1]); if (ks != k) { int iks = ks * (ks - 1) / 2; BLAS1D.dswap(ks, ref ap, 1, ref ap, 1, xIndex: +iks, yIndex: +ik); int ksj = ik + ks; double temp; int jb; for (jb = ks; jb <= k; jb++) { j = k + ks - jb; jk = ik + j; temp = ap[jk - 1]; ap[jk - 1] = ap[ksj - 1]; ap[ksj - 1] = temp; ksj -= j - 1; } if (kstep != 1) { int kskp1 = ikp1 + ks; temp = ap[kskp1 - 1]; ap[kskp1 - 1] = ap[kkp1 - 1]; ap[kkp1 - 1] = temp; } } ik += k; ik = kstep switch { 2 => ik + k + 1, _ => ik }; k += kstep; } break; } } } }
public static void r8po_sl(double[] a, int lda, int n, ref double[] b, int aIndex = 0, int bIndex = 0) //****************************************************************************80 // // Purpose: // // R8PO_SL solves a linear system factored by R8PO_FA. // // Discussion: // // 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: // // 23 May 2005 // // Author: // // FORTRAN77 original version by Dongarra, Moler, Bunch, Stewart. // C++ version by John Burkardt. // // Reference: // // Dongarra, Moler, Bunch and Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input, double A[LDA*N], the output from R8PO_FA. // // Input, int LDA, the leading dimension of the array A. // // Input, int N, the order of the matrix. // // Input/output, double B[N]. On input, the right hand side. // On output, the solution. // { int k; double t; // // Solve R' * Y = B. // for (k = 1; k <= n; k++) { t = BLAS1D.ddot(k - 1, a, 1, b, 1, aIndex + 0 + (k - 1) * lda, bIndex); b[bIndex + k - 1] = (b[bIndex + k - 1] - t) / a[aIndex + k - 1 + (k - 1) * lda]; } // // Solve R * X = Y. // for (k = n; 1 <= k; k--) { b[bIndex + k - 1] /= a[aIndex + k - 1 + (k - 1) * lda]; t = -b[bIndex + k - 1]; BLAS1D.daxpy(k - 1, t, a, 1, ref b, 1, aIndex + 0 + (k - 1) * lda, bIndex); } }
public static int dgbfa(ref double[] abd, int lda, int n, int ml, int mu, ref int[] ipvt) //****************************************************************************80 // // Purpose: // // DGBFA factors a real band matrix by elimination. // // Discussion: // // DGBFA is usually called by DGBCO, 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: // // 23 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double ABD[LDA*N]. On input, the matrix in band // storage. The columns of the matrix are stored in the columns of ABD // and the diagonals of the matrix are stored in rows ML+1 through // 2*ML+MU+1 of ABD. On output, an upper triangular matrix in band storage // and the multipliers which were used to obtain it. The factorization // can be written A = L*U where L is a product of permutation and unit lower // triangular matrices and U is upper triangular. // // Input, int LDA, the leading dimension of the array ABD. // 2*ML + MU + 1 <= LDA is required. // // Input, int N, the order of the matrix. // // Input, int ML, MU, the number of diagonals below and above the // main diagonal. 0 <= ML < N, 0 <= MU < N. // // Output, int IPVT[N], the pivot indices. // // Output, integer DGBFA, error flag. // 0, normal value. // K, if U(K,K) == 0.0D+00. This is not an error condition for this // subroutine, but it does indicate that DGBSL will divide by zero if // called. Use RCOND in DGBCO 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] = 0.0; } } jz = j1; int ju = 0; // // Gaussian elimination with partial pivoting. // for (k = 1; k <= n - 1; k++) { // // Zero out the next fill-in column. // jz += 1; if (jz <= n) { for (i = 1; i <= ml; i++) { abd[i - 1 + (jz - 1) * lda] = 0.0; } } // // Find L = pivot index. // int lm = Math.Min(ml, n - k); int l = BLAS1D.idamax(lm + 1, abd, 1, +m - 1 + (k - 1) * lda) + m - 1; ipvt[k - 1] = l + k - m; switch (abd[l - 1 + (k - 1) * lda]) { // // Zero pivot implies this column already triangularized. // case 0.0: info = k; break; // default: { double 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 = -1.0 / abd[m - 1 + (k - 1) * lda]; BLAS1D.dscal(lm, t, ref abd, 1, +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; } BLAS1D.daxpy(lm, t, abd, 1, ref abd, 1, +m + (k - 1) * lda, +mm + (j - 1) * lda); } break; } } } ipvt[n - 1] = n; info = abd[m - 1 + (n - 1) * lda] switch { 0.0 => n, _ => info }; return(info); } }
public static int dspfa(ref double[] ap, int n, ref int[] kpvt) //****************************************************************************80 // // Purpose: // // DSPFA factors a real symmetric matrix stored in packed form. // // Discussion: // // To solve A*X = B, follow DSPFA by DSPSL. // // To compute inverse(A)*C, follow DSPFA by DSPSL. // // To compute determinant(A), follow DSPFA by DSPDI. // // To compute inertia(A), follow DSPFA by DSPDI. // // To compute inverse(A), follow DSPFA by DSPDI. // // Packed storage: // // The following program segment will pack the upper triangle of a // symmetric matrix. // // k = 0 // do j = 1, n // do i = 1, j // k = k + 1 // ap(k) = a(i,j) // end do // end do // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 25 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double AP[(N*(N+1))/2]. On input, the packed form of a // symmetric matrix A. The columns of the upper triangle are stored // sequentially in a one-dimensional array. On output, a block diagonal // matrix and the multipliers which were used to obtain it stored in // packed form. The factorization can be written A = U*D*U' where U // is a product of permutation and unit upper triangular matrices, U' // is the transpose of U, and D is block diagonal with 1 by 1 and 2 // by 2 blocks. // // Input, int N, the order of the matrix. // // Output, int KPVT[N], the pivot indices. // // Output, int DSPFA, error flag. // 0, normal value. // K, if the K-th pivot block is singular. This is not an error // condition for this subroutine, but it does indicate that DSPSL or // DSPDI may divide by zero if called. // { int im = 0; // // ALPHA is used in choosing pivot block size. // double alpha = (1.0 + Math.Sqrt(17.0)) / 8.0; int info = 0; // // Main loop on K, which goes from N to 1. // int k = n; int ik = n * (n - 1) / 2; for (;;) { // // Leave the loop if K = 0 or K = 1. // if (k == 0) { break; } if (k == 1) { kpvt[0] = 1; info = ap[0] switch { 0.0 => 1, _ => info }; break; } // // This section of code determines the kind of elimination to be performed. // When it is completed, KSTEP will be set to the size of the pivot block, // and SWAP will be set to .true. if an interchange is required. // int km1 = k - 1; int kk = ik + k; double absakk = Math.Abs(ap[kk - 1]); // // Determine the largest off-diagonal element in column K. // int imax = BLAS1D.idamax(k - 1, ap, 1, index: +ik); int imk = ik + imax; double colmax = Math.Abs(ap[imk - 1]); int kstep; bool swap; int j; int imj; if (alpha * colmax <= absakk) { kstep = 1; swap = false; } // // Determine the largest off-diagonal element in row IMAX. // else { double rowmax = 0.0; int imaxp1 = imax + 1; im = imax * (imax - 1) / 2; imj = im + 2 * imax; for (j = imaxp1; j <= k; j++) { rowmax = Math.Max(rowmax, Math.Abs(ap[imj - 1])); imj += j; } if (imax != 1) { int jmax = BLAS1D.idamax(imax - 1, ap, 1, index: +im); int jmim = jmax + im; rowmax = Math.Max(rowmax, Math.Abs(ap[jmim - 1])); } int imim = imax + im; if (alpha * rowmax <= Math.Abs(ap[imim - 1])) { kstep = 1; swap = true; } else if (alpha * colmax * (colmax / rowmax) <= absakk) { kstep = 1; swap = false; } else { kstep = 2; swap = imax != km1; } } switch (Math.Max(absakk, colmax)) { // // Column K is zero. Set INFO and iterate the loop. // case 0.0: kpvt[k - 1] = k; info = k; break; default: { double mulk; int jk; int jj; double t; int ij; if (kstep != 2) { switch (swap) { // // 1 x 1 pivot block. // case true: { // // Perform an interchange. // BLAS1D.dswap(imax, ref ap, 1, ref ap, 1, xIndex: +im, yIndex: +ik); imj = ik + imax; for (jj = imax; jj <= k; jj++) { j = k + imax - jj; jk = ik + j; t = ap[jk - 1]; ap[jk - 1] = ap[imj - 1]; ap[imj - 1] = t; imj -= j - 1; } break; } } // // Perform the elimination. // ij = ik - (k - 1); for (jj = 1; jj <= km1; jj++) { j = k - jj; jk = ik + j; mulk = -ap[jk - 1] / ap[kk - 1]; t = mulk; BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij); ap[jk - 1] = mulk; ij -= j - 1; } kpvt[k - 1] = swap switch { // // Set the pivot array. // true => imax, _ => k }; } else { // // 2 x 2 pivot block. // int km1k = ik + k - 1; int ikm1 = ik - (k - 1); int jkm1; switch (swap) { // // Perform an interchange. // case true: { BLAS1D.dswap(imax, ref ap, 1, ref ap, 1, xIndex: +im, yIndex: +ikm1); imj = ikm1 + imax; for (jj = imax; jj <= km1; jj++) { j = km1 + imax - jj; jkm1 = ikm1 + j; t = ap[jkm1 - 1]; ap[jkm1 - 1] = ap[imj - 1]; ap[imj - 1] = t; imj -= j - 1; } t = ap[km1k - 1]; ap[km1k - 1] = ap[imk - 1]; ap[imk - 1] = t; break; } } // // Perform the elimination. // if (k - 2 != 0) { double ak = ap[kk - 1] / ap[km1k - 1]; int km1km1 = ikm1 + k - 1; double akm1 = ap[km1km1 - 1] / ap[km1k - 1]; double denom = 1.0 - ak * akm1; ij = ik - (k - 1) - (k - 2); for (jj = 1; jj <= k - 2; jj++) { j = km1 - jj; jk = ik + j; double bk = ap[jk - 1] / ap[km1k - 1]; jkm1 = ikm1 + j; double bkm1 = ap[jkm1 - 1] / ap[km1k - 1]; mulk = (akm1 * bk - bkm1) / denom; double mulkm1 = (ak * bkm1 - bk) / denom; t = mulk; BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ik, yIndex: +ij); t = mulkm1; BLAS1D.daxpy(j, t, ap, 1, ref ap, 1, xIndex: +ikm1, yIndex: +ij); ap[jk - 1] = mulk; ap[jkm1 - 1] = mulkm1; ij -= j - 1; } } kpvt[k - 1] = swap switch { // // Set the pivot array. // true => - imax, _ => 1 - k }; kpvt[k - 2] = kpvt[k - 1]; } break; } } ik -= k - 1; switch (kstep) { case 2: ik -= k - 2; break; } k -= kstep; } return(info); } }
public static void dgesl(double[] a, int lda, int n, int[] ipvt, ref double[] b, int job) //****************************************************************************80 // // Purpose: // // DGESL solves a real general linear system A * X = B. // // Discussion: // // DGESL can solve either of the systems A * X = B or A' * X = B. // // The system matrix must have been factored by DGECO or DGEFA. // // 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 DGECO has set 0.0 < RCOND // or DGEFA has set INFO == 0. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 16 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input, double A[LDA*N], the output from DGECO or DGEFA. // // Input, int LDA, the leading dimension of A. // // Input, int N, the order of the matrix A. // // Input, int IPVT[N], the pivot vector from DGECO or DGEFA. // // Input/output, double B[N]. // On input, the right hand side vector. // On output, the solution vector. // // Input, int JOB. // 0, solve A * X = B; // nonzero, solve A' * X = B. // { int k; int l; double t; switch (job) { // // Solve A * X = B. // case 0: { for (k = 1; k <= n - 1; k++) { l = ipvt[k - 1]; t = b[l - 1]; if (l != k) { b[l - 1] = b[k - 1]; b[k - 1] = t; } BLAS1D.daxpy(n - k, t, a, 1, ref b, 1, +k + (k - 1) * lda, +k); } for (k = n; 1 <= k; k--) { b[k - 1] /= a[k - 1 + (k - 1) * lda]; t = -b[k - 1]; BLAS1D.daxpy(k - 1, t, a, 1, ref b, 1, +0 + (k - 1) * lda); } break; } // default: { for (k = 1; k <= n; k++) { t = BLAS1D.ddot(k - 1, a, 1, b, 1, +0 + (k - 1) * lda); b[k - 1] = (b[k - 1] - t) / a[k - 1 + (k - 1) * lda]; } for (k = n - 1; 1 <= k; k--) { b[k - 1] += BLAS1D.ddot(n - k, a, 1, b, 1, +k + (k - 1) * lda, +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 dppdi(ref double[] ap, int n, ref double[] det, int job) //****************************************************************************80 // // Purpose: // // DPPDI computes the determinant and inverse of a matrix factored by DPPCO or DPPFA. // // Discussion: // // A division by zero will occur if the input factor contains // a zero on the diagonal and the inverse is requested. // It will not occur if the subroutines are called correctly // and if DPOCO or DPOFA has set INFO == 0. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 24 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double AP[N*(N+1)/2]. On input, the output from // DPPCO or DPPFA. On output, the upper triangular half of the // inverse, if requested. // // Input, int N, the order of the matrix. // // Output, double DET[2], the determinant of the original matrix // if requested. // determinant = DET[0] * 10.0**DET[1] // with 1.0D+00 <= DET[0] < 10.0D+00 or DET[0] == 0.0D+00. // // Input, int JOB, job request. // 11, both determinant and inverse. // 01, inverse only. // 10, determinant only. // { // // Compute the determinant. // if (job / 10 != 0) { det[0] = 1.0; det[1] = 0.0; const double s = 10.0; int ii = 0; int i; for (i = 1; i <= n; i++) { ii += i; det[0] = det[0] * ap[ii - 1] * ap[ii - 1]; if (det[0] == 0.0) { break; } while (det[0] < 1.0) { det[0] *= s; det[1] -= 1.0; } while (s <= det[0]) { det[0] /= s; det[1] += 1.0; } } } // // Compute inverse(R). // if (job % 10 == 0) { return; } int kk = 0; int k; int k1; int kj; int j1; double t; int j; for (k = 1; k <= n; k++) { k1 = kk + 1; kk += k; ap[kk - 1] = 1.0 / ap[kk - 1]; t = -ap[kk - 1]; BLAS1D.dscal(k - 1, t, ref ap, 1, index: +k1 - 1); j1 = kk + 1; kj = kk + k; for (j = k + 1; j <= n; j++) { t = ap[kj - 1]; ap[kj - 1] = 0.0; BLAS1D.daxpy(k, t, ap, 1, ref ap, 1, xIndex: +k1 - 1, yIndex: +j1 - 1); j1 += j; kj += j; } } // // Form inverse(R) * (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 = ap[kj - 1]; BLAS1D.daxpy(k, t, ap, 1, ref ap, 1, xIndex: +j1 - 1, yIndex: +k1 - 1); k1 += k; kj += 1; } t = ap[jj - 1]; BLAS1D.dscal(j, t, ref ap, 1, index: +j1 - 1); } }
private static void dscal_test() //****************************************************************************80 // // Purpose: // // DSCAL_TEST tests DSCAL. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { int N = 6; double[] x = new double[N]; for (int i = 0; i < N; i++) { x[i] = i + 1; } Console.WriteLine(""); Console.WriteLine("DSCAL_TEST"); Console.WriteLine(" DSCAL multiplies a vector by a scalar."); Console.WriteLine(""); Console.WriteLine(" X ="); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } double da = 5.0; BLAS1D.dscal(N, da, ref x, 1); Console.WriteLine(""); Console.WriteLine(" DSCAL ( N, " + da + ", X, 1 )"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { x[i] = i + 1; } da = -2.0; BLAS1D.dscal(3, da, ref x, 2); Console.WriteLine(""); Console.WriteLine(" DSCAL ( 3, " + da + ", X, 2 )"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } }
public static void dgbsl(double[] abd, int lda, int n, int ml, int mu, int[] ipvt, ref double[] b, int job) //****************************************************************************80 // // Purpose: // // DGBSL solves a real banded system factored by DGBCO or DGBFA. // // Discussion: // // DGBSL can solve either A * X = B or 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 DGBCO has set 0.0 < RCOND // or DGBFA has set INFO == 0. // // To compute inverse(A) * C where C is a matrix with P columns: // // call dgbco ( abd, lda, n, ml, mu, ipvt, rcond, z ) // // if ( rcond is too small ) then // exit // end if // // do j = 1, p // call dgbsl ( abd, lda, n, ml, mu, ipvt, c(1,j), 0 ) // end do // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input, double ABD[LDA*N], the output from DGBCO or DGBFA. // // Input, integer LDA, the leading dimension of the array ABD. // // Input, int N, the order of the matrix. // // Input, int ML, MU, the number of diagonals below and above the // main diagonal. 0 <= ML < N, 0 <= MU < N. // // Input, int IPVT[N], the pivot vector from DGBCO or DGBFA. // // Input/output, double B[N]. On input, the right hand side. // On output, the solution. // // Input, int JOB, job choice. // 0, solve A*X=B. // nonzero, solve A'*X=B. // { int k; int l; int la; int lb; int lm; double t; int m = mu + ml + 1; switch (job) { // // JOB = 0, Solve A * x = b. // // First solve L * y = b. // case 0: { switch (ml) { case > 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; } BLAS1D.daxpy(lm, t, abd, 1, ref b, 1, +m + (k - 1) * lda, k); } break; } } // // 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]; BLAS1D.daxpy(lm, t, abd, 1, ref b, 1, +la - 1 + (k - 1) * lda, +lb - 1); } break; } // default: { for (k = 1; k <= n; k++) { lm = Math.Min(k, m) - 1; la = m - lm; lb = k - lm; t = BLAS1D.ddot(lm, abd, 1, b, 1, +la - 1 + (k - 1) * lda, +lb - 1); b[k - 1] = (b[k - 1] - t) / abd[m - 1 + (k - 1) * lda]; } switch (ml) { // // Now solve L' * x = y. // case > 0: { for (k = n - 1; 1 <= k; k--) { lm = Math.Min(ml, n - k); b[k - 1] += BLAS1D.ddot(lm, abd, 1, b, 1, +m + (k - 1) * lda, +k); l = ipvt[k - 1]; if (l == k) { continue; } t = b[l - 1]; b[l - 1] = b[k - 1]; b[k - 1] = t; } break; } } break; } } }
private static void dswap_test() //****************************************************************************80 // // Purpose: // // DSWAP_TEST tests DSWAP. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 15 May 2006 // // Author: // // John Burkardt // { int N = 6; double[] x = new double[N]; double[] y = new double[N]; for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } Console.WriteLine(""); Console.WriteLine("DSWAP_TEST"); Console.WriteLine(" DSWAP swaps two vectors."); Console.WriteLine(""); Console.WriteLine(" X and Y:"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } BLAS1D.dswap(N, ref x, 1, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DSWAP ( N, X, 1, Y, 1 )"); Console.WriteLine(""); Console.WriteLine(" X and Y:"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } for (int i = 0; i < N; i++) { x[i] = i + 1; } for (int i = 0; i < N; i++) { y[i] = 100 * (i + 1); } BLAS1D.dswap(3, ref x, 2, ref y, 1); Console.WriteLine(""); Console.WriteLine(" DSWAP ( 3, X, 2, Y, 1 )"); Console.WriteLine(""); Console.WriteLine(" X and Y:"); Console.WriteLine(""); for (int i = 0; i < N; i++) { Console.WriteLine(" " + (i + 1).ToString(CultureInfo.InvariantCulture).PadLeft(6) + " " + x[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + " " + y[i].ToString(CultureInfo.InvariantCulture).PadLeft(14) + ""); } }
public static void dchud(ref double[] r, int ldr, int p, double[] x, ref double[] z, int ldz, int nz, double[] y, ref double[] rho, ref double[] c, ref double[] s) //****************************************************************************80 // // Purpose: // // DCHUD updates an augmented Cholesky decomposition. // // Discussion: // // DCHUD can also update 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, DCHUD 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 * RHO + ZETA * ZETA ). DCHUD will // simultaneously update several triplets (Z, Y, RHO). // // For a less terse description of what DCHUD 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) ) // ( ). // ( -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: // // 08 June 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double R[LDR*P], the upper triangular matrix to be // updated. The part of R below the diagonal is not referenced. // On output, the matrix has been updated. // // Input, int LDR, the leading dimension of the array R. // LDR must be at least equal to P. // // Input, int P, the order of the matrix R. // // Input, double X[P], the row to be added to R. // // Input/output, double Z[LDZ*NZ], contains NZ P-vectors // to be updated with R. // // Input, int LDZ, the leading dimension of the array Z. // LDZ must be at least P. // // 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, double Y[NZ], the scalars for updating the vectors Z. // // Input/output, double RHO[NZ]. On input, the norms of the // residual vectors to be updated. If RHO(J) is negative, it is left // unaltered. // // Output, double C[P], S[P], the cosines and sines of the // transforming rotations. // { int i; int j; double t; // // Update R. // for (j = 1; j <= p; j++) { double xj = x[j - 1]; // // Apply the previous rotations. // for (i = 1; i <= j - 1; i++) { t = c[i - 1] * r[i - 1 + (j - 1) * ldz] + s[i - 1] * xj; xj = c[i - 1] * xj - s[i - 1] * r[i - 1 + (j - 1) * ldz]; r[i - 1 + (j - 1) * ldz] = t; } // // Compute the next rotation. // BLAS1D.drotg(ref r[j - 1 + (j - 1) * ldr], ref xj, ref c[j - 1], ref s[j - 1]); } // // If required, update Z and RHO. // for (j = 1; j <= nz; j++) { double 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 - s[i - 1] * z[i - 1 + (j - 1) * ldz]; z[i - 1 + (j - 1) * ldz] = t; } double azeta = Math.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 dtrdi(ref double[] t, int ldt, int n, ref double[] det, int job) //****************************************************************************80 // // Purpose: // // DTRDI computes the determinant and inverse of a real triangular matrix. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 March 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double T[LDT*N]. // On input, T contains 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, T contains the inverse matrix, if it was requested. // // Input, int LDT, the leading dimension of T. // // Input, int N, the order of the matrix. // // Output, double DET[2], the determinant of the matrix, if // requested. The determinant = DET[0] * 10.0**DET[1], with // 1.0 <= abs ( DET[0] ) < 10.0, or DET[0] == 0. // // Input, int JOB, specifies the shape of T, and the task. // 010, inverse of lower triangular matrix. // 011, inverse of upper triangular matrix. // 100, determinant only. // 110, determinant and inverse of lower triangular. // 111, determinant and inverse of upper triangular. // // Output, int DTRDI. // If the inverse was requested, then // 0, if the system was nonsingular; // nonzero, if the system was singular. // { int j; int k; double temp; // // Determinant. // int info = 0; if (job / 100 != 0) { det[0] = 1.0; det[1] = 0.0; int i; for (i = 1; i <= n; i++) { det[0] *= t[i - 1 + (i - 1) * ldt]; if (det[0] == 0.0) { break; } while (Math.Abs(det[0]) < 1.0) { det[0] *= 10.0; det[1] -= 1.0; } while (10.0 <= Math.Abs(det[0])) { det[0] /= 10.0; det[1] += 1.0; } } } switch (job / 10 % 10) { case 0: return(info); } // // Inverse of an upper triangular matrix. // if (job % 10 != 0) { info = 0; for (k = 1; k <= n; k++) { if (t[k - 1 + (k - 1) * ldt] == 0.0) { info = k; break; } t[k - 1 + (k - 1) * ldt] = 1.0 / t[k - 1 + (k - 1) * ldt]; temp = -t[k - 1 + (k - 1) * ldt]; BLAS1D.dscal(k - 1, temp, ref t, 1, index: +0 + (k - 1) * ldt); for (j = k + 1; j <= n; j++) { temp = t[k - 1 + (j - 1) * ldt]; t[k - 1 + (j - 1) * ldt] = 0.0; BLAS1D.daxpy(k, temp, t, 1, ref t, 1, xIndex: +0 + (k - 1) * ldt, yIndex: +0 + (j - 1) * ldt); } } } // // Inverse of a lower triangular matrix. // else { info = 0; for (k = n; 1 <= k; k--) { if (t[k - 1 + (k - 1) * ldt] == 0.0) { info = k; break; } t[k - 1 + (k - 1) * ldt] = 1.0 / t[k - 1 + (k - 1) * ldt]; temp = -t[k - 1 + (k - 1) * ldt]; if (k != n) { BLAS1D.dscal(n - k, temp, ref t, 1, index: +k + (k - 1) * ldt); } for (j = 1; j <= k - 1; j++) { temp = t[k - 1 + (j - 1) * ldt]; t[k - 1 + (j - 1) * ldt] = 0.0; BLAS1D.daxpy(n - k + 1, temp, t, 1, ref t, 1, xIndex: +k - 1 + (k - 1) * ldt, yIndex: +k - 1 + (j - 1) * ldt); } } } return(info); }
public static void dpbsl(double[] abd, int lda, int n, int m, ref double[] b) //****************************************************************************80 // // Purpose: // // DPBSL solves a real SPD band system factored by DPBCO or DPBFA. // // Discussion: // // The matrix is assumed to be a symmetric positive definite (SPD) // band matrix. // // To compute inverse(A) * C where C is a matrix with P columns: // // call dpbco ( abd, lda, n, rcond, z, info ) // // if ( rcond is too small .or. info /= 0) go to ... // // do j = 1, p // call dpbsl ( abd, lda, n, c(1,j) ) // end do // // 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: // // 23 May 2005 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input, double ABD[LDA*N], the output from DPBCO or DPBFA. // // Input, int LDA, the leading dimension of the array ABD. // // Input, int N, the order of the matrix. // // Input, int M, the number of diagonals above the main diagonal. // // Input/output, double B[N]. On input, the right hand side. // On output, the solution. // { int k; int la; int lb; int lm; double t; // // Solve R'*Y = B. // for (k = 1; k <= n; k++) { lm = Math.Min(k - 1, m); la = m + 1 - lm; lb = k - lm; t = BLAS1D.ddot(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]; BLAS1D.daxpy(lm, t, abd, 1, ref b, 1, xIndex: +la - 1 + (k - 1) * lda, yIndex: +lb - 1); } }
public static int dchdc(ref double[] a, int lda, int p, double[] work, ref int[] ipvt, int job) //****************************************************************************80 // // Purpose: // // DCHDC computes the Cholesky decomposition of a positive definite matrix. // // Discussion: // // A pivoting option allows the user to estimate the condition of a // positive definite matrix or determine the rank of a positive // semidefinite matrix. // // For positive definite matrices, INFO = P is the normal return. // // For pivoting with positive semidefinite matrices, INFO will // in general be less than P. However, INFO may be greater than // the rank of A, since rounding error can cause an otherwise zero // element to be positive. Indefinite systems will always cause // INFO to be less than P. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 23 June 2009 // // Author: // // Original FORTRAN77 version by Jack Dongarra, Cleve Moler, Jim Bunch, // Pete Stewart. // C++ version by John Burkardt. // // Reference: // // Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, // LINPACK User's Guide, // SIAM, (Society for Industrial and Applied Mathematics), // 3600 University City Science Center, // Philadelphia, PA, 19104-2688. // ISBN 0-89871-172-X // // Parameters: // // Input/output, double A[LDA*P]. // On input, A contains the matrix whose decomposition is to // be computed. Only the upper half of A need be stored. // The lower part of the array a is not referenced. // On output, A contains in its upper half the Cholesky factor // of the input matrix, as it has been permuted by pivoting. // // Input, int LDA, the leading dimension of the array A. // // Input, int P, the order of the matrix. // // Input, double WORK[P] is a work array. // // Input/output, int IPVT[P]. // On input, IPVT contains integers that control the selection // of the pivot elements, if pivoting has been requested. // Each diagonal element A(K,K) is placed in one of three classes // according to the value of IPVT(K). // // > 0, then X(K) is an initial element. // = 0, then X(K) is a free element. // < 0, then X(K) is a final element. // // Before the decomposition is computed, initial elements are moved by // symmetric row and column interchanges to the beginning of the array A // and final elements to the end. Both initial and final elements are // frozen in place during the computation and only free elements are moved. // At the K-th stage of the reduction, if A(K,K) is occupied by a free // element, it is interchanged with the largest free element A(L,L) with // K <= L. IPVT is not referenced if JOB is 0. // // On output, IPVT(J) contains the index of the diagonal element // of A that was moved into the J-th position, if pivoting was requested. // // Input, int JOB, initiates column pivoting. // 0, no pivoting is done. // nonzero, pivoting is done. // // Output, int DCHDC, contains the index of the last positive diagonal // element of the Cholesky factor. // { int j; int k; double temp; int pl = 1; int pu = 0; int info = p; // // Pivoting has been requested. // Rearrange the the elements according to IPVT. // if (job != 0) { for (k = 1; k <= p; k++) { bool swapk = 0 < ipvt[k - 1]; bool negk = ipvt[k - 1] < 0; ipvt[k - 1] = negk switch { true => - k, _ => k }; switch (swapk) { case true: { if (k != pl) { BLAS1D.dswap(pl - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (pl - 1) * lda); temp = a[k - 1 + (k - 1) * lda]; a[k - 1 + (k - 1) * lda] = a[pl - 1 + (pl - 1) * lda]; a[pl - 1 + (pl - 1) * lda] = temp; for (j = pl + 1; j <= p; j++) { if (j < k) { temp = a[pl - 1 + (j - 1) * lda]; a[pl - 1 + (j - 1) * lda] = a[j - 1 + (k - 1) * lda]; a[j - 1 + (k - 1) * lda] = temp; } else if (k < j) { temp = a[k - 1 + (j - 1) * lda]; a[k - 1 + (j - 1) * lda] = a[pl - 1 + (j - 1) * lda]; a[pl - 1 + (j - 1) * lda] = temp; } } ipvt[k - 1] = ipvt[pl - 1]; ipvt[pl - 1] = k; } pl += 1; break; } } } pu = p; for (k = p; pl <= k; k--) { switch (ipvt[k - 1]) { case < 0: { ipvt[k - 1] = -ipvt[k - 1]; if (pu != k) { BLAS1D.dswap(k - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (pu - 1) * lda); temp = a[k - 1 + (k - 1) * lda]; a[k - 1 + (k - 1) * lda] = a[pu - 1 + (pu - 1) * lda]; a[pu - 1 + (pu - 1) * lda] = temp; for (j = k + 1; j <= p; j++) { if (j < pu) { temp = a[k - 1 + (j - 1) * lda]; a[k - 1 + (j - 1) * lda] = a[j - 1 + (pu - 1) * lda]; a[j - 1 + (pu - 1) * lda] = temp; } else if (pu < j) { temp = a[k - 1 + (j - 1) * lda]; a[k - 1 + (j - 1) * lda] = a[pu - 1 + (j - 1) * lda]; a[pu - 1 + (j - 1) * lda] = temp; } } (ipvt[k - 1], ipvt[pu - 1]) = (ipvt[pu - 1], ipvt[k - 1]); } pu -= 1; break; } } } } for (k = 1; k <= p; k++) { // // Reduction loop. // double maxdia = a[k - 1 + (k - 1) * lda]; int maxl = k; // // Determine the pivot element. // if (pl <= k && k < pu) { int l; for (l = k + 1; l <= pu; l++) { if (!(maxdia < a[l - 1 + (l - 1) * lda])) { continue; } maxdia = a[l - 1 + (l - 1) * lda]; maxl = l; } } switch (maxdia) { // // Quit if the pivot element is not positive. // case <= 0.0: info = k - 1; return(info); } // // Start the pivoting and update IPVT. // if (k != maxl) { BLAS1D.dswap(k - 1, ref a, 1, ref a, 1, xIndex: +0 + (k - 1) * lda, yIndex: +0 + (maxl - 1) * lda); a[maxl - 1 + (maxl - 1) * lda] = a[k - 1 + (k - 1) * lda]; a[k - 1 + (k - 1) * lda] = maxdia; (ipvt[maxl - 1], ipvt[k - 1]) = (ipvt[k - 1], ipvt[maxl - 1]); } // // Reduction step. // Pivoting is contained across the rows. // work[k - 1] = Math.Sqrt(a[k - 1 + (k - 1) * lda]); a[k - 1 + (k - 1) * lda] = work[k - 1]; for (j = k + 1; j <= p; j++) { if (k != maxl) { if (j < maxl) { temp = a[k - 1 + (j - 1) * lda]; a[k - 1 + (j - 1) * lda] = a[j - 1 + (maxl - 1) * lda]; a[j - 1 + (maxl - 1) * lda] = temp; } else if (maxl < j) { temp = a[k - 1 + (j - 1) * lda]; a[k - 1 + (j - 1) * lda] = a[maxl - 1 + (j - 1) * lda]; a[maxl - 1 + (j - 1) * lda] = temp; } } a[k - 1 + (j - 1) * lda] /= work[k - 1]; work[j - 1] = a[k - 1 + (j - 1) * lda]; temp = -a[k - 1 + (j - 1) * lda]; BLAS1D.daxpy(j - k, temp, work, 1, ref a, 1, xIndex: +k, yIndex: +k + (j - 1) * lda); } } return(info); } }