void qr_solve(double x[], int m, int n, double a[], double b[])
/******************************************************************************/
/*
Purpose:
QR_SOLVE solves a linear system in the least squares sense.
Discussion:
If the matrix A has full column rank, then the solution X should be the
unique vector that minimizes the Euclidean norm of the residual.
If the matrix A does not have full column rank, then the solution is
not unique; the vector X will minimize the residual norm, but so will
various other vectors.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
11 September 2012
Author:
John Burkardt
Reference:
David Kahaner, Cleve Moler, Steven Nash,
Numerical Methods and Software,
Prentice Hall, 1989,
ISBN: 0-13-627258-4,
LC: TA345.K34.
Parameters:
Input, int M, the number of rows of A.
Input, int N, the number of columns of A.
Input, double A[M*N], the matrix.
Input, double B[M], the right hand side.
Output, double QR_SOLVE[N], the least squares solution.
*/
{
double a_qr[n * m], qraux[n], r[m], tol;
int ind, itask, jpvt[n], kr, lda;
r8mat_copy(a_qr, m, n, a);
lda = m;
tol = r8_epsilon() / r8mat_amax(m, n, a_qr);
itask = 1;
ind = dqrls(a_qr, lda, m, n, tol, &kr, b, x, r, jpvt, qraux, itask); UNUSED(ind);
}
int lrline ( double xu, double yu, double xv1, double yv1, double xv2, double yv2, double dv )
{
double dx;
double dxu;
double dy;
double dyu;
double t;
double tol;
double tolabs;
int value;
tol = 100.0 * r8_epsilon ( );
dx = xv2 - xv1;
dy = yv2 - yv1;
dxu = xu - xv1;
dyu = yu - yv1;
tolabs = tol * r8_max ( fabs ( dx ), r8_max ( fabs ( dy ), r8_max ( fabs ( dxu ), r8_max ( fabs ( dyu ), fabs ( dv ) ) ) ) );
t = dy * dxu - dx * dyu + dv * sqrt ( dx * dx + dy * dy );
if ( tolabs < t )
{
value = 1;
}
else if ( -tolabs <= t )
{
value = 0;
}
else if ( t < -tolabs )
{
value = -1;
}
return value;
}
static void optimize_leaf_nodes(const ml_instance_definition &mlid, boosted_loss_func loss_func, decision_tree &tree) {
ml_vector<dt_node_ptr> leaf_nodes;
gather_leaf_nodes(leaf_nodes, tree);
double eps = sqrt(r8_epsilon());
for(auto &leaf_ptr : leaf_nodes) {
//
// use custom loss function if given, otherwise defaults to squared error loss
//
if(loss_func) {
leaf_opt_helper help;
help.instances = &leaf_ptr->leaf_instances;
help.mlid = &mlid;
help.loss_func = loss_func;
double optimal = 0.0;
double upper = leaf_ptr->feature_value.continuous_value * 100.0;
double lower = upper * -1.0;
if(lower > upper) {
std::swap(lower, upper);
}
//puml::log("optimize: leaf before %.3f, ", leaf_ptr->feature_value.continuous_value);
local_min(lower, upper, eps, eps, leaf_optimization, &help, &optimal);
leaf_ptr->feature_value.continuous_value = optimal;
//puml::log(" after %.3f\n", leaf_ptr->feature_value.continuous_value);
}
// empty the leaf instances vector. we only kept them around for this optimization step
leaf_ptr->leaf_instances.clear();
leaf_ptr->leaf_instances.shrink_to_fit();
}
}
double class_matrix ( int kind, int m, double alpha, double beta, double aj[],
double bj[] )
/******************************************************************************/
/*
Purpose:
CLASS_MATRIX computes the Jacobi matrix for a quadrature rule.
Discussion:
This routine computes the diagonal AJ and sub-diagonal BJ
elements of the order M tridiagonal symmetric Jacobi matrix
associated with the polynomials orthogonal with respect to
the weight function specified by KIND.
For weight functions 1-7, M elements are defined in BJ even
though only M-1 are needed. For weight function 8, BJ(M) is
set to zero.
The zero-th moment of the weight function is returned in ZEMU.
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.
Parameters:
Input, int KIND, the rule.
1, Legendre, (a,b) 1.0
2, Chebyshev Type 1, (a,b) ((b-x)*(x-a))^(-0.5)
3, Gegenbauer, (a,b) ((b-x)*(x-a))^alpha
4, Jacobi, (a,b) (b-x)^alpha*(x-a)^beta
5, Generalized Laguerre, (a,inf) (x-a)^alpha*exp(-b*(x-a))
6, Generalized Hermite, (-inf,inf) |x-a|^alpha*exp(-b*(x-a)^2)
7, Exponential, (a,b) |x-(a+b)/2.0|^alpha
8, Rational, (a,inf) (x-a)^alpha*(x+b)^beta
Input, int M, the order of the Jacobi matrix.
Input, double ALPHA, the value of Alpha, if needed.
Input, double BETA, the value of Beta, if needed.
Output, double AJ[M], BJ[M], the diagonal and subdiagonal
of the Jacobi matrix.
Output, double CLASS_MATRIX, the zero-th moment.
*/
{
double a2b2;
double ab;
double aba;
double abi;
double abj;
double abti;
double apone;
int i;
const double pi = 3.14159265358979323846264338327950;
double temp;
double temp2;
double zemu;
temp = r8_epsilon ( );
parchk ( kind, 2 * m - 1, alpha, beta );
temp2 = 0.5;
if ( 500.0 * temp < r8_abs ( pow ( r8_gamma ( temp2 ), 2 ) - pi ) )
{
printf ( "\n" );
printf ( "CLASS_MATRIX - Fatal error!\n" );
printf ( " Gamma function does not match machine parameters.\n" );
exit ( 1 );
}
if ( kind == 1 )
{
ab = 0.0;
zemu = 2.0 / ( ab + 1.0 );
for ( i = 0; i < m; i++ )
{
aj[i] = 0.0;
}
for ( i = 1; i <= m; i++ )
{
abi = i + ab * ( i % 2 );
abj = 2 * i + ab;
bj[i-1] = sqrt ( abi * abi / ( abj * abj - 1.0 ) );
}
}
else if ( kind == 2 )
{
zemu = pi;
for ( i = 0; i < m; i++ )
{
aj[i] = 0.0;
}
bj[0] = sqrt ( 0.5 );
for ( i = 1; i < m; i++ )
{
bj[i] = 0.5;
}
}
else if ( kind == 3 )
{
ab = alpha * 2.0;
zemu = pow ( 2.0, ab + 1.0 ) * pow ( r8_gamma ( alpha + 1.0 ), 2 )
/ r8_gamma ( ab + 2.0 );
for ( i = 0; i < m; i++ )
{
aj[i] = 0.0;
}
bj[0] = sqrt ( 1.0 / ( 2.0 * alpha + 3.0 ) );
for ( i = 2; i <= m; i++ )
{
bj[i-1] = sqrt ( i * ( i + ab ) / ( 4.0 * pow ( i + alpha, 2 ) - 1.0 ) );
}
}
else if ( kind == 4 )
{
ab = alpha + beta;
abi = 2.0 + ab;
zemu = pow ( 2.0, ab + 1.0 ) * r8_gamma ( alpha + 1.0 )
* r8_gamma ( beta + 1.0 ) / r8_gamma ( abi );
aj[0] = ( beta - alpha ) / abi;
bj[0] = sqrt ( 4.0 * ( 1.0 + alpha ) * ( 1.0 + beta )
/ ( ( abi + 1.0 ) * abi * abi ) );
a2b2 = beta * beta - alpha * alpha;
for ( i = 2; i <= m; i++ )
{
abi = 2.0 * i + ab;
aj[i-1] = a2b2 / ( ( abi - 2.0 ) * abi );
abi = abi * abi;
bj[i-1] = sqrt ( 4.0 * i * ( i + alpha ) * ( i + beta ) * ( i + ab )
/ ( ( abi - 1.0 ) * abi ) );
}
}
else if ( kind == 5 )
{
zemu = r8_gamma ( alpha + 1.0 );
for ( i = 1; i <= m; i++ )
{
aj[i-1] = 2.0 * i - 1.0 + alpha;
bj[i-1] = sqrt ( i * ( i + alpha ) );
}
}
else if ( kind == 6 )
{
zemu = r8_gamma ( ( alpha + 1.0 ) / 2.0 );
for ( i = 0; i < m; i++ )
{
aj[i] = 0.0;
}
for ( i = 1; i <= m; i++ )
{
bj[i-1] = sqrt ( ( i + alpha * ( i % 2 ) ) / 2.0 );
}
}
else if ( kind == 7 )
{
ab = alpha;
zemu = 2.0 / ( ab + 1.0 );
for ( i = 0; i < m; i++ )
{
aj[i] = 0.0;
}
for ( i = 1; i <= m; i++ )
{
abi = i + ab * ( i % 2 );
abj = 2 * i + ab;
bj[i-1] = sqrt ( abi * abi / ( abj * abj - 1.0 ) );
}
}
else if ( kind == 8 )
{
ab = alpha + beta;
zemu = r8_gamma ( alpha + 1.0 ) * r8_gamma ( - ( ab + 1.0 ) )
/ r8_gamma ( - beta );
apone = alpha + 1.0;
aba = ab * apone;
aj[0] = - apone / ( ab + 2.0 );
bj[0] = - aj[0] * ( beta + 1.0 ) / ( ab + 2.0 ) / ( ab + 3.0 );
for ( i = 2; i <= m; i++ )
{
abti = ab + 2.0 * i;
aj[i-1] = aba + 2.0 * ( ab + i ) * ( i - 1 );
aj[i-1] = - aj[i-1] / abti / ( abti - 2.0 );
}
for ( i = 2; i <= m - 1; i++ )
{
abti = ab + 2.0 * i;
bj[i-1] = i * ( alpha + i ) / ( abti - 1.0 ) * ( beta + i )
/ ( abti * abti ) * ( ab + i ) / ( abti + 1.0 );
}
bj[m-1] = 0.0;
for ( i = 0; i < m; i++ )
{
bj[i] = sqrt ( bj[i] );
}
}
else
{
printf ( "\n" );
printf ( "CLASS_MATRIX - Fatal error!\n" );
printf ( " Illegal value of KIND = %d.\n", kind );
exit ( 1 );
}
return zemu;
}
void scqf ( int nt, double t[], int mlt[], double wts[], int nwts, int ndx[],
double swts[], double st[], int kind, double alpha, double beta, double a,
double b )
/******************************************************************************/
/*
Purpose:
SCQF scales a quadrature formula to a nonstandard interval.
Discussion:
The arrays WTS and SWTS may coincide.
The arrays T and ST may coincide.
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.
Parameters:
Input, int NT, the number of knots.
Input, double T[NT], the original knots.
Input, int MLT[NT], the multiplicity of the knots.
Input, double WTS[NWTS], the weights.
Input, int NWTS, the number of weights.
Input, int NDX[NT], used to index the array WTS.
For more details see the comments in CAWIQ.
Output, double SWTS[NWTS], the scaled weights.
Output, double ST[NT], the scaled knots.
Input, int KIND, the rule.
1, Legendre, (a,b) 1.0
2, Chebyshev Type 1, (a,b) ((b-x)*(x-a))^(-0.5)
3, Gegenbauer, (a,b) ((b-x)*(x-a))^alpha
4, Jacobi, (a,b) (b-x)^alpha*(x-a)^beta
5, Generalized Laguerre, (a,inf) (x-a)^alpha*exp(-b*(x-a))
6, Generalized Hermite, (-inf,inf) |x-a|^alpha*exp(-b*(x-a)^2)
7, Exponential, (a,b) |x-(a+b)/2.0|^alpha
8, Rational, (a,inf) (x-a)^alpha*(x+b)^beta
Input, double ALPHA, the value of Alpha, if needed.
Input, double BETA, the value of Beta, if needed.
Input, double A, B, the interval endpoints.
*/
{
double al;
double be;
int i;
int k;
int l;
double p;
double shft;
double slp;
double temp;
double tmp;
temp = r8_epsilon ( );
parchk ( kind, 1, alpha, beta );
if ( kind == 1 )
{
al = 0.0;
be = 0.0;
if ( ( b - a ) <= temp )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B - A too small.\n" );
exit ( 1 );
}
shft = ( a + b ) / 2.0;
slp = ( b - a ) / 2.0;
}
else if ( kind == 2 )
{
al = -0.5;
be = -0.5;
if ( ( b - a ) <= temp )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B - A too small.\n" );
exit ( 1 );
}
shft = ( a + b ) / 2.0;
slp = ( b - a ) / 2.0;
}
else if ( kind == 3 )
{
al = alpha;
be = alpha;
if ( ( b - a ) <= temp )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B - A too small.\n" );
exit ( 1 );
}
shft = ( a + b ) / 2.0;
slp = ( b - a ) / 2.0;
}
else if ( kind == 4 )
{
al = alpha;
be = beta;
if ( ( b - a ) <= temp )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B - A too small.\n" );
exit ( 1 );
}
shft = ( a + b ) / 2.0;
slp = ( b - a ) / 2.0;
}
else if ( kind == 5 )
{
if ( b <= 0.0 )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B <= 0\n" );
exit ( 1 );
}
shft = a;
slp = 1.0 / b;
al = alpha;
be = 0.0;
}
else if ( kind == 6 )
{
if ( b <= 0.0 )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B <= 0.\n" );
exit ( 1 );
}
shft = a;
slp = 1.0 / sqrt ( b );
al = alpha;
be = 0.0;
}
else if ( kind == 7 )
{
al = alpha;
be = 0.0;
if ( ( b - a ) <= temp )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " B - A too small.\n" );
exit ( 1 );
}
shft = ( a + b ) / 2.0;
slp = ( b - a ) / 2.0;
}
else if ( kind == 8 )
{
if ( a + b <= 0.0 )
{
printf ( "\n" );
printf ( "SCQF - Fatal error!\n" );
printf ( " A + B <= 0.\n" );
exit ( 1 );
}
shft = a;
slp = a + b;
al = alpha;
be = beta;
}
p = pow ( slp, al + be + 1.0 );
for ( k = 0; k < nt; k++ )
{
st[k] = shft + slp * t[k];
l = abs ( ndx[k] );
if ( l != 0 )
{
tmp = p;
for ( i = l - 1; i <= l - 1 + mlt[k] - 1; i++ )
{
swts[i] = wts[i] * tmp;
tmp = tmp * slp;
}
}
}
return;
}
void sgmga_point_tests ( void )
/******************************************************************************/
/*
Purpose:
SGMGA_POINT_TESTS calls SGMGA_POINT_TEST.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
27 November 2009
Author:
John Burkardt
Local Parameters:
Local, double TOL, a tolerance for point equality.
A value of sqrt ( eps ) is reasonable, and will allow the code to
consolidate points which are equal, or very nearly so. A value of
-1.0, on the other hand, will force the code to use every point,
regardless of duplication.
*/
{
int dim;
int dim_num;
GWPointer *gw_compute_points;
double *importance;
int level_max_max;
int level_max_min;
double *level_weight;
int *np;
int np_sum;
int *order_1d;
int order_nd;
double *p;
int *rule;
double tol;
printf ( "\n" );
printf ( "SGMGA_POINT_TESTS\n" );
printf ( " Call SGMGA_POINT_TEST with various arguments.\n" );
/*
Set the point equality tolerance.
*/
tol = sqrt ( r8_epsilon ( ) );
printf ( "\n" );
printf ( " All tests will use a point equality tolerance of %e\n", tol );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = 1.0;
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = 1.0;
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
rule[2] = 1;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_points[2] = clenshaw_curtis_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
rule[2] = 1;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_points[2] = clenshaw_curtis_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 3;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = patterson_lookup_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 4;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 7;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = laguerre_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 1;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 1.5;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 8;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = gen_laguerre_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 2;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 0.5;
p[1] = 1.5;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 2;
rule[1] = 9;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = fejer2_compute_points_np;
gw_compute_points[1] = jacobi_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 1;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 2.0;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 6;
rule[1] = 4;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = gen_hermite_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 4;
rule[2] = 5;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
gw_compute_points[2] = hermite_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
Repeat, treating rules #2 and #3 as Golub Welsch rules.
*/
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 2;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 10;
rule[2] = 10;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
gw_compute_points[2] = hermite_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
Look at a case of interest to Mike.
*/
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim_num - dim );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 5;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 5;
rule[1] = 5;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = hermite_compute_points_np;
gw_compute_points[1] = hermite_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
Look at a case that includes a "0" importance dimension.
*/
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
importance[0] = 1.0;
importance[1] = 0.0;
importance[2] = 1.0;
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max_min = 0;
level_max_max = 3;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
rule[2] = 1;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_points[2] = clenshaw_curtis_compute_points_np;
sgmga_point_test ( dim_num, importance, level_weight, level_max_min,
level_max_max, rule, np, p, gw_compute_points, tol );
free ( gw_compute_points );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
return;
}
double piecewise_linear_product_integral ( double a, double b, int f_num,
double f_x[], double f_v[], int g_num, double g_x[], double g_v[] )
/******************************************************************************/
/*
Purpose:
PIECEWISE_LINEAR_PRODUCT_INTEGRAL: piecewise linear product integral.
Discussion:
We are given two piecewise linear functions F(X) and G(X) and we wish
to compute the exact value of the integral
INTEGRAL = Integral ( A <= X <= B ) F(X) * G(X) dx
The functions F(X) and G(X) are defined as tables of coordinates X and
values V. A piecewise linear function is evaluated at a point X by
evaluating the interpolant to the data at the endpoints of the interval
containing X.
It must be the case that A <= B.
It must be the case that the node coordinates F_X(*) and G_X(*) are
given in ascending order.
It must be the case that:
F_X(1) <= A and B <= F_X(F_NUM)
G_X(1) <= A and B <= G_X(G_NUM)
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
04 July 2013
Author:
John Burkardt
Parameters:
Input, double A, B, the limits of integration.
Input, int F_NUM, the number of nodes for F.
Input, double F_X[F_NUM], the node coordinates for F.
Input, double F_V[F_NUM], the nodal values for F.
Input, int G_NUM, the number of nodes for G.
Input, double G_X[G_NUM], the node coordinates for G.
Input, double G_V[G_NUM], the nodal values for G.
Output, double INTEGRAL, the integral of F(X) * G(X)
from A to B.
*/
{
double bit;
int f_left;
double f0;
double f1;
double fl;
double fr;
int g_left;
double g0;
double g1;
double gl;
double gr;
double h0;
double h1;
double h2;
int i;
double integral;
double xl;
double xr;
double xr_max;
integral = 0.0;
if ( f_x[f_num-1] <= a || g_x[g_num-1] <= a )
{
return integral;
}
if ( f_num < 2 || g_num < 2 )
{
return integral;
}
xr = a;
f_left = 0;
r8vec_bracket3 ( f_num, f_x, xr, &f_left );
fr = f_v[f_left] + ( xr - f_x[f_left] ) * ( f_v[f_left+1] - f_v[f_left] )
/ ( f_x[f_left+1] - f_x[f_left] );
g_left = 0;
r8vec_bracket3 ( g_num, g_x, xr, &g_left );
gr = g_v[g_left] + ( xr - g_x[g_left] ) * ( g_v[g_left+1] - g_v[g_left] )
/ ( g_x[g_left+1] - g_x[g_left] );
xr_max = b;
xr_max = r8_min ( xr_max, f_x[f_num-1] );
xr_max = r8_min ( xr_max, g_x[g_num-1] );
while ( xr < xr_max )
{
/*
Shift right values to left.
*/
xl = xr;
fl = fr;
gl = gr;
/*
Determine the new right values.
The hard part is figuring out how to advance XR some, but not too much.
*/
xr = xr_max;
for ( i = 1; i <= 2; i++ )
{
if ( f_left + i <= f_num - 1 )
{
if ( xl < f_x[f_left+i] && f_x[f_left+i] < xr )
{
xr = f_x[f_left+i];
break;
}
}
}
for ( i = 1; i <= 2; i++ )
{
if ( g_left + i <= g_num - 1 )
{
if ( xl < g_x[g_left+i] && g_x[g_left+i] < xr )
{
xr = g_x[g_left+i];
break;
}
}
}
r8vec_bracket3 ( f_num, f_x, xr, &f_left );
fr = f_v[f_left] + ( xr - f_x[f_left] ) * ( f_v[f_left+1] - f_v[f_left] )
/ ( f_x[f_left+1] - f_x[f_left] );
r8vec_bracket3 ( g_num, g_x, xr, &g_left );
gr = g_v[g_left] + ( xr - g_x[g_left] ) * ( g_v[g_left+1] - g_v[g_left] )
/ ( g_x[g_left+1] - g_x[g_left] );
/*
Form the linear polynomials for F(X) and G(X) over [XL,XR],
then the product H(X), integrate H(X) and add to the running total.
*/
if ( r8_epsilon ( ) <= r8_abs ( xr - xl ) )
{
f1 = fl - fr;
f0 = fr * xl - fl * xr;
g1 = gl - gr;
g0 = gr * xl - gl * xr;
h2 = f1 * g1;
h1 = f1 * g0 + f0 * g1;
h0 = f0 * g0;
h2 = h2 / 3.0;
h1 = h1 / 2.0;
bit = ( ( h2 * xr + h1 ) * xr + h0 ) * xr
- ( ( h2 * xl + h1 ) * xl + h0 ) * xl;
integral = integral + bit / ( xr - xl ) / ( xr - xl );
}
}
return integral;
}
int main(int argc, char **argv) {
/******************************************************************************/
/*
Purpose:
MAIN is the main program for LINPACK_BENCH.
Discussion:
LINPACK_BENCH drives the double precision LINPACK benchmark program.
Modified:
25 July 2008
Parameters:
N is the problem size.
*/
# define N 1000
# define LDA ( N + 1 )
double *a;
double a_max;
double *b;
double b_max;
double cray = 0.056;
double eps;
int i;
int info;
int *ipvt;
int j;
int job;
double ops;
double *resid;
double resid_max;
double residn;
double *rhs;
double t1;
double t2;
double time[6];
double total;
double *x;
int arg = argc > 1 ? argv[1][0] - '0' : 3;
if (arg == 0) return 0;
timestamp ( );
printf ( "\n" );
printf ( "LINPACK_BENCH\n" );
printf ( " C version\n" );
printf ( "\n" );
printf ( " The LINPACK benchmark.\n" );
printf ( " Language: C\n" );
printf ( " Datatype: Double precision real\n" );
printf ( " Matrix order N = %d\n", N );
printf ( " Leading matrix dimension LDA = %d\n", LDA );
ops = ( double ) ( 2 * N * N * N ) / 3.0 + 2.0 * ( double ) ( N * N );
/*
Allocate space for arrays.
*/
a = r8mat_gen ( LDA, N );
b = ( double * ) malloc ( N * sizeof ( double ) );
ipvt = ( int * ) malloc ( N * sizeof ( int ) );
resid = ( double * ) malloc ( N * sizeof ( double ) );
rhs = ( double * ) malloc ( N * sizeof ( double ) );
x = ( double * ) malloc ( N * sizeof ( double ) );
a_max = 0.0;
for ( j = 0; j < N; j++ )
{
for ( i = 0; i < N; i++ )
{
a_max = r8_max ( a_max, a[i+j*LDA] );
}
}
for ( i = 0; i < N; i++ )
{
x[i] = 1.0;
}
for ( i = 0; i < N; i++ )
{
b[i] = 0.0;
for ( j = 0; j < N; j++ )
{
b[i] = b[i] + a[i+j*LDA] * x[j];
}
}
t1 = cpu_time ( );
info = dgefa ( a, LDA, N, ipvt );
if ( info != 0 )
{
printf ( "\n" );
printf ( "LINPACK_BENCH - Fatal error!\n" );
printf ( " The matrix A is apparently singular.\n" );
printf ( " Abnormal end of execution.\n" );
return 1;
}
t2 = cpu_time ( );
time[0] = t2 - t1;
t1 = cpu_time ( );
job = 0;
dgesl ( a, LDA, N, ipvt, b, job );
t2 = cpu_time ( );
time[1] = t2 - t1;
total = time[0] + time[1];
free ( a );
/*
Compute a residual to verify results.
*/
a = r8mat_gen ( LDA, N );
for ( i = 0; i < N; i++ )
{
x[i] = 1.0;
}
for ( i = 0; i < N; i++ )
{
rhs[i] = 0.0;
for ( j = 0; j < N; j++ )
{
rhs[i] = rhs[i] + a[i+j*LDA] * x[j];
}
}
for ( i = 0; i < N; i++ )
{
resid[i] = -rhs[i];
for ( j = 0; j < N; j++ )
{
resid[i] = resid[i] + a[i+j*LDA] * b[j];
}
}
resid_max = 0.0;
for ( i = 0; i < N; i++ )
{
resid_max = r8_max ( resid_max, r8_abs ( resid[i] ) );
}
b_max = 0.0;
for ( i = 0; i < N; i++ )
{
b_max = r8_max ( b_max, r8_abs ( b[i] ) );
}
eps = r8_epsilon ( );
residn = resid_max / ( double ) N / a_max / b_max / eps;
time[2] = total;
if ( 0.0 < total )
{
time[3] = ops / ( 1.0E+06 * total );
}
else
{
time[3] = -1.0;
}
time[4] = 2.0 / time[3];
time[5] = total / cray;
printf ( "\n" );
printf ( " Norm. Resid Resid MACHEP X[1] X[N]\n" );
printf ( "\n" );
printf ( " %14f %14f %14e %14f %14f\n", residn, resid_max, eps, b[0], b[N-1] );
printf ( "\n" );
printf ( " Factor Solve Total Unit Cray-Ratio\n" );
printf ( "\n" );
printf ( " %9f %9f %9f %9f %9f\n",
time[0], time[1], time[2], time[4], time[5] );
printf ( "\n" );
printf ( "Unrolled Double Precision %9f Mflops\n", time[3]);
printf ( "\n" );
free ( a );
free ( b );
free ( ipvt );
free ( resid );
free ( rhs );
free ( x );
/*
Terminate.
*/
printf ( "\n" );
printf ( "LINPACK_BENCH\n" );
printf ( " Normal end of execution.\n" );
printf ( "\n" );
timestamp ( );
return 0;
# undef LDA
# undef N
}
double zero ( double a, double b, double t, func_base& f )
//****************************************************************************80
//
// Purpose:
//
// ZERO seeks the root of a function F(X) in an interval [A,B].
//
// Discussion:
//
// The interval [A,B] must be a change of sign interval for F.
// That is, F(A) and F(B) must be of opposite signs. Then
// assuming that F is continuous implies the existence of at least
// one value C between A and B for which F(C) = 0.
//
// The location of the zero is determined to within an accuracy
// of 6 * MACHEPS * r8_abs ( C ) + 2 * T.
//
// Thanks to Thomas Secretin for pointing out a transcription error in the
// setting of the value of P, 11 February 2013.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 11 February 2013
//
// 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 change of sign interval.
//
// Input, double T, a positive error tolerance.
//
// Input, func_base& F, the name of a user-supplied c++ functor
// whose zero is being sought. The input and output
// of F() are of type double.
//
// Output, double ZERO, the estimated value of a zero of
// the function F.
//
{
double c;
double d;
double e;
double fa;
double fb;
double fc;
double m;
double macheps;
double p;
double q;
double r;
double s;
double sa;
double sb;
double tol;
//
// Make local copies of A and B.
//
sa = a;
sb = b;
fa = f ( sa );
fb = f ( sb );
c = sa;
fc = fa;
e = sb - sa;
d = e;
macheps = r8_epsilon ( );
for ( ; ; )
{
if ( r8_abs ( fc ) < r8_abs ( fb ) )
{
sa = sb;
sb = c;
c = sa;
fa = fb;
fb = fc;
fc = fa;
}
tol = 2.0 * macheps * r8_abs ( sb ) + t;
m = 0.5 * ( c - sb );
if ( r8_abs ( m ) <= tol || fb == 0.0 )
{
break;
}
if ( r8_abs ( e ) < tol || r8_abs ( fa ) <= r8_abs ( fb ) )
{
e = m;
d = e;
}
else
{
s = fb / fa;
if ( sa == c )
{
p = 2.0 * m * s;
q = 1.0 - s;
}
else
{
q = fa / fc;
r = fb / fc;
p = s * ( 2.0 * m * q * ( q - r ) - ( sb - sa ) * ( r - 1.0 ) );
q = ( q - 1.0 ) * ( r - 1.0 ) * ( s - 1.0 );
}
if ( 0.0 < p )
{
q = - q;
}
else
{
p = - p;
}
s = e;
e = d;
if ( 2.0 * p < 3.0 * m * q - r8_abs ( tol * q ) &&
p < r8_abs ( 0.5 * s * q ) )
{
d = p / q;
}
else
{
e = m;
d = e;
}
}
sa = sb;
fa = fb;
if ( tol < r8_abs ( d ) )
{
sb = sb + d;
}
else if ( 0.0 < m )
{
sb = sb + tol;
}
else
{
sb = sb - tol;
}
fb = f ( sb );
if ( ( 0.0 < fb && 0.0 < fc ) || ( fb <= 0.0 && fc <= 0.0 ) )
{
c = sa;
fc = fa;
e = sb - sa;
d = e;
}
}
return sb;
}
double local_min ( double a, double b, double t, func_base& f,
double &x )
//****************************************************************************80
//
// Purpose:
//
// LOCAL_MIN seeks a local minimum of a function F(X) in an interval [A,B].
//
// Discussion:
//
// 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 values EPS and T define a tolerance TOL = EPS * abs ( X ) + T.
// F is never evaluated at two points closer than TOL.
//
// If F is a unimodal function and the computed values of F are always
// unimodal when separated by at least SQEPS * abs ( X ) + (T/3), then
// LOCAL_MIN approximates the abscissa of the global minimum of F on the
// interval [A,B] with an error less than 3*SQEPS*abs(LOCAL_MIN)+T.
//
// If F is not unimodal, then LOCAL_MIN may approximate a local, but
// perhaps non-global, minimum to the same accuracy.
//
// Licensing:
//
// This code is distributed under the GNU LGPL license.
//
// Modified:
//
// 17 July 2011
//
// 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.
//
// Input, double T, a positive absolute error tolerance.
//
// Input, func_base& F, a user-supplied c++ functor whose
// local minimum is being sought. The input and output
// of F() are of type double.
//
// Output, double &X, the estimated value of an abscissa
// for which F attains a local minimum value in [A,B].
//
// Output, double LOCAL_MIN, the value F(X).
//
{
double c;
double d;
double e;
double eps;
double fu;
double fv;
double fw;
double fx;
double m;
double p;
double q;
double r;
double sa;
double sb;
double t2;
double tol;
double u;
double v;
double w;
//
// C is the square of the inverse of the golden ratio.
//
c = 0.5 * ( 3.0 - sqrt ( 5.0 ) );
eps = sqrt ( r8_epsilon ( ) );
sa = a;
sb = b;
x = sa + c * ( b - a );
w = x;
v = w;
e = 0.0;
fx = f ( x );
fw = fx;
fv = fw;
for ( ; ; )
{
m = 0.5 * ( sa + sb ) ;
tol = eps * r8_abs ( x ) + t;
t2 = 2.0 * tol;
//
// Check the stopping criterion.
//
if ( r8_abs ( x - m ) <= t2 - 0.5 * ( sb - sa ) )
{
break;
}
//
// Fit a parabola.
//
r = 0.0;
q = r;
p = q;
if ( tol < r8_abs ( e ) )
{
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;
}
if ( r8_abs ( p ) < r8_abs ( 0.5 * q * r ) &&
q * ( sa - x ) < p &&
p < q * ( sb - x ) )
{
//
// Take the parabolic interpolation step.
//
d = p / q;
u = x + d;
//
// F must not be evaluated too close to A or B.
//
if ( ( u - sa ) < t2 || ( sb - u ) < t2 )
{
if ( x < m )
{
d = tol;
}
else
{
d = - tol;
}
}
}
//
// A golden-section step.
//
else
{
if ( x < m )
{
e = sb - x;
}
else
{
e = sa - x;
}
d = c * e;
}
//
// F must not be evaluated too close to X.
//
if ( tol <= r8_abs ( d ) )
{
u = x + d;
}
else if ( 0.0 < d )
{
u = x + tol;
}
else
{
u = x - tol;
}
fu = f ( u );
//
// Update A, B, V, W, and X.
//
if ( fu <= fx )
{
if ( u < x )
{
sb = x;
}
else
{
sa = x;
}
v = w;
fv = fw;
w = x;
fw = fx;
x = u;
fx = fu;
}
else
{
if ( u < x )
{
sa = u;
}
else
{
sb = 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;
}
}
}
return fx;
}
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;
}
int diaedg ( double x0, double y0, double x1, double y1, double x2, double y2, double x3, double y3 )
{
double ca;
double cb;
double dx10;
double dx12;
double dx30;
double dx32;
double dy10;
double dy12;
double dy30;
double dy32;
double s;
double tol;
double tola;
double tolb;
int value;
tol = 100.0 * r8_epsilon ( );
dx10 = x1 - x0;
dy10 = y1 - y0;
dx12 = x1 - x2;
dy12 = y1 - y2;
dx30 = x3 - x0;
dy30 = y3 - y0;
dx32 = x3 - x2;
dy32 = y3 - y2;
tola = tol * r8_max ( fabs ( dx10 ), r8_max ( fabs ( dy10 ), r8_max ( fabs ( dx30 ), fabs ( dy30 ) ) ) );
tolb = tol * r8_max ( fabs ( dx12 ), r8_max ( fabs ( dy12 ), r8_max ( fabs ( dx32 ), fabs ( dy32 ) ) ) );
ca = dx10 * dx30 + dy10 * dy30;
cb = dx12 * dx32 + dy12 * dy32;
if ( tola < ca && tolb < cb )
{
value = -1;
}
else if ( ca < -tola && cb < -tolb )
{
value = 1;
}
else
{
tola = r8_max ( tola, tolb );
s = ( dx10 * dy30 - dx30 * dy10 ) * cb + ( dx32 * dy12 - dx12 * dy32 ) * ca;
if ( tola < s )
{
value = -1;
}
else if ( s < -tola )
{
value = 1;
}
else
{
value = 0;
}
}
return value;
}
void zero_rc ( double a, double b, double t, double *arg, int *status,
double value )
/******************************************************************************/
/*
Purpose:
ZERO_RC seeks the root of a function F(X) using reverse communication.
Discussion:
The interval [A,B] must be a change of sign interval for F.
That is, F(A) and F(B) must be of opposite signs. Then
assuming that F is continuous implies the existence of at least
one value C between A and B for which F(C) = 0.
The location of the zero is determined to within an accuracy
of 6 * MACHEPS * r8_abs ( C ) + 2 * T.
The routine is a revised version of the Brent zero finder
algorithm, using reverse communication.
Thanks to Thomas Secretin for pointing out a transcription error in the
setting of the value of P, 11 February 2013.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
11 February 2013
Author:
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 change of sign interval.
Input, double T, a positive error tolerance.
Output, double *ARG, the currently considered point. The user
does not need to initialize this value. On return with STATUS positive,
the user is requested to evaluate the function at ARG, and return
the value in VALUE. On return with STATUS zero, ARG is the routine's
estimate for the function's zero.
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 zero
Input, double VALUE, the function value at ARG, as requested
by the routine on the previous call.
*/
{
static double c;
static double d;
static double e;
static double fa;
static double fb;
static double fc;
double m;
static double machep;
double p;
double q;
double r;
double s;
static double sa;
static double sb;
double tol;
/*
Input STATUS = 0.
Initialize, request F(A).
*/
if ( *status == 0 )
{
machep = r8_epsilon ( );
sa = a;
sb = b;
e = sb - sa;
d = e;
*status = 1;
*arg = a;
return;
}
/*
Input STATUS = 1.
Receive F(A), request F(B).
*/
else if ( *status == 1 )
{
fa = value;
*status = 2;
*arg = sb;
return;
}
/*
Input STATUS = 2
Receive F(B).
*/
else if ( *status == 2 )
{
fb = value;
if ( 0.0 < fa * fb )
{
*status = -1;
return;
}
c = sa;
fc = fa;
}
else
{
fb = value;
if ( ( 0.0 < fb && 0.0 < fc ) || ( fb <= 0.0 && fc <= 0.0 ) )
{
c = sa;
fc = fa;
e = sb - sa;
d = e;
}
}
/*
Compute the next point at which a function value is requested.
*/
if ( r8_abs ( fc ) < r8_abs ( fb ) )
{
sa = sb;
sb = c;
c = sa;
fa = fb;
fb = fc;
fc = fa;
}
tol = 2.0 * machep * r8_abs ( sb ) + t;
m = 0.5 * ( c - sb );
if ( r8_abs ( m ) <= tol || fb == 0.0 )
{
*status = 0;
*arg = sb;
return;
}
if ( r8_abs ( e ) < tol || r8_abs ( fa ) <= r8_abs ( fb ) )
{
e = m;
d = e;
}
else
{
s = fb / fa;
if ( sa == c )
{
p = 2.0 * m * s;
q = 1.0 - s;
}
else
{
q = fa / fc;
r = fb / fc;
p = s * ( 2.0 * m * q * ( q - r ) - ( sb - sa ) * ( r - 1.0 ) );
q = ( q - 1.0 ) * ( r - 1.0 ) * ( s - 1.0 );
}
if ( 0.0 < p )
{
q = - q;
}
else
{
p = - p;
}
s = e;
e = d;
if ( 2.0 * p < 3.0 * m * q - r8_abs ( tol * q ) &&
p < r8_abs ( 0.5 * s * q ) )
{
d = p / q;
}
else
{
e = m;
d = e;
}
}
sa = sb;
fa = fb;
if ( tol < r8_abs ( d ) )
{
sb = sb + d;
}
else if ( 0.0 < m )
{
sb = sb + tol;
}
else
{
sb = sb - tol;
}
*arg = sb;
*status = *status + 1;
return;
}
void sgmga_write_tests ( void )
/******************************************************************************/
/*
Purpose:
SGMGA_WRITE_TESTS calls SGMGA_WRITE_TEST.
Discussion:
We can't test Golub-Welsch rules in this routine, because the program
that writes out the files needs to know the integration region for each
component, and we have not specified how that would be done with
Golub Welsch rules.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
27 November 2009
Author:
John Burkardt
Local Parameters:
Local, double TOL, a tolerance for point equality.
A value of sqrt ( eps ) is reasonable, and will allow the code to
consolidate points which are equal, or very nearly so. A value of
-1.0, on the other hand, will force the code to use every point,
regardless of duplication.
*/
{
int dim;
int dim_num;
char file_name[255];
GWPointer *gw_compute_points;
GWPointer *gw_compute_weights;
double *importance;
int level_max;
int level_max_max;
int level_max_min;
double *level_weight;
int *np;
int np_sum;
int *order_1d;
int order_nd;
double *p;
int *rule;
double tol;
printf ( "\n" );
printf ( "SGMGA_WRITE_TESTS\n" );
printf ( " Call SGMGA_WRITE_TEST with various arguments.\n" );
/*
Set the point equality tolerance.
*/
tol = sqrt ( r8_epsilon ( ) );
printf ( "\n" );
printf ( " All tests will use a point equality tolerance of %e\n\n", tol );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = 1.0;
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_ccxcc_iso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_ccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = 1.0;
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
rule[2] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_points[2] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[2] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d3_l2_ccxccxcc_iso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
rule[2] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_points[2] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[2] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d3_l2_ccxccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 3;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 3;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = patterson_lookup_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = patterson_lookup_weights_np;
strcpy ( file_name, "sgmga_d2_l3_ccxgp_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 4;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = legendre_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_ccxgl_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 7;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = laguerre_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = laguerre_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_ccxlg_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 8;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 1;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 1.5;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = gen_laguerre_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = gen_laguerre_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_ccxglg_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 2;
rule[1] = 9;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 2;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 0.5;
p[1] = 1.5;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = fejer2_compute_points_np;
gw_compute_points[1] = jacobi_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = fejer2_compute_weights_np;
gw_compute_weights[1] = jacobi_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_f2xgj_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 6;
rule[1] = 4;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 1;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
p[0] = 2.0;
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = gen_hermite_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = gen_hermite_compute_weights_np;
gw_compute_weights[1] = legendre_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l2_gghxgl_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
LEVEL_MAX = 1
*/
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 1;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l1_ccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
LEVEL_MAX = 2 (already done)
LEVEL_MAX = 3
*/
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 3;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l3_ccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
LEVEL_MAX = 4
*/
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 4;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l4_ccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
LEVEL_MAX = 5
*/
dim_num = 2;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 5;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 1;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = clenshaw_curtis_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = clenshaw_curtis_compute_weights_np;
strcpy ( file_name, "sgmga_d2_l5_ccxcc_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
/*
Dimension 3
*/
dim_num = 3;
importance = ( double * ) malloc ( dim_num * sizeof ( double ) );
for ( dim = 0; dim < dim_num; dim++ )
{
importance[dim] = ( double ) ( dim + 1 );
}
level_weight = ( double * ) malloc ( dim_num * sizeof ( double ) );
sgmga_importance_to_aniso ( dim_num, importance, level_weight );
level_max = 2;
rule = ( int * ) malloc ( dim_num * sizeof ( int ) );
rule[0] = 1;
rule[1] = 4;
rule[2] = 5;
np = ( int * ) malloc ( dim_num * sizeof ( int ) );
np[0] = 0;
np[1] = 0;
np[2] = 0;
np_sum = i4vec_sum ( dim_num, np );
p = ( double * ) malloc ( np_sum * sizeof ( double ) );
gw_compute_points = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_points[0] = clenshaw_curtis_compute_points_np;
gw_compute_points[1] = legendre_compute_points_np;
gw_compute_points[2] = hermite_compute_points_np;
gw_compute_weights = ( GWPointer * ) malloc ( dim_num * sizeof ( GWPointer ) );
gw_compute_weights[0] = clenshaw_curtis_compute_weights_np;
gw_compute_weights[1] = legendre_compute_weights_np;
gw_compute_weights[2] = hermite_compute_weights_np;
strcpy ( file_name, "sgmga_d3_l2_ccxglxgh_aniso" );
sgmga_write_test ( dim_num, level_weight, level_max, rule, np,
p, gw_compute_points, gw_compute_weights, tol, file_name );
free ( gw_compute_points );
free ( gw_compute_weights );
free ( importance );
free ( level_weight );
free ( np );
free ( p );
free ( rule );
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;
}
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;
}
int dtris2 ( int point_num, int base, double point_xy[], int *tri_num, int tri_vert[], int tri_nabe[] )
{
double cmax, tol;
int e, error, i, j, k, l, ledg, lr, ltri, m, m1, m2, n, redg, rtri, t, top;
int *indx, *stack;
stack = new int[point_num];
tol = 100.0 * r8_epsilon ( );
//
// Sort the vertices by increasing (x,y).
//
indx = r82vec_sort_heap_index_a ( point_num, base, point_xy );
r82vec_permute ( point_num, indx, base, point_xy );
//
// Make sure that the data points are "reasonably" distinct.
//
m1 = 1;
for ( i = 2; i <= point_num; i++ )
{
m = m1;
m1 = i;
k = -1;
for ( j = 0; j <= 1; j++ )
{
cmax = r8_max ( fabs ( point_xy[2*(m-1)+j] ),
fabs ( point_xy[2*(m1-1)+j] ) );
if ( tol * ( cmax + 1.0 ) < fabs ( point_xy[2*(m-1)+j] - point_xy[2*(m1-1)+j] ) )
{
k = j;
break;
}
}
if ( k == -1 )
{
std::cout << "\n";
std::cout << "DTRIS2 - Fatal error!\n";
std::cout << " Fails for point number I = " << i << "\n";
std::cout << " M = " << m << "\n";
std::cout << " M1 = " << m1 << "\n";
std::cout << " X,Y(M) = " << point_xy[2*(m-1)+0] << " " << point_xy[2*(m-1)+1] << "\n";
std::cout << " X,Y(M1) = " << point_xy[2*(m1-1)+0] << " " << point_xy[2*(m1-1)+1] << "\n";
delete [] stack;
return 224;
}
}
//
// Starting from points M1 and M2, search for a third point M that
// makes a "healthy" triangle (M1,M2,M)
//
m1 = 1;
m2 = 2;
j = 3;
for ( ; ; )
{
if ( point_num < j )
{
std::cout << "\n";
std::cout << "DTRIS2 - Fatal error!\n";
delete [] stack;
return 225;
}
m = j;
lr = lrline ( point_xy[2*(m-1)+0], point_xy[2*(m-1)+1],
point_xy[2*(m1-1)+0], point_xy[2*(m1-1)+1],
point_xy[2*(m2-1)+0], point_xy[2*(m2-1)+1], 0.0 );
if ( lr != 0 )
{
break;
}
j = j + 1;
}
//
// Set up the triangle information for (M1,M2,M), and for any other
// triangles you created because points were collinear with M1, M2.
//
*tri_num = j - 2;
if ( lr == -1 )
{
tri_vert[3*0+0] = m1;
tri_vert[3*0+1] = m2;
tri_vert[3*0+2] = m;
tri_nabe[3*0+2] = -3;
for ( i = 2; i <= *tri_num; i++ )
{
m1 = m2;
m2 = i+1;
tri_vert[3*(i-1)+0] = m1;
tri_vert[3*(i-1)+1] = m2;
tri_vert[3*(i-1)+2] = m;
tri_nabe[3*(i-1)+0] = -3 * i;
tri_nabe[3*(i-1)+1] = i;
tri_nabe[3*(i-1)+2] = i - 1;
}
tri_nabe[3*(*tri_num-1)+0] = -3 * (*tri_num) - 1;
tri_nabe[3*(*tri_num-1)+1] = -5;
ledg = 2;
ltri = *tri_num;
}
else
{
tri_vert[3*0+0] = m2;
tri_vert[3*0+1] = m1;
tri_vert[3*0+2] = m;
tri_nabe[3*0+0] = -4;
for ( i = 2; i <= *tri_num; i++ )
{
m1 = m2;
m2 = i+1;
tri_vert[3*(i-1)+0] = m2;
tri_vert[3*(i-1)+1] = m1;
tri_vert[3*(i-1)+2] = m;
tri_nabe[3*(i-2)+2] = i;
tri_nabe[3*(i-1)+0] = -3 * i - 3;
tri_nabe[3*(i-1)+1] = i - 1;
}
tri_nabe[3*(*tri_num-1)+2] = -3 * (*tri_num);
tri_nabe[3*0+1] = -3 * (*tri_num) - 2;
ledg = 2;
ltri = 1;
}
//
// Insert the vertices one at a time from outside the convex hull,
// determine visible boundary edges, and apply diagonal edge swaps until
// Delaunay triangulation of vertices (so far) is obtained.
//
top = 0;
for ( i = j+1; i <= point_num; i++ )
{
m = i;
m1 = tri_vert[3*(ltri-1)+ledg-1];
if ( ledg <= 2 )
{
m2 = tri_vert[3*(ltri-1)+ledg];
}
else
{
m2 = tri_vert[3*(ltri-1)+0];
}
lr = lrline ( point_xy[2*(m-1)+0], point_xy[2*(m-1)+1],
point_xy[2*(m1-1)+0], point_xy[2*(m1-1)+1],
point_xy[2*(m2-1)+0], point_xy[2*(m2-1)+1], 0.0 );
if ( 0 < lr )
{
rtri = ltri;
redg = ledg;
ltri = 0;
}
else
{
l = -tri_nabe[3*(ltri-1)+ledg-1];
rtri = l / 3;
redg = (l % 3) + 1;
}
vbedg ( point_xy[2*(m-1)+0], point_xy[2*(m-1)+1], point_num,
point_xy, *tri_num, tri_vert, tri_nabe, <ri, &ledg, &rtri, &redg );
n = *tri_num + 1;
l = -tri_nabe[3*(ltri-1)+ledg-1];
for ( ; ; )
{
t = l / 3;
e = ( l % 3 ) + 1;
l = -tri_nabe[3*(t-1)+e-1];
m2 = tri_vert[3*(t-1)+e-1];
if ( e <= 2 )
{
m1 = tri_vert[3*(t-1)+e];
}
else
{
m1 = tri_vert[3*(t-1)+0];
}
*tri_num = *tri_num + 1;
tri_nabe[3*(t-1)+e-1] = *tri_num;
tri_vert[3*(*tri_num-1)+0] = m1;
tri_vert[3*(*tri_num-1)+1] = m2;
tri_vert[3*(*tri_num-1)+2] = m;
tri_nabe[3*(*tri_num-1)+0] = t;
tri_nabe[3*(*tri_num-1)+1] = *tri_num - 1;
tri_nabe[3*(*tri_num-1)+2] = *tri_num + 1;
top = top + 1;
if ( point_num < top )
{
std::cout << "\n";
std::cout << "DTRIS2 - Fatal error!\n";
std::cout << " Stack overflow.\n";
delete [] stack;
return 8;
}
stack[top-1] = *tri_num;
if ( t == rtri && e == redg )
{
break;
}
}
tri_nabe[3*(ltri-1)+ledg-1] = -3 * n - 1;
tri_nabe[3*(n-1)+1] = -3 * (*tri_num) - 2;
tri_nabe[3*(*tri_num-1)+2] = -l;
ltri = n;
ledg = 2;
error = swapec ( m, &top, <ri, &ledg, point_num, point_xy, *tri_num,
tri_vert, tri_nabe, stack );
if ( error != 0 )
{
std::cout << "\n";
std::cout << "DTRIS2 - Fatal error!\n";
std::cout << " Error return from SWAPEC.\n";
delete [] stack;
return error;
}
}
//
// Now account for the sorting that we did.
//
for ( i = 0; i < 3; i++ )
{
for ( j = 0; j < *tri_num; j++ )
{
tri_vert[i+j*3] = indx [ tri_vert[i+j*3] - 1 ];
}
}
perm_inverse ( point_num, indx );
r82vec_permute ( point_num, indx, base, point_xy );
delete [] indx;
delete [] stack;
return 0;
}
void abwe2 ( int n, int m, double eps, double coef2, int even, double b[],
double *x, double *w1, double *w2 )
/******************************************************************************/
/*
Purpose:
ABWE2 calculates a Gaussian abscissa and two weights.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
30 April 2013
Author:
Original FORTRAN77 version by Robert Piessens, Maria Branders.
C version by John Burkardt.
Reference:
Robert Piessens, Maria Branders,
A Note on the Optimal Addition of Abscissas to Quadrature Formulas
of Gauss and Lobatto,
Mathematics of Computation,
Volume 28, Number 125, January 1974, pages 135-139.
Parameters:
Input, int N, the order of the Gauss rule.
Input, int M, the value of ( N + 1 ) / 2.
Input, double EPS, the requested absolute accuracy of the
abscissas.
Input, double COEF2, a value needed to compute weights.
Input, int EVEN, is TRUE if N is even.
Input, double B[M+1], the Chebyshev coefficients.
Input/output, double *X; on input, an estimate for
the abscissa, and on output, the computed abscissa.
Output, double *W1, the Gauss-Kronrod weight.
Output, double *W2, the Gauss weight.
*/
{
double ai;
double an;
double delta;
int i;
int iter;
int k;
int ka;
double p0;
double p1;
double p2;
double pd0;
double pd1;
double pd2;
double yy;
if ( *x == 0.0 )
{
ka = 1;
}
else
{
ka = 0;
}
/*
Iterative process for the computation of a Gaussian abscissa.
*/
for ( iter = 1; iter <= 50; iter++ )
{
p0 = 1.0;
p1 = *x;
pd0 = 0.0;
pd1 = 1.0;
/*
When N is 1, we need to initialize P2 and PD2 to avoid problems with DELTA.
*/
if ( n <= 1 )
{
if ( r8_epsilon ( ) < r8_abs ( *x ) )
{
p2 = ( 3.0 * ( *x ) * ( *x ) - 1.0 ) / 2.0;
pd2 = 3.0 * ( *x );
}
else
{
p2 = 3.0 * ( *x );
pd2 = 3.0;
}
}
ai = 0.0;
for ( k = 2; k <= n; k++ )
{
ai = ai + 1.0;
p2 = ( ( ai + ai + 1.0 ) * (*x) * p1 - ai * p0 ) / ( ai + 1.0 );
pd2 = ( ( ai + ai + 1.0 ) * ( p1 + (*x) * pd1 ) - ai * pd0 )
/ ( ai + 1.0 );
p0 = p1;
p1 = p2;
pd0 = pd1;
pd1 = pd2;
}
/*
Newton correction.
*/
delta = p2 / pd2;
*x = *x - delta;
if ( ka == 1 )
{
break;
}
if ( r8_abs ( delta ) <= eps )
{
ka = 1;
}
}
/*
Catch non-convergence.
*/
if ( ka != 1 )
{
fprintf ( stderr, "\n" );
fprintf ( stderr, "ABWE2 - Fatal error!\n" );
fprintf ( stderr, " Iteration limit reached.\n" );
fprintf ( stderr, " EPS was %e\n", eps );
fprintf ( stderr, " Last DELTA was %e\n", delta );
exit ( 1 );
}
/*
Computation of the weight.
*/
an = n;
*w2 = 2.0 / ( an * pd2 * p0 );
p1 = 0.0;
p2 = b[m];
yy = 4.0 * (*x) * (*x) - 2.0;
for ( k = 1; k <= m; k++ )
{
i = m - k + 1;
p0 = p1;
p1 = p2;
p2 = yy * p1 - p0 + b[i-1];
}
if ( even )
{
*w1 = *w2 + coef2 / ( pd2 * (*x) * ( p2 - p1 ) );
}
else
{
*w1 = *w2 + 2.0 * coef2 / ( pd2 * ( p2 - p0 ) );
}
return;
}
double glomin ( double a, double b, double c, double m, double e, double t,
func_base& f, double &x )
//****************************************************************************80
//
// 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 July 2011
//
// 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 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, func_base& F, a user-supplied c++ functor whose
// global minimum is being sought. The input and output
// of F() are of type double.
//
// 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 macheps;
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;
}
macheps = r8_epsilon ( );
m2 = 0.5 * ( 1.0 + 16.0 * macheps ) * 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;
}
//
// Loop.
//
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 * macheps ) * 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;
}
