void dqrdc(double a[], int lda, int n, int p, double qraux[], int jpvt[], double work[], int job) /******************************************************************************/ /* Purpose: DQRDC computes the QR factorization of a real rectangular matrix. Discussion: DQRDC uses Householder transformations. Column pivoting based on the 2-norms of the reduced columns may be performed at the user's option. Licensing: This code is distributed under the GNU LGPL license. Modified: 07 June 2005 Author: C version by John Burkardt. Reference: Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, LINPACK User's Guide, SIAM, (Society for Industrial and Applied Mathematics), 3600 University City Science Center, Philadelphia, PA, 19104-2688. ISBN 0-89871-172-X Parameters: Input/output, double A(LDA,P). On input, the N by P matrix whose decomposition is to be computed. On output, A contains in its upper triangle the upper triangular matrix R of the QR factorization. Below its diagonal A contains information from which the orthogonal part of the decomposition can be recovered. Note that if pivoting has been requested, the decomposition is not that of the original matrix A but that of A with its columns permuted as described by JPVT. Input, int LDA, the leading dimension of the array A. LDA must be at least N. Input, int N, the number of rows of the matrix A. Input, int P, the number of columns of the matrix A. Output, double QRAUX[P], contains further information required to recover the orthogonal part of the decomposition. Input/output, integer JPVT[P]. On input, JPVT contains integers that control the selection of the pivot columns. The K-th column A(*,K) of A is placed in one of three classes according to the value of JPVT(K). > 0, then A(K) is an initial column. = 0, then A(K) is a free column. < 0, then A(K) is a final column. Before the decomposition is computed, initial columns are moved to the beginning of the array A and final columns to the end. Both initial and final columns are frozen in place during the computation and only free columns are moved. At the K-th stage of the reduction, if A(*,K) is occupied by a free column it is interchanged with the free column of largest reduced norm. JPVT is not referenced if JOB == 0. On output, JPVT(K) contains the index of the column of the original matrix that has been interchanged into the K-th column, if pivoting was requested. Workspace, double WORK[P]. WORK is not referenced if JOB == 0. Input, int JOB, initiates column pivoting. 0, no pivoting is done. nonzero, pivoting is done. */ { int jp; int j; int lup; int maxj; double maxnrm, nrmxl, t, tt; int pl = 1, pu = 0; /* If pivoting is requested, rearrange the columns. */ if (job != 0) { for (j = 1; j <= p; j++) { int swapj = (0 < jpvt[j - 1]); jpvt[j - 1] = (jpvt[j - 1] < 0) ? -j : j; if (swapj) { if (j != pl) dswap(n, a + 0 + (pl - 1)*lda, 1, a + 0 + (j - 1), 1); jpvt[j - 1] = jpvt[pl - 1]; jpvt[pl - 1] = j; pl++; } } pu = p; for (j = p; 1 <= j; j--) { if (jpvt[j - 1] < 0) { jpvt[j - 1] = -jpvt[j - 1]; if (j != pu) { dswap(n, a + 0 + (pu - 1)*lda, 1, a + 0 + (j - 1)*lda, 1); jp = jpvt[pu - 1]; jpvt[pu - 1] = jpvt[j - 1]; jpvt[j - 1] = jp; } pu = pu - 1; } } } /* Compute the norms of the free columns. */ for (j = pl; j <= pu; j++) qraux[j - 1] = dnrm2(n, a + 0 + (j - 1) * lda, 1); for (j = pl; j <= pu; j++) work[j - 1] = qraux[j - 1]; /* Perform the Householder reduction of A. */ lup = i4_min(n, p); for (int l = 1; l <= lup; l++) { /* Bring the column of largest norm into the pivot position. */ if (pl <= l && l < pu) { maxnrm = 0.0; maxj = l; for (j = l; j <= pu; j++) { if (maxnrm < qraux[j - 1]) { maxnrm = qraux[j - 1]; maxj = j; } } if (maxj != l) { dswap(n, a + 0 + (l - 1)*lda, 1, a + 0 + (maxj - 1)*lda, 1); qraux[maxj - 1] = qraux[l - 1]; work[maxj - 1] = work[l - 1]; jp = jpvt[maxj - 1]; jpvt[maxj - 1] = jpvt[l - 1]; jpvt[l - 1] = jp; } } /* Compute the Householder transformation for column L. */ qraux[l - 1] = 0.0; if (l != n) { nrmxl = dnrm2(n - l + 1, a + l - 1 + (l - 1) * lda, 1); if (nrmxl != 0.0) { if (a[l - 1 + (l - 1)*lda] != 0.0) nrmxl = nrmxl * r8_sign(a[l - 1 + (l - 1) * lda]); dscal(n - l + 1, 1.0 / nrmxl, a + l - 1 + (l - 1)*lda, 1); a[l - 1 + (l - 1)*lda] = 1.0 + a[l - 1 + (l - 1) * lda]; /* Apply the transformation to the remaining columns, updating the norms. */ for (j = l + 1; j <= p; j++) { t = -ddot(n - l + 1, a + l - 1 + (l - 1) * lda, 1, a + l - 1 + (j - 1) * lda, 1) / a[l - 1 + (l - 1) * lda]; daxpy(n - l + 1, t, a + l - 1 + (l - 1)*lda, 1, a + l - 1 + (j - 1)*lda, 1); if (pl <= j && j <= pu) { if (qraux[j - 1] != 0.0) { tt = 1.0 - pow(r8_abs(a[l - 1 + (j - 1) * lda]) / qraux[j - 1], 2); tt = r8_max(tt, 0.0); t = tt; tt = 1.0 + 0.05 * tt * pow(qraux[j - 1] / work[j - 1], 2); if (tt != 1.0) qraux[j - 1] = qraux[j - 1] * sqrt(t); else { qraux[j - 1] = dnrm2(n - l, a + l + (j - 1) * lda, 1); work[j - 1] = qraux[j - 1]; } } } } /* Save the transformation. */ qraux[l - 1] = a[l - 1 + (l - 1) * lda]; a[l - 1 + (l - 1)*lda] = -nrmxl; } } } }
void imtqlx ( int n, double d[], double e[], double z[] ) /******************************************************************************/ /* Purpose: IMTQLX diagonalizes a symmetric tridiagonal matrix. Discussion: This routine is a slightly modified version of the EISPACK routine to perform the implicit QL algorithm on a symmetric tridiagonal matrix. The authors thank the authors of EISPACK for permission to use this routine. It has been modified to produce the product Q' * Z, where Z is an input vector and Q is the orthogonal matrix diagonalizing the input matrix. The changes consist (essentially) of applying the orthogonal transformations directly to Z as they are generated. Licensing: This code is distributed under the GNU LGPL license. Modified: 11 January 2010 Author: Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky. C version by John Burkardt. Reference: Sylvan Elhay, Jaroslav Kautsky, Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of Interpolatory Quadrature, ACM Transactions on Mathematical Software, Volume 13, Number 4, December 1987, pages 399-415. Roger Martin, James Wilkinson, The Implicit QL Algorithm, Numerische Mathematik, Volume 12, Number 5, December 1968, pages 377-383. Parameters: Input, int N, the order of the matrix. Input/output, double D(N), the diagonal entries of the matrix. On output, the information in D has been overwritten. Input/output, double E(N), the subdiagonal entries of the matrix, in entries E(1) through E(N-1). On output, the information in E has been overwritten. Input/output, double Z(N). On input, a vector. On output, the value of Q' * Z, where Q is the matrix that diagonalizes the input symmetric tridiagonal matrix. */ { double b; double c; double f; double g; int i; int ii; int itn = 30; int j; int k; int l; int m; int mml; double p; double prec; double r; double s; prec = r8_epsilon ( ); if ( n == 1 ) { return; } e[n-1] = 0.0; for ( l = 1; l <= n; l++ ) { j = 0; for ( ; ; ) { for ( m = l; m <= n; m++ ) { if ( m == n ) { break; } if ( r8_abs ( e[m-1] ) <= prec * ( r8_abs ( d[m-1] ) + r8_abs ( d[m] ) ) ) { break; } } p = d[l-1]; if ( m == l ) { break; } if ( itn <= j ) { printf ( "\n" ); printf ( "IMTQLX - Fatal error!\n" ); printf ( " Iteration limit exceeded\n" ); exit ( 1 ); } j = j + 1; g = ( d[l] - p ) / ( 2.0 * e[l-1] ); r = sqrt ( g * g + 1.0 ); g = d[m-1] - p + e[l-1] / ( g + r8_abs ( r ) * r8_sign ( g ) ); s = 1.0; c = 1.0; p = 0.0; mml = m - l; for ( ii = 1; ii <= mml; ii++ ) { i = m - ii; f = s * e[i-1]; b = c * e[i-1]; if ( r8_abs ( g ) <= r8_abs ( f ) ) { c = g / f; r = sqrt ( c * c + 1.0 ); e[i] = f * r; s = 1.0 / r; c = c * s; } else { s = f / g; r = sqrt ( s * s + 1.0 ); e[i] = g * r; c = 1.0 / r; s = s * c; } g = d[i] - p; r = ( d[i-1] - g ) * s + 2.0 * c * b; p = s * r; d[i] = g + p; g = c * r - b; f = z[i]; z[i] = s * z[i-1] + c * f; z[i-1] = c * z[i-1] - s * f; } d[l-1] = d[l-1] - p; e[l-1] = g; e[m-1] = 0.0; } } /* Sorting. */ for ( ii = 2; ii <= m; ii++ ) { i = ii - 1; k = i; p = d[i-1]; for ( j = ii; j <= n; j++ ) { if ( d[j-1] < p ) { k = j; p = d[j-1]; } } if ( k != i ) { d[k-1] = d[i-1]; d[i-1] = p; p = z[i-1]; z[i-1] = z[k-1]; z[k-1] = p; } } return; }
double local_min_rc ( double &a, double &b, int &status, double value ) //****************************************************************************80 // // Purpose: // // LOCAL_MIN_RC seeks a minimizer of a scalar function of a scalar variable. // // Discussion: // // This routine seeks an approximation to the point where a function // F attains a minimum on the interval (A,B). // // The method used is a combination of golden section search and // successive parabolic interpolation. Convergence is never much // slower than that for a Fibonacci search. If F has a continuous // second derivative which is positive at the minimum (which is not // at A or B), then convergence is superlinear, and usually of the // order of about 1.324... // // The routine is a revised version of the Brent local minimization // algorithm, using reverse communication. // // It is worth stating explicitly that this routine will NOT be // able to detect a minimizer that occurs at either initial endpoint // A or B. If this is a concern to the user, then the user must // either ensure that the initial interval is larger, or to check // the function value at the returned minimizer against the values // at either endpoint. // // Licensing: // // This code is distributed under the GNU LGPL license. // // Modified: // // 17 July 2011 // // Author: // // John Burkardt // // Reference: // // Richard Brent, // Algorithms for Minimization Without Derivatives, // Dover, 2002, // ISBN: 0-486-41998-3, // LC: QA402.5.B74. // // David Kahaner, Cleve Moler, Steven Nash, // Numerical Methods and Software, // Prentice Hall, 1989, // ISBN: 0-13-627258-4, // LC: TA345.K34. // // Parameters // // Input/output, double &A, &B. On input, the left and right // endpoints of the initial interval. On output, the lower and upper // bounds for an interval containing the minimizer. It is required // that A < B. // // Input/output, int &STATUS, used to communicate between // the user and the routine. The user only sets STATUS to zero on the first // call, to indicate that this is a startup call. The routine returns STATUS // positive to request that the function be evaluated at ARG, or returns // STATUS as 0, to indicate that the iteration is complete and that // ARG is the estimated minimizer. // // Input, double VALUE, the function value at ARG, as requested // by the routine on the previous call. // // Output, double LOCAL_MIN_RC, the currently considered point. // On return with STATUS positive, the user is requested to evaluate the // function at this point, and return the value in VALUE. On return with // STATUS zero, this is the routine's estimate for the function minimizer. // // Local parameters: // // C is the squared inverse of the golden ratio. // // EPS is the square root of the relative machine precision. // { static double arg; static double c; static double d; static double e; static double eps; static double fu; static double fv; static double fw; static double fx; static double midpoint; static double p; static double q; static double r; static double tol; static double tol1; static double tol2; static double u; static double v; static double w; static double x; // // STATUS (INPUT) = 0, startup. // if ( status == 0 ) { if ( b <= a ) { cout << "\n"; cout << "LOCAL_MIN_RC - Fatal error!\n"; cout << " A < B is required, but\n"; cout << " A = " << a << "\n"; cout << " B = " << b << "\n"; status = -1; exit ( 1 ); } c = 0.5 * ( 3.0 - sqrt ( 5.0 ) ); eps = sqrt ( r8_epsilon ( ) ); tol = r8_epsilon ( ); v = a + c * ( b - a ); w = v; x = v; e = 0.0; status = 1; arg = x; return arg; } // // STATUS (INPUT) = 1, return with initial function value of FX. // else if ( status == 1 ) { fx = value; fv = fx; fw = fx; } // // STATUS (INPUT) = 2 or more, update the data. // else if ( 2 <= status ) { fu = value; if ( fu <= fx ) { if ( x <= u ) { a = x; } else { b = x; } v = w; fv = fw; w = x; fw = fx; x = u; fx = fu; } else { if ( u < x ) { a = u; } else { b = u; } if ( fu <= fw || w == x ) { v = w; fv = fw; w = u; fw = fu; } else if ( fu <= fv || v == x || v == w ) { v = u; fv = fu; } } } // // Take the next step. // midpoint = 0.5 * ( a + b ); tol1 = eps * r8_abs ( x ) + tol / 3.0; tol2 = 2.0 * tol1; // // If the stopping criterion is satisfied, we can exit. // if ( r8_abs ( x - midpoint ) <= ( tol2 - 0.5 * ( b - a ) ) ) { status = 0; return arg; } // // Is golden-section necessary? // if ( r8_abs ( e ) <= tol1 ) { if ( midpoint <= x ) { e = a - x; } else { e = b - x; } d = c * e; } // // Consider fitting a parabola. // else { r = ( x - w ) * ( fx - fv ); q = ( x - v ) * ( fx - fw ); p = ( x - v ) * q - ( x - w ) * r; q = 2.0 * ( q - r ); if ( 0.0 < q ) { p = - p; } q = r8_abs ( q ); r = e; e = d; // // Choose a golden-section step if the parabola is not advised. // if ( ( r8_abs ( 0.5 * q * r ) <= r8_abs ( p ) ) || ( p <= q * ( a - x ) ) || ( q * ( b - x ) <= p ) ) { if ( midpoint <= x ) { e = a - x; } else { e = b - x; } d = c * e; } // // Choose a parabolic interpolation step. // else { d = p / q; u = x + d; if ( ( u - a ) < tol2 ) { d = tol1 * r8_sign ( midpoint - x ); } if ( ( b - u ) < tol2 ) { d = tol1 * r8_sign ( midpoint - x ); } } } // // F must not be evaluated too close to X. // if ( tol1 <= r8_abs ( d ) ) { u = x + d; } if ( r8_abs ( d ) < tol1 ) { u = x + tol1 * r8_sign ( d ); } // // Request value of F(U). // arg = u; status = status + 1; return arg; }
double local_min_rc ( double *a, double *b, int *status, double value ) /******************************************************************************/ /* Purpose: LOCAL_MIN_RC seeks a minimizer of a scalar function of a scalar variable. Discussion: This routine seeks an approximation to the point where a function F attains a minimum on the interval (A,B). The method used is a combination of golden section search and successive parabolic interpolation. Convergence is never much slower than that for a Fibonacci search. If F has a continuous second derivative which is positive at the minimum (which is not at A or B), then convergence is superlinear, and usually of the order of about 1.324... The routine is a revised version of the Brent local minimization algorithm, using reverse communication. It is worth stating explicitly that this routine will NOT be able to detect a minimizer that occurs at either initial endpoint A or B. If this is a concern to the user, then the user must either ensure that the initial interval is larger, or to check the function value at the returned minimizer against the values at either endpoint. Licensing: This code is distributed under the GNU LGPL license. Modified: 16 April 2008 Author: John Burkardt Reference: Richard Brent, Algorithms for Minimization Without Derivatives, Dover, 2002, ISBN: 0-486-41998-3, LC: QA402.5.B74. David Kahaner, Cleve Moler, Steven Nash, Numerical Methods and Software, Prentice Hall, 1989, ISBN: 0-13-627258-4, LC: TA345.K34. Parameters Input/output, double *A, *B. On input, the left and right endpoints of the initial interval. On output, the lower and upper bounds for an interval containing the minimizer. It is required that A < B. Input/output, int *STATUS, used to communicate between the user and the routine. The user only sets STATUS to zero on the first call, to indicate that this is a startup call. The routine returns STATUS positive to request that the function be evaluated at ARG, or returns STATUS as 0, to indicate that the iteration is complete and that ARG is the estimated minimizer. Input, double VALUE, the function value at ARG, as requested by the routine on the previous call. Output, double LOCAL_MIN_RC, the currently considered point. On return with STATUS positive, the user is requested to evaluate the function at this point, and return the value in VALUE. On return with STATUS zero, this is the routine's estimate for the function minimizer. Local parameters: C is the squared inverse of the golden ratio. EPS is the square root of the relative machine precision. */ { static double arg; static double c; static double d; static double e; static double eps; static double fu; static double fv; static double fw; static double fx; static double midpoint; static double p; static double q; static double r; static double tol; static double tol1; static double tol2; static double u; static double v; static double w; static double x; /* STATUS (INPUT) = 0, startup. */ if ( *status == 0 ) { if ( *b <= *a ) { printf ( "\n" ); printf ( "LOCAL_MIN_RC - Fatal error!\n" ); printf ( " A < B is required, but\n" ); printf ( " A = %f\n", *a ); printf ( " B = %f\n", *b ); *status = -1; exit ( 1 ); } c = 0.5 * ( 3.0 - sqrt ( 5.0 ) ); eps = sqrt ( r8_epsilon ( ) ); tol = r8_epsilon ( ); v = *a + c * ( *b - *a ); w = v; x = v; e = 0.0; *status = 1; arg = x; return arg; } /* STATUS (INPUT) = 1, return with initial function value of FX. */ else if ( *status == 1 ) { fx = value; fv = fx; fw = fx; } /* STATUS (INPUT) = 2 or more, update the data. */ else if ( 2 <= *status ) { fu = value; if ( fu <= fx ) { if ( x <= u ) { *a = x; } else { *b = x; } v = w; fv = fw; w = x; fw = fx; x = u; fx = fu; } else { if ( u < x ) { *a = u; } else { *b = u; } if ( fu <= fw || w == x ) { v = w; fv = fw; w = u; fw = fu; } else if ( fu <= fv || v == x || v == w ) { v = u; fv = fu; } } } /* Take the next step. */ midpoint = 0.5 * ( *a + *b ); tol1 = eps * r8_abs ( x ) + tol / 3.0; tol2 = 2.0 * tol1; /* If the stopping criterion is satisfied, we can exit. */ if ( r8_abs ( x - midpoint ) <= ( tol2 - 0.5 * ( *b - *a ) ) ) { *status = 0; return arg; } /* Is golden-section necessary? */ if ( r8_abs ( e ) <= tol1 ) { if ( midpoint <= x ) { e = *a - x; } else { e = *b - x; } d = c * e; } /* Consider fitting a parabola. */ else { r = ( x - w ) * ( fx - fv ); q = ( x - v ) * ( fx - fw ); p = ( x - v ) * q - ( x - w ) * r; q = 2.0 * ( q - r ); if ( 0.0 < q ) { p = - p; } q = r8_abs ( q ); r = e; e = d; /* Choose a golden-section step if the parabola is not advised. */ if ( ( r8_abs ( 0.5 * q * r ) <= r8_abs ( p ) ) || ( p <= q * ( *a - x ) ) || ( q * ( *b - x ) <= p ) ) { if ( midpoint <= x ) { e = *a - x; } else { e = *b - x; } d = c * e; } /* Choose a parabolic interpolation step. */ else { d = p / q; u = x + d; if ( ( u - *a ) < tol2 ) { d = tol1 * r8_sign ( midpoint - x ); } if ( ( *b - u ) < tol2 ) { d = tol1 * r8_sign ( midpoint - x ); } } } /* F must not be evaluated too close to X. */ if ( tol1 <= r8_abs ( d ) ) { u = x + d; } if ( r8_abs ( d ) < tol1 ) { u = x + tol1 * r8_sign ( d ); } /* Request value of F(U). */ arg = u; *status = *status + 1; return arg; }
double *r8vec_house_column ( int n, double a[], int k ) /******************************************************************************/ /* Purpose: R8VEC_HOUSE_COLUMN defines a Householder premultiplier that "packs" a column. Discussion: An R8VEC is a vector of R8's. The routine returns a vector V that defines a Householder premultiplier matrix H(V) that zeros out the subdiagonal entries of column K of the matrix A. H(V) = I - 2 * v * v' Licensing: This code is distributed under the GNU LGPL license. Modified: 21 August 2010 Author: John Burkardt Parameters: Input, int N, the order of the matrix A. Input, double A[N], column K of the matrix A. Input, int K, the column of the matrix to be modified. Output, double R8VEC_HOUSE_COLUMN[N], a vector of unit L2 norm which defines an orthogonal Householder premultiplier matrix H with the property that the K-th column of H*A is zero below the diagonal. */ { int i; double s; double *v; v = r8vec_zero_new ( n ); if ( k < 1 || n <= k ) { return v; } s = r8vec_norm_l2 ( n+1-k, a+k-1 ); if ( s == 0.0 ) { return v; } v[k-1] = a[k-1] + r8_abs ( s ) * r8_sign ( a[k-1] ); r8vec_copy ( n-k, a+k, v+k ); s = r8vec_norm_l2 ( n-k+1, v+k-1 ); for ( i = k-1; i < n; i++ ) { v[i] = v[i] / s; } return v; }