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;
}
