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 j;
int jp;
int l;
int lup;
int maxj;
double maxnrm;
double nrmxl;
int pl;
int pu;
int swapj;
double t;
double tt;
pl = 1;
pu = 0;
/*
If pivoting is requested, rearrange the columns.
*/
if ( job != 0 )
{
for ( j = 1; j <= p; j++ )
{
swapj = ( 0 < jpvt[j-1] );
if ( jpvt[j-1] < 0 )
{
jpvt[j-1] = -j;
}
else
{
jpvt[j-1] = 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 = pl + 1;
}
}
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 ( 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;
}
}
}
return;
}
double glomin ( double a, double b, double c, double m, double machep,
double e, double t, double f ( double x ), double *x )
/******************************************************************************/
/*
Purpose:
GLOMIN seeks a global minimum of a function F(X) in an interval [A,B].
Discussion:
This function assumes that F(X) is twice continuously differentiable
over [A,B] and that F''(X) <= M for all X in [A,B].
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
17 April 2008
Author:
Original FORTRAN77 version by Richard Brent.
C version by John Burkardt.
Reference:
Richard Brent,
Algorithms for Minimization Without Derivatives,
Dover, 2002,
ISBN: 0-486-41998-3,
LC: QA402.5.B74.
Parameters:
Input, double A, B, the endpoints of the interval.
It must be the case that A < B.
Input, double C, an initial guess for the global
minimizer. If no good guess is known, C = A or B is acceptable.
Input, double M, the bound on the second derivative.
Input, double MACHEP, an estimate for the relative machine
precision.
Input, double E, a positive tolerance, a bound for the
absolute error in the evaluation of F(X) for any X in [A,B].
Input, double T, a positive error tolerance.
Input, double F ( double x ), a user-supplied
function whose global minimum is being sought.
Output, double *X, the estimated value of the abscissa
for which F attains its global minimum value in [A,B].
Output, double GLOMIN, the value F(X).
*/
{
double a0;
double a2;
double a3;
double d0;
double d1;
double d2;
double h;
int k;
double m2;
double p;
double q;
double qs;
double r;
double s;
double sc;
double y;
double y0;
double y1;
double y2;
double y3;
double yb;
double z0;
double z1;
double z2;
a0 = b;
*x = a0;
a2 = a;
y0 = f ( b );
yb = y0;
y2 = f ( a );
y = y2;
if ( y0 < y )
{
y = y0;
}
else
{
*x = a;
}
if ( m <= 0.0 || b <= a )
{
return y;
}
m2 = 0.5 * ( 1.0 + 16.0 * machep ) * m;
if ( c <= a || b <= c )
{
sc = 0.5 * ( a + b );
}
else
{
sc = c;
}
y1 = f ( sc );
k = 3;
d0 = a2 - sc;
h = 9.0 / 11.0;
if ( y1 < y )
{
*x = sc;
y = y1;
}
for ( ; ; )
{
d1 = a2 - a0;
d2 = sc - a0;
z2 = b - a2;
z0 = y2 - y1;
z1 = y2 - y0;
r = d1 * d1 * z0 - d0 * d0 * z1;
p = r;
qs = 2.0 * ( d0 * z1 - d1 * z0 );
q = qs;
if ( k < 1000000 || y2 <= y )
{
for ( ; ; )
{
if ( q * ( r * ( yb - y2 ) + z2 * q * ( ( y2 - y ) + t ) ) <
z2 * m2 * r * ( z2 * q - r ) )
{
a3 = a2 + r / q;
y3 = f ( a3 );
if ( y3 < y )
{
*x = a3;
y = y3;
}
}
k = ( ( 1611 * k ) % 1048576 );
q = 1.0;
r = ( b - a ) * 0.00001 * ( double ) ( k );
if ( z2 <= r )
{
break;
}
}
}
else
{
k = ( ( 1611 * k ) % 1048576 );
q = 1.0;
r = ( b - a ) * 0.00001 * ( double ) ( k );
while ( r < z2 )
{
if ( q * ( r * ( yb - y2 ) + z2 * q * ( ( y2 - y ) + t ) ) <
z2 * m2 * r * ( z2 * q - r ) )
{
a3 = a2 + r / q;
y3 = f ( a3 );
if ( y3 < y )
{
*x = a3;
y = y3;
}
}
k = ( ( 1611 * k ) % 1048576 );
q = 1.0;
r = ( b - a ) * 0.00001 * ( double ) ( k );
}
}
r = m2 * d0 * d1 * d2;
s = sqrt ( ( ( y2 - y ) + t ) / m2 );
h = 0.5 * ( 1.0 + h );
p = h * ( p + 2.0 * r * s );
q = q + 0.5 * qs;
r = - 0.5 * ( d0 + ( z0 + 2.01 * e ) / ( d0 * m2 ) );
if ( r < s || d0 < 0.0 )
{
r = a2 + s;
}
else
{
r = a2 + r;
}
if ( 0.0 < p * q )
{
a3 = a2 + p / q;
}
else
{
a3 = r;
}
for ( ; ; )
{
a3 = r8_max ( a3, r );
if ( b <= a3 )
{
a3 = b;
y3 = yb;
}
else
{
y3 = f ( a3 );
}
if ( y3 < y )
{
*x = a3;
y = y3;
}
d0 = a3 - a2;
if ( a3 <= r )
{
break;
}
p = 2.0 * ( y2 - y3 ) / ( m * d0 );
if ( ( 1.0 + 9.0 * machep ) * d0 <= r8_abs ( p ) )
{
break;
}
if ( 0.5 * m2 * ( d0 * d0 + p * p ) <= ( y2 - y ) + ( y3 - y ) + 2.0 * t )
{
break;
}
a3 = 0.5 * ( a2 + a3 );
h = 0.9 * h;
}
if ( b <= a3 )
{
break;
}
a0 = sc;
sc = a2;
a2 = a3;
y0 = y1;
y1 = y2;
y2 = y3;
}
return y;
}
void gmsh_size_read ( char *gmsh_filename, int *node_num, int *node_dim,
int *element_num, int *element_order )
/******************************************************************************/
/*
Purpose:
GMSH_SIZE_READ reads sizes from a GMSH file.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
19 October 2014
Author:
John Burkardt
Parameters:
Input, character *GMSH_FILENAME, the GMSH filename.
Output, int *NODE_NUM, the number of nodes.
Output, int *NODE_DIM, the spatial dimension.
Output, int *ELEMENT_NUM, the number of elements.
Output, int *ELEMENT_ORDER, the order of the elements.
*/
{
char *error;
int ierror;
int indx;
FILE *input;
int input_stat;
int k;
int length;
int level;
const double r8_big = 1.0E+30;
char text[255];
char* text_pointer;
double x;
double x_max;
double x_min;
double y;
double y_max;
double y_min;
double z;
double z_max;
double z_min;
*node_num = 0;
*node_dim = 0;
x_max = - r8_big;
x_min = + r8_big;
y_max = - r8_big;
y_min = + r8_big;
z_max = - r8_big;
z_min = + r8_big;
input = fopen ( gmsh_filename, "rt" );
if ( ! input )
{
fprintf ( stderr, "\n" );
fprintf ( stderr, "GMSH_SIZE_READ - Fatal error!\n" );
fprintf ( stderr, " Could not open input file \"%s\"\n", gmsh_filename );
exit ( 1 );
}
level = 0;
for ( ; ; )
{
text_pointer = text;
error = fgets ( text_pointer, 255, input );
if ( !error )
{
break;
}
if ( level == 0 )
{
if ( s_begin ( text_pointer, "$Nodes" ) )
{
level = 1;
}
}
else if ( level == 1 )
{
*node_num = s_to_i4 ( text_pointer, &length, &ierror );
level = 2;
}
else if ( level == 2 )
{
if ( s_begin ( text_pointer, "$EndNodes" ) )
{
break;
}
else
{
indx = s_to_i4 ( text_pointer, &length, &ierror );
text_pointer = text_pointer + length;
x = s_to_r8 ( text_pointer, &length, &ierror );
x_min = r8_min ( x_min, x );
x_max = r8_max ( x_max, x );
text_pointer = text_pointer + length;
y = s_to_r8 ( text_pointer, &length, &ierror );
y_min = r8_min ( y_min, y );
y_max = r8_max ( y_max, y );
text_pointer = text_pointer + length;
z = s_to_r8 ( text_pointer, &length, &ierror);
text_pointer = text_pointer + length;
z_min = r8_min ( z_min, z );
z_max = r8_max ( z_max, z );
}
}
}
/*
Make a very simple guess as to the dimensionality of the data.
*/
*node_dim = 3;
if ( z_max == z_min )
{
*node_dim = 2;
if ( y_max == y_min )
{
*node_dim = 1;
}
}
/*
Now read element information.
*/
level = 0;
for ( ; ; )
{
text_pointer = text;
error = fgets ( text_pointer, 255, input );
if ( !error )
{
break;
}
if ( level == 0 )
{
if ( s_begin ( text_pointer, "$Elements" ) )
{
level = 1;
}
}
else if ( level == 1 )
{
*element_num = s_to_i4 ( text_pointer, &length, &ierror );
level = 2;
}
else if ( level == 2 )
{
if ( s_begin ( text_pointer, "$EndElements" ) )
{
break;
}
else
{
k = 0;
for ( ; ; )
{
indx = s_to_i4 ( text_pointer, &length, &ierror );
text_pointer = text_pointer + length;
if ( ierror != 0 )
{
break;
}
k = k + 1;
}
*element_order = k - 5;
break;
}
}
}
fclose ( input );
return;
}
void test10 ( )
/****************************************************************************/
/*
Purpose:
TEST10 compares a function and projection over [A,B].
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
09 August 2013
Author:
John Burkardt
*/
{
double a;
double b;
double *c;
int i;
int m;
int n;
double r;
double *v;
double *x;
printf ( "\n" );
printf ( "TEST10:\n" );
printf ( " T_PROJECT_COEFFICIENTS_AB computes the Chebyshev interpolant C(F)(n,x)\n" );
printf ( " of a function F(x) defined over [A,B].\n" );
printf ( " T_PROJECT_VALUE_AB evaluates that projection.\n" );
a = 0.0;
b = 1.5;
printf ( "\n" );
printf ( " Compute projections of order N to exp(x) over [%g,%g]\n", a, b );
printf ( "\n" );
printf ( " N Max||F(x)-C(F)(n,x)||\n" );
printf ( "\n" );
for ( n = 0; n <= 10; n++ )
{
c = t_project_coefficients_ab ( n, exp, a, b );
m = 101;
x = r8vec_linspace_new ( m, a, b );
v = t_project_value_ab ( m, n, x, c, a, b );
r = 0.0;
for ( i = 0; i < m; i++ )
{
r = r8_max ( r, r8_abs ( v[i] - exp ( x[i] ) ) );
}
printf ( " %2d %14g\n", n, r );
free ( c );
free ( v );
free ( x );
}
return;
}
void test04 ( )
/******************************************************************************/
/*
Purpose:
TEST04 tests BERNSTEIN_POLY_AB_APPROX.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
11 February 2012
Author:
John Burkardt
*/
{
double a;
double b;
double error_max;
int i;
int maxdata = 20;
int ndata;
int nsample;
int nval = 501;
double *xdata;
double *xval;
double *ydata;
double *yval;
printf ( "\n" );
printf ( "TEST04\n" );
printf ( " BERNSTEIN_POLY_AB_APPROX evaluates the Bernstein polynomial\n" );
printf ( " approximant to a function F(X).\n" );
a = 1.0;
b = 3.0;
printf ( "\n" );
printf ( " N Max Error\n" );
printf ( "\n" );
for ( ndata = 0; ndata <= maxdata; ndata++ )
{
/*
Generate data values.
*/
xdata = ( double * ) malloc ( ( ndata + 1 ) * sizeof ( double ) );
ydata = ( double * ) malloc ( ( ndata + 1 ) * sizeof ( double ) );
for ( i = 0; i <= ndata; i++)
{
if ( ndata == 0 )
{
xdata[i] = 0.5 * ( a + b );
}
else
{
xdata[i] = ( ( double ) ( ndata - i ) * a
+ ( double ) ( i ) * b )
/ ( double ) ( ndata );
}
ydata[i] = sin ( xdata[i] );
}
/*
Compare the true function and the approximant.
*/
xval = r8vec_linspace_new ( nval, a, b );
error_max = 0.0;
yval = bernstein_poly_ab_approx ( ndata, a, b, ydata, nval, xval );
error_max = 0.0;
for ( i = 0; i < nval; i++ )
{
error_max = r8_max ( error_max, r8_abs ( yval[i] - sin ( xval[i] ) ) );
}
printf ( " %4d %14g\n", ndata, error_max );
free ( xdata );
free ( xval );
free ( ydata );
free ( yval );
}
return;
}
