template <typename PointT> void
pcl::SampleConsensusModelCircle2D<PointT>::optimizeModelCoefficients (
const std::vector<int> &inliers, const Eigen::VectorXf &model_coefficients, Eigen::VectorXf &optimized_coefficients)
{
boost::mutex::scoped_lock lock (tmp_mutex_);
const int n_unknowns = 3; // 3 unknowns
// Needs a set of valid model coefficients
if (model_coefficients.size () != n_unknowns)
{
PCL_ERROR ("[pcl::SampleConsensusModelCircle2D::optimizeModelCoefficients] Invalid number of model coefficients given (%lu)!\n", (unsigned long)model_coefficients.size ());
optimized_coefficients = model_coefficients;
return;
}
// Need at least 3 samples
if (inliers.size () <= 3)
{
PCL_ERROR ("[pcl::SampleConsensusModelCircle2D::optimizeModelCoefficients] Not enough inliers found to support a model (%lu)! Returning the same coefficients.\n", (unsigned long)inliers.size ());
optimized_coefficients = model_coefficients;
return;
}
tmp_inliers_ = &inliers;
int m = inliers.size ();
double *fvec = new double[m];
int iwa[n_unknowns];
int lwa = m * n_unknowns + 5 * n_unknowns + m;
double *wa = new double[lwa];
// Set the initial solution
double x[n_unknowns];
for (int d = 0; d < n_unknowns; ++d)
x[d] = model_coefficients[d]; // initial guess
// Set tol to the square root of the machine. Unless high solutions are required, these are the recommended settings.
double tol = sqrt (dpmpar (1));
// Optimize using forward-difference approximation LM
int info = lmdif1 (&pcl::SampleConsensusModelCircle2D<PointT>::functionToOptimize, this, m, n_unknowns, x, fvec, tol, iwa, wa, lwa);
// Compute the L2 norm of the residuals
PCL_DEBUG ("[pcl::SampleConsensusModelCircle2D::optimizeModelCoefficients] LM solver finished with exit code %i, having a residual norm of %g. \nInitial solution: %g %g %g \nFinal solution: %g %g %g\n",
info, enorm (m, fvec), model_coefficients[0], model_coefficients[1], model_coefficients[2], x[0], x[1], x[2]);
optimized_coefficients = Eigen::Vector3f (x[0], x[1], x[2]);
free (wa); free (fvec);
}
/** \brief Recompute the plane coefficients using the given inlier set and return them to the user.
* @note: these are the coefficients of the circle model after refinement (eg. after SVD)
* \param inliers the data inliers found as supporting the model
* \param refit_coefficients the resultant recomputed coefficients after non-linear optimization
*/
void
SACModelCircle2D::refitModel (const std::vector<int> &inliers, std::vector<double> &refit_coefficients)
{
if (inliers.size () == 0)
{
ROS_ERROR ("[SACModelCircle2D::RefitModel] Cannot re-fit 0 inliers!");
refit_coefficients = model_coefficients_;
return;
}
if (model_coefficients_.size () == 0)
{
ROS_WARN ("[SACModelCircle2D::RefitModel] Initial model coefficients have not been estimated yet - proceeding without an initial solution!");
best_inliers_ = indices_;
}
tmp_inliers_ = &inliers;
int m = inliers.size ();
double *fvec = new double[m];
int n = 3; // 3 unknowns
int iwa[n];
int lwa = m * n + 5 * n + m;
double *wa = new double[lwa];
// Set the initial solution
double x[3] = {0.0, 0.0, 0.0};
if ((int)model_coefficients_.size () == n)
for (int d = 0; d < n; d++)
x[d] = model_coefficients_.at (d);
// Set tol to the square root of the machine. Unless high solutions are required, these are the recommended settings.
double tol = sqrt (dpmpar (1));
// Optimize using forward-difference approximation LM
int info = lmdif1 (&sample_consensus::SACModelCircle2D::functionToOptimize, this, m, n, x, fvec, tol, iwa, wa, lwa);
// Compute the L2 norm of the residuals
ROS_DEBUG ("LM solver finished with exit code %i, having a residual norm of %g. \nInitial solution: %g %g %g \nFinal solution: %g %g %g",
info, enorm (m, fvec), model_coefficients_.at (0), model_coefficients_.at (1), model_coefficients_.at (2), x[0], x[1], x[2]);
refit_coefficients.resize (n);
for (int d = 0; d < n; d++)
refit_coefficients[d] = x[d];
free (wa); free (fvec);
}
static int
gnewton_set (void * vstate, gsl_multiroot_function_fdf * FDF, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx)
{
gnewton_state_t * state = (gnewton_state_t *) vstate;
size_t i, n = FDF->n ;
GSL_MULTIROOT_FN_EVAL_F_DF (FDF, x, f, J);
for (i = 0; i < n; i++)
{
gsl_vector_set (dx, i, 0.0);
}
state->phi = enorm(f);
return GSL_SUCCESS;
}
static int
set (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
hybrid_state_t *state = (hybrid_state_t *) vstate;
gsl_matrix *J = state->J;
gsl_matrix *q = state->q;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
GSL_MULTIROOT_FN_EVAL (func, x, f);
gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;
state->iter = 1;
state->fnorm = enorm (f);
state->ncfail = 0;
state->ncsuc = 0;
state->nslow1 = 0;
state->nslow2 = 0;
gsl_vector_set_all (dx, 0.0);
/* Store column norms in diag */
if (scale)
compute_diag (J, diag);
else
gsl_vector_set_all (diag, 1.0);
/* Set delta to factor |D x| or to factor if |D x| is zero */
state->delta = compute_delta (diag, x);
/* Factorize J into QR decomposition */
gsl_linalg_QR_decomp (J, tau);
gsl_linalg_QR_unpack (J, tau, q, r);
return GSL_SUCCESS;
}
static int
iterate (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
hybrid_state_t *state = (hybrid_state_t *) vstate;
const double fnorm = state->fnorm;
gsl_matrix *J = state->J;
gsl_matrix *q = state->q;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *qtf = state->qtf;
gsl_vector *x_trial = state->x_trial;
gsl_vector *f_trial = state->f_trial;
gsl_vector *df = state->df;
gsl_vector *qtdf = state->qtdf;
gsl_vector *rdx = state->rdx;
gsl_vector *w = state->w;
gsl_vector *v = state->v;
double prered, actred;
double pnorm, fnorm1, fnorm1p;
double ratio;
double p1 = 0.1, p5 = 0.5, p001 = 0.001, p0001 = 0.0001;
/* Compute qtf = Q^T f */
compute_qtf (q, f, qtf);
/* Compute dogleg step */
dogleg (r, qtf, diag, state->delta, state->newton, state->gradient, dx);
/* Take a trial step */
compute_trial_step (x, dx, state->x_trial);
pnorm = scaled_enorm (diag, dx);
if (state->iter == 1)
{
if (pnorm < state->delta)
{
state->delta = pnorm;
}
}
/* Evaluate function at x + p */
{
int status = GSL_MULTIROOT_FN_EVAL (func, x_trial, f_trial);
if (status != GSL_SUCCESS)
{
return GSL_EBADFUNC;
}
}
/* Set df = f_trial - f */
compute_df (f_trial, f, df);
/* Compute the scaled actual reduction */
fnorm1 = enorm (f_trial);
actred = compute_actual_reduction (fnorm, fnorm1);
/* Compute rdx = R dx */
compute_rdx (r, dx, rdx);
/* Compute the scaled predicted reduction phi1p = |Q^T f + R dx| */
fnorm1p = enorm_sum (qtf, rdx);
prered = compute_predicted_reduction (fnorm, fnorm1p);
/* Compute the ratio of the actual to predicted reduction */
if (prered > 0)
{
ratio = actred / prered;
}
else
{
ratio = 0;
}
/* Update the step bound */
if (ratio < p1)
{
state->ncsuc = 0;
state->ncfail++;
state->delta *= p5;
}
else
{
state->ncfail = 0;
state->ncsuc++;
if (ratio >= p5 || state->ncsuc > 1)
state->delta = GSL_MAX (state->delta, pnorm / p5);
if (fabs (ratio - 1) <= p1)
state->delta = pnorm / p5;
}
/* Test for successful iteration */
if (ratio >= p0001)
{
gsl_vector_memcpy (x, x_trial);
gsl_vector_memcpy (f, f_trial);
state->fnorm = fnorm1;
state->iter++;
}
/* Determine the progress of the iteration */
state->nslow1++;
if (actred >= p001)
state->nslow1 = 0;
if (actred >= p1)
state->nslow2 = 0;
if (state->ncfail == 2)
{
gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;
state->nslow2++;
if (state->iter == 1)
{
if (scale)
compute_diag (J, diag);
state->delta = compute_delta (diag, x);
}
else
{
if (scale)
update_diag (J, diag);
}
/* Factorize J into QR decomposition */
gsl_linalg_QR_decomp (J, tau);
gsl_linalg_QR_unpack (J, tau, q, r);
return GSL_SUCCESS;
}
/* Compute qtdf = Q^T df, w = (Q^T df - R dx)/|dx|, v = D^2 dx/|dx| */
compute_qtf (q, df, qtdf);
compute_wv (qtdf, rdx, dx, diag, pnorm, w, v);
/* Rank-1 update of the jacobian Q'R' = Q(R + w v^T) */
gsl_linalg_QR_update (q, r, w, v);
/* No progress as measured by jacobian evaluations */
if (state->nslow2 == 5)
{
return GSL_ENOPROGJ;
}
/* No progress as measured by function evaluations */
if (state->nslow1 == 10)
{
return GSL_ENOPROG;
}
return GSL_SUCCESS;
}
static int
set (void *vstate, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *work1 = state->work1;
gsl_permutation *perm = state->perm;
int signum;
/* Evaluate function at x */
/* return immediately if evaluation raised error */
{
int status = GSL_MULTIFIT_FN_EVAL_F_DF (fdf, x, f, J);
if (status)
return status;
}
state->par = 0;
state->iter = 1;
state->fnorm = enorm (f);
gsl_vector_set_all (dx, 0.0);
/* store column norms in diag */
if (scale)
{
compute_diag (J, diag);
}
else
{
gsl_vector_set_all (diag, 1.0);
}
/* set delta to 100 |D x| or to 100 if |D x| is zero */
state->xnorm = scaled_enorm (diag, x);
state->delta = compute_delta (diag, x);
/* Factorize J into QR decomposition */
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, work1);
gsl_vector_set_zero (state->rptdx);
gsl_vector_set_zero (state->w);
/* Zero the trial vector, as in the alloc function */
gsl_vector_set_zero (state->f_trial);
#ifdef DEBUG
printf("r = "); gsl_matrix_fprintf(stdout, r, "%g");
printf("perm = "); gsl_permutation_fprintf(stdout, perm, "%d");
printf("tau = "); gsl_vector_fprintf(stdout, tau, "%g");
#endif
return GSL_SUCCESS;
}
/* **********
*
* subroutine lmpar
*
* given an m by n matrix a, an n by n nonsingular diagonal
* matrix d, an m-vector b, and a positive number delta,
* the problem is to determine a value for the parameter
* par such that if x solves the system
*
* a*x = b , sqrt(par)*d*x = 0 ,
*
* in the least squares sense, and dxnorm is the euclidean
* norm of d*x, then either par is zero and
*
* (dxnorm-delta) .le. 0.1*delta ,
*
* or par is positive and
*
* abs(dxnorm-delta) .le. 0.1*delta .
*
* this subroutine completes the solution of the problem
* if it is provided with the necessary information from the
* qr factorization, with column pivoting, of a. that is, if
* a*p = q*r, where p is a permutation matrix, q has orthogonal
* columns, and r is an upper triangular matrix with diagonal
* elements of nonincreasing magnitude, then lmpar expects
* the full upper triangle of r, the permutation matrix p,
* and the first n components of (q transpose)*b. on output
* lmpar also provides an upper triangular matrix s such that
*
* t t t
* p *(a *a + par*d*d)*p = s *s .
*
* s is employed within lmpar and may be of separate interest.
*
* only a few iterations are generally needed for convergence
* of the algorithm. if, however, the limit of 10 iterations
* is reached, then the output par will contain the best
* value obtained so far.
*
* the subroutine statement is
*
* subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
* wa1,wa2)
*
* where
*
* n is a positive integer input variable set to the order of r.
*
* r is an n by n array. on input the full upper triangle
* must contain the full upper triangle of the matrix r.
* on output the full upper triangle is unaltered, and the
* strict lower triangle contains the strict upper triangle
* (transposed) of the upper triangular matrix s.
*
* ldr is a positive integer input variable not less than n
* which specifies the leading dimension of the array r.
*
* ipvt is an integer input array of length n which defines the
* permutation matrix p such that a*p = q*r. column j of p
* is column ipvt(j) of the identity matrix.
*
* diag is an input array of length n which must contain the
* diagonal elements of the matrix d.
*
* qtb is an input array of length n which must contain the first
* n elements of the vector (q transpose)*b.
*
* delta is a positive input variable which specifies an upper
* bound on the euclidean norm of d*x.
*
* par is a nonnegative variable. on input par contains an
* initial estimate of the levenberg-marquardt parameter.
* on output par contains the final estimate.
*
* x is an output array of length n which contains the least
* squares solution of the system a*x = b, sqrt(par)*d*x = 0,
* for the output par.
*
* sdiag is an output array of length n which contains the
* diagonal elements of the upper triangular matrix s.
*
* wa1 and wa2 are work arrays of length n.
*
* subprograms called
*
* minpack-supplied ... dpmpar,enorm,qrsolv
*
* fortran-supplied ... dabs,dmax1,dmin1,dsqrt
*
* argonne national laboratory. minpack project. march 1980.
* burton s. garbow, kenneth e. hillstrom, jorge j. more
*
* **********
*/
void lmpar(
int n,
double r[],
int ldr,
int ipvt[],
double diag[],
double qtb[],
double delta,
double *par,
double x[],
double sdiag[],
double wa1[],
double wa2[])
{
int i;
int iter;
int ij;
int jj;
int j;
int jm1;
int jp1;
int k;
int l;
int nsing;
double dxnorm;
double fp;
double gnorm;
double parc;
double parl;
double paru;
double sum;
double temp;
static double zero = 0.0;
//static double one = 1.0;
static double p1 = 0.1;
static double p001 = 0.001;
#ifdef BUG
printf( "lmpar\n" );
#endif
/* compute and store in x the gauss-newton direction. if the
* jacobian is rank-deficient, obtain a least squares solution.
*/
nsing = n;
jj = 0;
for (j=0; j<n; j++)
{
wa1[j] = qtb[j];
if ((r[jj] == zero) && (nsing == n))
nsing = j;
if (nsing < n)
wa1[j] = zero;
jj += ldr+1; /* [j+ldr*j] */
}
#ifdef BUG
printf( "nsing %d ", nsing );
#endif
if (nsing >= 1)
{
for (k=0; k<nsing; k++)
{
j = nsing - k - 1;
wa1[j] = wa1[j]/r[j+ldr*j];
temp = wa1[j];
jm1 = j - 1;
if (jm1 >= 0)
{
ij = ldr * j;
for (i=0; i<=jm1; i++)
{
wa1[i] -= r[ij]*temp;
ij += 1;
}
}
}
}
for (j=0; j<n; j++)
{
l = ipvt[j];
x[l] = wa1[j];
}
/* initialize the iteration counter.
* evaluate the function at the origin, and test
* for acceptance of the gauss-newton direction.
*/
iter = 0;
for (j=0; j<n; j++)
wa2[j] = diag[j]*x[j];
dxnorm = enorm(n,wa2);
fp = dxnorm - delta;
if (fp <= p1*delta)
{
#ifdef BUG
printf( "going to L220\n" );
#endif
goto L220;
}
/* if the jacobian is not rank deficient, the newton
* step provides a lower bound, parl, for the zero of
* the function. otherwise set this bound to zero.
*/
parl = zero;
if (nsing >= n)
{
for (j=0; j<n; j++)
{
l = ipvt[j];
wa1[j] = diag[l]*(wa2[l]/dxnorm);
}
jj = 0;
for (j=0; j<n; j++)
{
sum = zero;
jm1 = j - 1;
if (jm1 >= 0)
{
ij = jj;
for (i=0; i<=jm1; i++)
{
sum += r[ij]*wa1[i];
ij += 1;
}
}
wa1[j] = (wa1[j] - sum)/r[j+ldr*j];
jj += ldr; /* [i+ldr*j] */
}
temp = enorm(n,wa1);
parl = ((fp/delta)/temp)/temp;
}
/* calculate an upper bound, paru, for the zero of the function. */
jj = 0;
for (j=0; j<n; j++)
{
sum = zero;
ij = jj;
for (i=0; i<=j; i++)
{
sum += r[ij]*qtb[i];
ij += 1;
}
l = ipvt[j];
wa1[j] = sum/diag[l];
jj += ldr; /* [i+ldr*j] */
}
gnorm = enorm(n,wa1);
paru = gnorm/delta;
if(paru == zero)
paru = DWARF/dmin1(delta,p1);
/* if the input par lies outside of the interval (parl,paru),
* set par to the closer endpoint.
*/
*par = dmax1(*par,parl);
*par = dmin1(*par,paru);
if (*par == zero)
*par = gnorm/dxnorm;
#ifdef BUG
printf( "parl %.4e par %.4e paru %.4e\n", parl, *par, paru );
#endif
/* beginning of an iteration. */
L150:
iter += 1;
/* evaluate the function at the current value of par. */
if (*par == zero)
*par = dmax1(DWARF,p001*paru);
temp = sqrt(*par);
for (j=0; j<n; j++)
wa1[j] = temp*diag[j];
qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2);
for (j=0; j<n; j++)
wa2[j] = diag[j]*x[j];
dxnorm = enorm(n,wa2);
temp = fp;
fp = dxnorm - delta;
/* if the function is small enough, accept the current value
* of par. also test for the exceptional cases where parl
* is zero or the number of iterations has reached 10.
*/
if ((fabs(fp) <= p1*delta)
|| ((parl == zero) && (fp <= temp) && (temp < zero))
|| (iter == 10))
{
goto L220;
}
/* compute the newton correction. */
for (j=0; j<n; j++)
{
l = ipvt[j];
wa1[j] = diag[l]*(wa2[l]/dxnorm);
}
jj = 0;
for (j=0; j<n; j++)
{
wa1[j] = wa1[j]/sdiag[j];
temp = wa1[j];
jp1 = j + 1;
if (jp1 < n)
{
ij = jp1 + jj;
for (i=jp1; i<n; i++)
{
wa1[i] -= r[ij]*temp;
ij += 1; /* [i+ldr*j] */
}
}
jj += ldr; /* ldr*j */
}
temp = enorm(n,wa1);
parc = ((fp/delta)/temp)/temp;
/* depending on the sign of the function, update parl or paru. */
if (fp > zero)
parl = dmax1(parl, *par);
if (fp < zero)
paru = dmin1(paru, *par);
/* compute an improved estimate for par. */
*par = dmax1(parl, *par + parc);
/* end of an iteration. */
goto L150;
L220:
/* termination. */
if (iter == 0)
*par = zero;
}
/*
* **********
*
* subroutine qrfac
*
* this subroutine uses householder transformations with column
* pivoting (optional) to compute a qr factorization of the
* m by n matrix a. that is, qrfac determines an orthogonal
* matrix q, a permutation matrix p, and an upper trapezoidal
* matrix r with diagonal elements of nonincreasing magnitude,
* such that a*p = q*r. the householder transformation for
* column k, k = 1,2,...,min(m,n), is of the form
*
* t
* i - (1/u(k))*u*u
*
* where u has zeros in the first k-1 positions. the form of
* this transformation and the method of pivoting first
* appeared in the corresponding linpack subroutine.
*
* the subroutine statement is
*
* subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
*
* where
*
* m is a positive integer input variable set to the number
* of rows of a.
*
* n is a positive integer input variable set to the number
* of columns of a.
*
* a is an m by n array. on input a contains the matrix for
* which the qr factorization is to be computed. on output
* the strict upper trapezoidal part of a contains the strict
* upper trapezoidal part of r, and the lower trapezoidal
* part of a contains a factored form of q (the non-trivial
* elements of the u vectors described above).
*
* lda is a positive integer input variable not less than m
* which specifies the leading dimension of the array a.
*
* pivot is a logical input variable. if pivot is set true,
* then column pivoting is enforced. if pivot is set false,
* then no column pivoting is done.
*
* ipvt is an integer output array of length lipvt. ipvt
* defines the permutation matrix p such that a*p = q*r.
* column j of p is column ipvt(j) of the identity matrix.
* if pivot is false, ipvt is not referenced.
*
* lipvt is a positive integer input variable. if pivot is false,
* then lipvt may be as small as 1. if pivot is true, then
* lipvt must be at least n.
*
* rdiag is an output array of length n which contains the
* diagonal elements of r.
*
* acnorm is an output array of length n which contains the
* norms of the corresponding columns of the input matrix a.
* if this information is not needed, then acnorm can coincide
* with rdiag.
*
* wa is a work array of length n. if pivot is false, then wa
* can coincide with rdiag.
*
* subprograms called
*
* minpack-supplied ... dpmpar,enorm
*
* fortran-supplied ... dmax1,dsqrt,min0
*
* argonne national laboratory. minpack project. march 1980.
* burton s. garbow, kenneth e. hillstrom, jorge j. more
*
* **********
*/
void qrfac(int m,
int n,
double a[],
int lda,
int pivot,
int ipvt[],
int lipvt,
double rdiag[],
double acnorm[],
double wa[])
{
int i;
int ij;
int jj;
int j;
int jp1;
int k;
int kmax;
int minmn;
double ajnorm;
double sum;
double temp;
static double zero = 0.0;
static double one = 1.0;
static double p05 = 0.05;
/* compute the initial column norms and initialize several arrays. */
//printf("\nqrfac\n");
ij = 0;
for (j=0; j<n; j++)
{
acnorm[j] = enorm(m,&a[ij]);
rdiag[j] = acnorm[j];
wa[j] = rdiag[j];
if (pivot != 0)
ipvt[j] = j;
ij += m; /* m*j */
// printf("acnorm[%d] = %e\n", j, acnorm[j]);
// printf("rdiag[%d] = %e\n", j, rdiag[j]);
}
#ifdef BUG
printf( "qrfac\n" );
#endif
/* reduce a to r with householder transformations. */
minmn = min0(m,n);
for (j=0; j<minmn; j++)
{
if (pivot == 0)
goto L40;
/* bring the column of largest norm into the pivot position. */
kmax = j;
for (k=j; k<n; k++)
{
if (rdiag[k] > rdiag[kmax])
kmax = k;
}
if (kmax == j)
goto L40;
ij = m * j;
jj = m * kmax;
for (i=0; i<m; i++)
{
temp = a[ij]; /* [i+m*j] */
a[ij] = a[jj]; /* [i+m*kmax] */
a[jj] = temp;
ij += 1;
jj += 1;
}
rdiag[kmax] = rdiag[j];
wa[kmax] = wa[j];
k = ipvt[j];
ipvt[j] = ipvt[kmax];
ipvt[kmax] = k;
L40:
/* compute the householder transformation to reduce the
* j-th column of a to a multiple of the j-th unit vector.
*/
jj = j + m*j;
ajnorm = enorm(m-j,&a[jj]);
if (ajnorm == zero)
goto L100;
if (a[jj] < zero)
ajnorm = -ajnorm;
ij = jj;
for (i=j; i<m; i++)
{
a[ij] /= ajnorm;
ij += 1; /* [i+m*j] */
}
a[jj] += one;
/* apply the transformation to the remaining columns
* and update the norms.
*/
jp1 = j + 1;
if (jp1 < n)
{
for (k=jp1; k<n; k++)
{
sum = zero;
ij = j + m*k;
jj = j + m*j;
for (i=j; i<m; i++)
{
sum += a[jj]*a[ij];
ij += 1; /* [i+m*k] */
jj += 1; /* [i+m*j] */
}
temp = sum/a[j+m*j];
ij = j + m*k;
jj = j + m*j;
for (i=j; i<m; i++)
{
a[ij] -= temp*a[jj];
ij += 1; /* [i+m*k] */
jj += 1; /* [i+m*j] */
}
if ((pivot != 0) && (rdiag[k] != zero))
{
temp = a[j+m*k]/rdiag[k];
temp = dmax1(zero, one-temp*temp);
rdiag[k] *= sqrt(temp);
temp = rdiag[k]/wa[k];
if ((p05*temp*temp) <= MACHEP)
{
rdiag[k] = enorm(m-j-1,&a[jp1+m*k]);
wa[k] = rdiag[k];
}
}
}
}
L100:
rdiag[j] = -ajnorm;
}
}
static int
dogleg (const gsl_matrix * r, const gsl_vector * qtf,
const gsl_vector * diag, double delta,
gsl_vector * newton, gsl_vector * gradient, gsl_vector * p)
{
double qnorm, gnorm, sgnorm, bnorm, temp;
newton_direction (r, qtf, newton);
#ifdef DEBUG
printf("newton = "); gsl_vector_fprintf(stdout, newton, "%g"); printf("\n");
#endif
qnorm = scaled_enorm (diag, newton);
if (qnorm <= delta)
{
gsl_vector_memcpy (p, newton);
#ifdef DEBUG
printf("took newton (qnorm = %g <= delta = %g)\n", qnorm, delta);
#endif
return GSL_SUCCESS;
}
gradient_direction (r, qtf, diag, gradient);
#ifdef DEBUG
printf("grad = "); gsl_vector_fprintf(stdout, gradient, "%g"); printf("\n");
#endif
gnorm = enorm (gradient);
if (gnorm == 0)
{
double alpha = delta / qnorm;
double beta = 0;
scaled_addition (alpha, newton, beta, gradient, p);
#ifdef DEBUG
printf("took scaled newton because gnorm = 0\n");
#endif
return GSL_SUCCESS;
}
minimum_step (gnorm, diag, gradient);
compute_Rg (r, gradient, p); /* Use p as temporary space to compute Rg */
#ifdef DEBUG
printf("mingrad = "); gsl_vector_fprintf(stdout, gradient, "%g"); printf("\n");
printf("Rg = "); gsl_vector_fprintf(stdout, p, "%g"); printf("\n");
#endif
temp = enorm (p);
sgnorm = (gnorm / temp) / temp;
if (sgnorm > delta)
{
double alpha = 0;
double beta = delta;
scaled_addition (alpha, newton, beta, gradient, p);
#ifdef DEBUG
printf("took gradient\n");
#endif
return GSL_SUCCESS;
}
bnorm = enorm (qtf);
{
double bg = bnorm / gnorm;
double bq = bnorm / qnorm;
double dq = delta / qnorm;
double dq2 = dq * dq;
double sd = sgnorm / delta;
double sd2 = sd * sd;
double t1 = bg * bq * sd;
double u = t1 - dq;
double t2 = t1 - dq * sd2 + sqrt (u * u + (1-dq2) * (1 - sd2));
double alpha = dq * (1 - sd2) / t2;
double beta = (1 - alpha) * sgnorm;
#ifdef DEBUG
printf("bnorm = %g\n", bnorm);
printf("gnorm = %g\n", gnorm);
printf("qnorm = %g\n", qnorm);
printf("delta = %g\n", delta);
printf("alpha = %g beta = %g\n", alpha, beta);
printf("took scaled combination of newton and gradient\n");
#endif
scaled_addition (alpha, newton, beta, gradient, p);
}
return GSL_SUCCESS;
}
void qrfac(double *A, int M, int N, int lda, int pivot, int *ipvt, int lipvt,double *rdiag, double *acnorm,double eps) {
int i,j,jp1,k,kmax,minmn,t;
double ajnorm,epsmch,one,p05,sum,temp,zero,temp2,pmaxval;
double *AT,*wa,*wa2;
/*
* This routine is a C translation of Fortran Code by
* argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
*
* M is a positive integer input variable set to the number
of rows of a.
N is a positive integer input variable set to the number
of columns of a.
A is an M by N array. on input a contains the matrix for
which the qr factorization is to be computed. on output
the strict upper trapezoidal part of a contains the strict
upper trapezoidal part of r, and the lower trapezoidal
part of a contains a factored form of q (the non-trivial
elements of the u vectors described above).
lda is a positive integer input variable not less than m
which specifies the leading dimension of the array a.
pivot is an integer input variable. if pivot is set to 1,
then column pivoting is enforced. if pivot is set to 0,
then no column pivoting is done.
ipvt is an integer output array of length lipvt. ipvt
defines the permutation matrix p such that a*p = q*r.
column j of p is column ipvt(j) of the identity matrix.
if pivot is false, ipvt is not referenced.
lipvt is a positive integer input variable. if pivot is false,
then lipvt may be as small as 1. if pivot is true, then
lipvt must be at least n.
rdiag is an output array of length N which contains the
diagonal elements of r.
acnorm is an output array of length N which contains the
norms of the corresponding columns of the input matrix a.
if this information is not needed, then acnorm can coincide
with rdiag.
*
*/
if (pivot != 0 && pivot != 1) {
printf("Pivot only takes binary values 0 and 1 \n");
exit(-1);
}
AT = (double*) malloc(sizeof(double) *N*M);
wa = (double*) malloc(sizeof(double) *N);
wa2 = (double*) malloc(sizeof(double) *M);
one = 1.0;
zero = 0.0;
p05 = 5.0e-02;
epsmch = eps;
mtranspose(A,M,N,AT);// AT is size NXM
//compute the initial column norms and initialize several arrays.
for(j = 0; j < N; ++j) {
acnorm[j] = enorm(AT+j*M,M);
rdiag[j] = acnorm[j];
wa[j] = rdiag[j];
if (pivot == 1) {
ipvt[j] = j;
}
}
//reduce a to r with householder transformations.
if (M < N) {
minmn = M;
} else {
minmn = N;
}
for (j = 0; j < minmn; ++j) {
if (pivot == 1) {
//bring the column of largest norm into the pivot position.
kmax = j;
for(k = j; k < N; ++k) {
if (rdiag[k] > rdiag[kmax]) {
kmax = k;
}
}
if (kmax != j) {
for(i = 0; i < M; ++i) {
t = i * N;
temp = A[t+j];
A[t+j] = A[t+kmax];
A[t+kmax] = temp;
}
rdiag[kmax] = rdiag[j];
wa[kmax] = wa[j];
k = ipvt[j];
ipvt[j] = ipvt[kmax];
ipvt[kmax] = k;
}
}
// compute the householder transformation to reduce the
// j-th column of a to a multiple of the j-th unit vector.
t = j * N + j;
for(i = 0; i < M-j; ++i) {
wa2[i] = A[t+i*N];
}
ajnorm = enorm(wa2,M-j);
if (ajnorm != zero) {
if (A[t] < zero) {
ajnorm = - ajnorm;
}
for(i = j; i < M; ++i) {
A[i*N+j] /= ajnorm;
}
A[t] += one;
// apply the transformation to the remaining columns
// and update the norms.
jp1 = j + 1; // Breakpoint
if (N >= jp1+1) {
for(k = jp1; k < N; ++k) {
sum = zero;
for(i = j; i < M; ++i) {
sum += (A[i*N+j] * A[i*N+k]);
}
temp = sum / A[t];
for(i = j; i < M; ++i) {
A[i*N+k] -= (temp * A[i*N+j]);
}
// Breakpoint 2
if (pivot == 1 && rdiag[k] != zero) {
temp = A[j*N+k] / rdiag[k];
pmaxval = pmax(zero, one - temp*temp);
rdiag[k] = rdiag[k]*sqrt(pmaxval);
temp2 = (p05*(rdiag[k]/wa[k]));
temp2 = temp2 * temp2;
if (temp2 <= epsmch) {
for(i = 0; i < M-j-1; ++i) {
wa2[i] = A[jp1*N+k+i*N];
}
rdiag[k] = enorm(wa2,M-j-1);
wa[k] = rdiag[k];
}
}
}
}
}
rdiag[j] = -ajnorm;
}
free(AT);
free(wa);
free(wa2);
}
/* Subroutine */ void qrfac(int m, int n, double *a, int
lda, int pivot, int *ipvt, int lipvt, double *rdiag,
double *acnorm, double *wa)
{
/* Initialized data */
#define p05 .05
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
double d__1, d__2, d__3;
/* Local variables */
int i__, j, k, jp1;
double sum;
int kmax;
double temp;
int minmn;
double epsmch;
double ajnorm;
/* ********** */
/* subroutine qrfac */
/* this subroutine uses householder transformations with column */
/* pivoting (optional) to compute a qr factorization of the */
/* m by n matrix a. that is, qrfac determines an orthogonal */
/* matrix q, a permutation matrix p, and an upper trapezoidal */
/* matrix r with diagonal elements of nonincreasing magnitude, */
/* such that a*p = q*r. the householder transformation for */
/* column k, k = 1,2,...,min(m,n), is of the form */
/* t */
/* i - (1/u(k))*u*u */
/* where u has zeros in the first k-1 positions. the form of */
/* this transformation and the method of pivoting first */
/* appeared in the corresponding linpack subroutine. */
/* the subroutine statement is */
/* subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) */
/* where */
/* m is a positive integer input variable set to the number */
/* of rows of a. */
/* n is a positive integer input variable set to the number */
/* of columns of a. */
/* a is an m by n array. on input a contains the matrix for */
/* which the qr factorization is to be computed. on output */
/* the strict upper trapezoidal part of a contains the strict */
/* upper trapezoidal part of r, and the lower trapezoidal */
/* part of a contains a factored form of q (the non-trivial */
/* elements of the u vectors described above). */
/* lda is a positive integer input variable not less than m */
/* which specifies the leading dimension of the array a. */
/* pivot is a logical input variable. if pivot is set true, */
/* then column pivoting is enforced. if pivot is set false, */
/* then no column pivoting is done. */
/* ipvt is an integer output array of length lipvt. ipvt */
/* defines the permutation matrix p such that a*p = q*r. */
/* column j of p is column ipvt(j) of the identity matrix. */
/* if pivot is false, ipvt is not referenced. */
/* lipvt is a positive integer input variable. if pivot is false, */
/* then lipvt may be as small as 1. if pivot is true, then */
/* lipvt must be at least n. */
/* rdiag is an output array of length n which contains the */
/* diagonal elements of r. */
/* acnorm is an output array of length n which contains the */
/* norms of the corresponding columns of the input matrix a. */
/* if this information is not needed, then acnorm can coincide */
/* with rdiag. */
/* wa is a work array of length n. if pivot is false, then wa */
/* can coincide with rdiag. */
/* subprograms called */
/* minpack-supplied ... dpmpar,enorm */
/* fortran-supplied ... dmax1,dsqrt,min0 */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* Parameter adjustments */
--wa;
--acnorm;
--rdiag;
a_dim1 = lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipvt;
/* Function Body */
/* epsmch is the machine precision. */
epsmch = dpmpar(1);
/* compute the initial column norms and initialize several arrays. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
acnorm[j] = enorm(m, &a[j * a_dim1 + 1]);
rdiag[j] = acnorm[j];
wa[j] = rdiag[j];
if (pivot) {
ipvt[j] = j;
}
/* L10: */
}
/* reduce a to r with householder transformations. */
minmn = min(m,n);
i__1 = minmn;
for (j = 1; j <= i__1; ++j) {
if (! (pivot)) {
goto L40;
}
/* bring the column of largest norm into the pivot position. */
kmax = j;
i__2 = n;
for (k = j; k <= i__2; ++k) {
if (rdiag[k] > rdiag[kmax]) {
kmax = k;
}
/* L20: */
}
if (kmax == j) {
goto L40;
}
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = a[i__ + kmax * a_dim1];
a[i__ + kmax * a_dim1] = temp;
/* L30: */
}
rdiag[kmax] = rdiag[j];
wa[kmax] = wa[j];
k = ipvt[j];
ipvt[j] = ipvt[kmax];
ipvt[kmax] = k;
L40:
/* compute the householder transformation to reduce the */
/* j-th column of a to a multiple of the j-th unit vector. */
i__2 = m - j + 1;
ajnorm = enorm(i__2, &a[j + j * a_dim1]);
if (ajnorm == 0.) {
goto L100;
}
if (a[j + j * a_dim1] < 0.) {
ajnorm = -ajnorm;
}
i__2 = m;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] /= ajnorm;
/* L50: */
}
a[j + j * a_dim1] += 1.;
/* apply the transformation to the remaining columns */
/* and update the norms. */
jp1 = j + 1;
if (n < jp1) {
goto L100;
}
i__2 = n;
for (k = jp1; k <= i__2; ++k) {
sum = 0.;
i__3 = m;
for (i__ = j; i__ <= i__3; ++i__) {
sum += a[i__ + j * a_dim1] * a[i__ + k * a_dim1];
/* L60: */
}
temp = sum / a[j + j * a_dim1];
i__3 = m;
for (i__ = j; i__ <= i__3; ++i__) {
a[i__ + k * a_dim1] -= temp * a[i__ + j * a_dim1];
/* L70: */
}
if (! (pivot) || rdiag[k] == 0.) {
goto L80;
}
temp = a[j + k * a_dim1] / rdiag[k];
/* Computing MAX */
/* Computing 2nd power */
d__3 = temp;
d__1 = 0., d__2 = 1. - d__3 * d__3;
rdiag[k] *= sqrt((max(d__1,d__2)));
/* Computing 2nd power */
d__1 = rdiag[k] / wa[k];
if (p05 * (d__1 * d__1) > epsmch) {
goto L80;
}
i__3 = m - j;
rdiag[k] = enorm(i__3, &a[jp1 + k * a_dim1]);
wa[k] = rdiag[k];
L80:
/* L90: */
;
}
L100:
rdiag[j] = -ajnorm;
/* L110: */
}
return;
/* last card of subroutine qrfac. */
} /* qrfac_ */
double lmpar(int n, double *r__, int *ldr, int *ipvt,
double *diag, double *qtb, double *delta,
double par_init,
double *x, double *sdiag, double *wa1, double *wa2)
{
double par = par_init;
// ---- the return_value
/*
subroutine lmpar
given an m by n matrix a, an n by n nonsingular diagonal
matrix d, an m-vector b, and a positive number delta,
the problem is to determine a value for the parameter
par such that if x solves the system
a*x = b , sqrt(par)*d*x = 0 ,
in the least squares sense, and dxnorm is the euclidean
norm of d*x, then either par is 0. and
(dxnorm-delta) <= 0.1*delta ,
or par is positive and
abs(dxnorm-delta) <= 0.1*delta .
this subroutine completes the solution of the problem
if it is provided with the necessary information from the
qr factorization, with column pivoting, of a. that is, if
a*p = q*r, where p is a permutation matrix, q has orthogonal
columns, and r is an upper triangular matrix with diagonal
elements of nonincreasing magnitude, then lmpar expects
the full upper triangle of r, the permutation matrix p,
and the first n components of (q transpose)*b. on output
lmpar also provides an upper triangular matrix s such that
t t t
p *(a *a + par*d*d)*p = s *s .
s is employed within lmpar and may be of separate interest.
only a few iterations are generally needed for convergence
of the algorithm. if, however, the limit of 10 iterations
is reached, then the output par will contain the best
value obtained so far.
the subroutine statement is
subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
wa1,wa2)
where
n is a positive int input variable set to the order of r.
r is an n by n array. on input the full upper triangle
must contain the full upper triangle of the matrix r.
on output the full upper triangle is unaltered, and the
strict lower triangle contains the strict upper triangle
(transposed) of the upper triangular matrix s.
ldr is a positive int input variable not less than n
which specifies the leading dimension of the array r.
ipvt is an int input array of length n which defines the
permutation matrix p such that a*p = q*r. column j of p
is column ipvt(j) of the identity matrix.
diag is an input array of length n which must contain the
diagonal elements of the matrix d.
qtb is an input array of length n which must contain the first
n elements of the vector (q transpose)*b.
delta is a positive input variable which specifies an upper
bound on the euclidean norm of d*x.
par is a nonnegative variable. on input par contains an
initial estimate of the levenberg-marquardt parameter.
on output par contains the final estimate.
x is an output array of length n which contains the least
squares solution of the system a*x = b, sqrt(par)*d*x = 0,
for the output par.
sdiag is an output array of length n which contains the
diagonal elements of the upper triangular matrix s.
wa1 and wa2 are work arrays of length n.
subprograms called
minpack-supplied ... dpmpar,enorm,qrsolv
fortran-supplied ... fabs,dmax1,dmin1,dsqrt
argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
***********/
/* Initialized data */
static double p1 = .1;
static double p001 = .001;
/* System generated locals */
int r_dim1, r_offset;
/* Local variables */
int i__, j, k, l, jp1, iter, nsing;
double fp, sum, parc, parl, temp, paru, dwarf, gnorm, dxnorm;
/* Parameter adjustments */
--wa2;
--wa1;
--sdiag;
--x;
--qtb;
--diag;
--ipvt;
r_dim1 = *ldr;
r_offset = 1 + r_dim1;
r__ -= r_offset;
// dwarf is the smallest positive magnitude :
dwarf = machfd_.fltmin;
/* compute and store in x the gauss-newton direction. if the
jacobian is rank-deficient, obtain a least squares solution. */
nsing = n;
for (j = 1; j <= n; ++j) {
wa1[j] = qtb[j];
if (r__[j + j * r_dim1] == 0. && nsing == n) {
nsing = j - 1;
}
if (nsing < n) {
wa1[j] = 0.;
}
}
for (k = 1; k <= nsing; ++k) {
j = nsing - k + 1;
wa1[j] /= r__[j + j * r_dim1];
temp = wa1[j];
for (i__ = 1; i__ <= j-1; ++i__) {
wa1[i__] -= r__[i__ + j * r_dim1] * temp;
}
}
for (j = 1; j <= n; ++j) {
l = ipvt[j];
x[l] = wa1[j];
}
/* initialize the iteration counter.
evaluate the function at the origin, and test
for acceptance of the gauss-newton direction. */
iter = 0;
for (j = 1; j <= n; ++j) {
wa2[j] = diag[j] * x[j];
}
dxnorm = enorm(n, &wa2[1]);
fp = dxnorm - *delta;
if (fp <= p1 * *delta) {
goto L220;
}
/* if the jacobian is not rank deficient, the newton
step provides a lower bound, parl, for the zero of
the function. Otherwise set this bound to 0. */
parl = 0.;
if (nsing >= n) {
for (j = 1; j <= n; ++j) {
l = ipvt[j];
wa1[j] = diag[l] * (wa2[l] / dxnorm);
}
for (j = 1; j <= n; ++j) {
sum = 0.;
for (i__ = 1; i__ <= j-1; ++i__) {
sum += r__[i__ + j * r_dim1] * wa1[i__];
}
wa1[j] = (wa1[j] - sum) / r__[j + j * r_dim1];
}
temp = enorm(n, &wa1[1]);
parl = fp / *delta / temp / temp;
}
// L120:
/* calculate an upper bound, paru, for the 0. of the function. */
for (j = 1; j <= n; ++j) {
sum = 0.;
for (i__ = 1; i__ <= j; ++i__) {
sum += r__[i__ + j * r_dim1] * qtb[i__];
}
l = ipvt[j];
wa1[j] = sum / diag[l];
}
gnorm = enorm(n, &wa1[1]);
paru = gnorm / *delta;
if (paru == 0.) {
paru = dwarf / fmin2(*delta,p1);
}
/* if the input par lies outside of the interval (parl,paru),
set par to the closer endpoint. */
par = fmax2(par, parl);
par = fmin2(par, paru);
if (par == 0.) {
par = gnorm / dxnorm;
}
/* beginning of an iteration. */
L150:
++iter;
/* evaluate the function at the current value of par. */
if (par == 0.)
par = fmax2(dwarf, p001 * paru);
temp = sqrt(par);
for (j = 1; j <= n; ++j) {
wa1[j] = temp * diag[j];
}
qrsolv(n, &r__[r_offset], ldr, &ipvt[1], &wa1[1], &qtb[1], &x[1],
&sdiag[1], &wa2[1]);
for (j = 1; j <= n; ++j) {
wa2[j] = diag[j] * x[j];
}
dxnorm = enorm(n, &wa2[1]);
temp = fp;
fp = dxnorm - *delta;
/* if the function is small enough, accept the current value
of par. also test for the exceptional cases where parl
is 0. or the number of iterations has reached 10. */
if (fabs(fp) <= p1 * *delta || (parl == 0. && fp <= temp && temp < 0.) ||
iter == 10) { // << FIXME: give warning for iter == 10 !!
goto L220;
}
/* compute the newton correction. */
for (j = 1; j <= n; ++j) {
l = ipvt[j];
wa1[j] = diag[l] * (wa2[l] / dxnorm);
}
for (j = 1; j <= n; ++j) {
wa1[j] /= sdiag[j];
temp = wa1[j];
jp1 = j + 1;
for (i__ = jp1; i__ <= n; ++i__) {
wa1[i__] -= r__[i__ + j * r_dim1] * temp;
}
}
temp = enorm(n, &wa1[1]);
parc = fp / *delta / temp / temp;
/* depending on the sign of the function, update parl or paru. */
if (fp > 0.) {
parl = fmax2(parl,par);
}
if (fp < 0.) {
paru = fmin2(paru,par);
}
// compute an improved estimate for par.
par = fmax2(parl, par + parc);
/* end of an iteration. */
goto L150;
L220: // termination.
if (iter == 0) {
par = 0.;
}
return par;
} /* lmpar */
static
void qrfac(int *m, int *n, double *a, int *lda,
/*logical*/int *pivot, int *ipvt, int *lipvt, double *rdiag,
double *acnorm, double *wa)
{
/* Initialized data */
static double p05 = .05;
/* System generated locals */
int a_dim1, a_offset;
double d__1;
/* Local variables */
int i__, j, k, jp1, minmn;
double sum, temp, ajnorm;
/* **********
subroutine qrfac
this subroutine uses householder transformations with column
pivoting (optional) to compute a qr factorization of the
m by n matrix a. that is, qrfac determines an orthogonal
matrix q, a permutation matrix p, and an upper trapezoidal
matrix r with diagonal elements of nonincreasing magnitude,
such that a*p = q*r. the householder transformation for
column k, k = 1,2,...,min(m,n), is of the form
t
i - (1/u(k))*u*u
where u has zeros in the first k-1 positions. the form of
this transformation and the method of pivoting first
appeared in the corresponding linpack subroutine.
the subroutine statement is
subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
where
m is a positive int input variable set to the number
of rows of a.
n is a positive int input variable set to the number
of columns of a.
a is an m by n array. on input a contains the matrix for
which the qr factorization is to be computed. on output
the strict upper trapezoidal part of a contains the strict
upper trapezoidal part of r, and the lower trapezoidal
part of a contains a factored form of q (the non-trivial
elements of the u vectors described above).
lda is a positive int input variable not less than m
which specifies the leading dimension of the array a.
pivot is a *logical* input variable. if pivot is set true,
then column pivoting is enforced. if pivot is set false,
then no column pivoting is done.
ipvt is an int output array of length lipvt. ipvt
defines the permutation matrix p such that a*p = q*r.
column j of p is column ipvt(j) of the identity matrix.
if pivot is false, ipvt is not referenced.
lipvt is a positive int input variable. if pivot is false,
then lipvt may be as small as 1. if pivot is true, then
lipvt must be at least n.
rdiag is an output array of length n which contains the
diagonal elements of r.
acnorm is an output array of length n which contains the
norms of the corresponding columns of the input matrix a.
if this information is not needed, then acnorm can coincide
with rdiag.
wa is a work array of length n. if pivot is false, then wa
can coincide with rdiag.
subprograms called
minpack-supplied ... dpmpar,enorm
fortran-supplied ... dmax1,dsqrt,min0
argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
**********
double precision dpmpar,enorm
Parameter adjustments */
--wa;
--acnorm;
--rdiag;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipvt;
// compute the initial column norms and initialize several arrays.
for (j = 1; j <= *n; ++j) {
acnorm[j] = enorm(*m, &a[j * a_dim1 + 1]);
rdiag[j] = acnorm[j];
wa[j] = rdiag[j];
if (*pivot) ipvt[j] = j;
}
/* reduce a to r with householder transformations. */
minmn = imin2(*m,*n);
for (j = 1; j <= minmn; ++j) {
if (*pivot) { // bring the column of largest norm into the pivot position.
int kmax = j;
for (k = j; k <= *n; ++k) {
if (rdiag[k] > rdiag[kmax])
kmax = k;
}
if (kmax != j) {
// swap a[,j] and a[,kmax] :
for (i__ = 1; i__ <= *m; ++i__) {
double t = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = a[i__ + kmax * a_dim1];
a[i__ + kmax * a_dim1] = t;
}
rdiag[kmax] = rdiag[j];
wa[kmax] = wa[j];
k = ipvt[j]; ipvt[j] = ipvt[kmax]; ipvt[kmax] = k;
}
}
// L40:
/* compute the householder transformation to reduce the
j-th column of a to a multiple of the j-th unit vector. */
ajnorm = enorm(*m - j + 1, &a[j + j * a_dim1]);
if (ajnorm == 0.) {
goto L100;
}
if (a[j + j * a_dim1] < 0.) {
ajnorm = -ajnorm;
}
for (i__ = j; i__ <= *m; ++i__) {
a[i__ + j * a_dim1] /= ajnorm;
}
a[j + j * a_dim1] += 1.;
/* apply the transformation to the remaining columns
and update the norms. */
jp1 = j + 1;
for (k = jp1; k <= *n; ++k) {
sum = 0.;
for (i__ = j; i__ <= *m; ++i__) {
sum += a[i__ + j * a_dim1] * a[i__ + k * a_dim1];
}
temp = sum / a[j + j * a_dim1];
for (i__ = j; i__ <= *m; ++i__) {
a[i__ + k * a_dim1] -= temp * a[i__ + j * a_dim1];
}
if (*pivot && rdiag[k] != 0.) {
temp = a[j + k * a_dim1] / rdiag[k];
rdiag[k] *= sqrt((fmax2(0., 1. - temp * temp)));
/* Computing 2nd power */
d__1 = rdiag[k] / wa[k];
if (p05 * (d__1 * d__1) < machfd_.epsmax) {
rdiag[k] = enorm(*m - j, &a[jp1 + k * a_dim1]);
wa[k] = rdiag[k];
}
}
}
L100:
rdiag[j] = -ajnorm;
}
return;
} /* qrfac */
double lmder1(S_fp fcn, int m, int n,
double *x, double *fvec, double *fjac, int ldfjac,
double ftol, double xtol, double gtol, int maxfev, double *diag,
int mode, double factor,
int *info, int *nfev, int *njev,
int *ipvt, double *qtf,
double *wa1, double *wa2, double *wa3, double *wa4, double *y)
{
// THE return value (since 2011-08-08):
double fd_min_fnorm = -99.; // Wall
/*
subroutine lmder
the purpose of lmder is to minimize the sum of the squares of
m nonlinear functions in n variables by a modification of
the levenberg-marquardt algorithm. the user must provide a
subroutine which calculates the functions and the jacobian.
the subroutine statement is
subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
maxfev,diag,mode,factor,nprint,info,nfev,
njev,ipvt,qtf,wa1,wa2,wa3,wa4)
where
fcn is the name of the user-supplied subroutine which
calculates the functions and the jacobian. fcn must
be declared in an external statement in the user
calling program, and should be written as follows.
subroutine fcn(m, n, x,fvec,fjac, ldfjac,iflag)
int m,n, ldfjac,iflag
double precision x(n), fvec(m), fjac(ldfjac,n)
----------
if iflag = 1 calculate the functions at x and
return this vector in fvec. do not alter fjac.
if iflag = 2 calculate the jacobian at x and
return this matrix in fjac. do not alter fvec.
----------
return
end
the value of iflag should not be changed by fcn unless
the user wants to terminate execution of lmder.
in this case set iflag to a negative int.
m is a positive int input variable set to the number
of functions.
n is a positive int input variable set to the number
of variables. n must not exceed m.
x is an array of length n. on input x must contain
an initial estimate of the solution vector. on output x
contains the final estimate of the solution vector.
fvec is an output array of length m which contains
the functions evaluated at the output x.
fjac is an output m by n array. the upper n by n submatrix
of fjac contains an upper triangular matrix r with
diagonal elements of nonincreasing magnitude such that
t t t
p *(jac *jac)*p = r *r,
where p is a permutation matrix and jac is the final
calculated jacobian. column j of p is column ipvt(j)
(see below) of the identity matrix. the lower trapezoidal
part of fjac contains information generated during
the computation of r.
ldfjac is a positive int input variable not less than m
which specifies the leading dimension of the array fjac.
ftol is a nonnegative input variable. termination
occurs when both the actual and predicted relative
reductions in the sum of squares are at most ftol.
therefore, ftol measures the relative error desired
in the sum of squares.
xtol is a nonnegative input variable. termination
occurs when the relative error between two consecutive
iterates is at most xtol. therefore, xtol measures the
relative error desired in the approximate solution.
gtol is a nonnegative input variable. termination
occurs when the cosine of the angle between fvec and
any column of the jacobian is at most gtol in absolute
value. therefore, gtol measures the orthogonality
desired between the function vector and the columns
of the jacobian.
maxfev is a positive int input variable. termination
occurs when the number of calls to fcn with iflag = 1
has reached maxfev.
diag is an array of length n. if mode = 1 (see
below), diag is internally set. if mode = 2, diag
must contain positive entries that serve as
multiplicative scale factors for the variables.
mode is an int input variable. if mode = 1, the
variables will be scaled internally. if mode = 2,
the scaling is specified by the input diag. other
values of mode are equivalent to mode = 1.
factor is a positive input variable used in determining the
initial step bound. this bound is set to the product of
factor and the euclidean norm of diag*x if nonzero, or else
to factor itself. in most cases factor should lie in the
interval (.1,100.).100. is a generally recommended value.
nprint is an int input variable that enables controlled
printing of iterates if it is positive. in this case,
fcn is called with iflag = 0 at the beginning of the first
iteration and every nprint iterations thereafter and
immediately prior to return, with x, fvec, and fjac
available for printing. fvec and fjac should not be
altered. if nprint is not positive, no special calls
of fcn with iflag = 0 are made.
info is an int output variable. if the user has
terminated execution, info is set to the (negative)
value of iflag. see description of fcn. otherwise,
info is set as follows.
info = 0 improper input parameters.
info = 1 both actual and predicted relative reductions
in the sum of squares are at most ftol.
info = 2 relative error between two consecutive iterates
is at most xtol.
info = 3 conditions for info = 1 and info = 2 both hold.
info = 4 the cosine of the angle between fvec and any
column of the jacobian is at most gtol in
absolute value.
info = 5 number of calls to fcn with iflag = 1 has
reached maxfev.
info = 6 ftol is too small. no further reduction in
the sum of squares is possible.
info = 7 xtol is too small. no further improvement in
the approximate solution x is possible.
info = 8 gtol is too small. fvec is orthogonal to the
columns of the jacobian to machine precision.
nfev is an int output variable set to the number of
calls to fcn with iflag = 1.
njev is an int output variable set to the number of
calls to fcn with iflag = 2.
ipvt is an int output array of length n. ipvt
defines a permutation matrix p such that jac*p = q*r,
where jac is the final calculated jacobian, q is
orthogonal (not stored), and r is upper triangular
with diagonal elements of nonincreasing magnitude.
column j of p is column ipvt(j) of the identity matrix.
qtf is an output array of length n which contains
the first n elements of the vector (q transpose)*fvec.
wa1, wa2, and wa3 are work arrays of length n.
wa4 is a work array of length m.
subprograms called
user-supplied ...... fcn
minpack-supplied ... dpmpar,enorm,lmpar,qrfac
fortran-supplied ... fabs,dmax1,dmin1,dsqrt,mod
argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
epsmch is the machine precision.
epsmch = dpmpar(1)
*/
/* Initialized data */
static double p1 = .1;
static double p5 = .5;
static double p25 = .25;
static double p75 = .75;
static double p0001 = 1e-4;
/* System generated locals */
int fjac_offset;
double d__1;
/* Local variables */
int i__, j, l, iter, iflag, nprint;
double par, sum, temp, temp1, temp2,
ratio, enorm_n, xnorm, fnorm1, actred, dirder, prered,
T_gnorm, delta = 0.; /* Wall*/
/* Parameter adjustments */
--wa4;
--fvec;
--wa3;
--wa2;
--wa1;
--qtf;
--ipvt;
--diag;
--x;
--y;
fjac_offset = 1 + ldfjac; fjac -= fjac_offset;
/* Function Body */
temp = 0.;
nprint = 0;
*info = 0;
iflag = 0;
*nfev = 0;
*njev = 0;
/* check the input parameters for errors. */
if (n <= 0 || m < n || ldfjac < m || ftol < 0. || xtol < 0. ||
gtol < 0. || maxfev <= 0 || factor <= 0.) {
warning("lmder1(): invalid (scalar) input");
goto L_end;
}
if (mode == 2) { /* check diag[] */
for (j = 1; j <= n; ++j)
if (diag[j] <= 0.) goto L_end;
}
/* evaluate the function at the starting point and calculate its norm. */
iflag = 1;
(*fcn)(&x[1], &fvec[1], &fjac[fjac_offset], ldfjac, iflag, &y[1]);
*nfev = 1;
if (iflag < 0) {
warning("lmder1(): problem in function evaluation at starting point");
goto L_end;
}
fd_min_fnorm = fmin2(enorm(m, &fvec[1]), mauxfd_1.bignum);
/* initialize levenberg-marquardt parameter and iteration counter. */
par = 0.;
iter = 1;
/* ==== beginning of the outer loop. ==========================================*/
L30:
/* calculate the jacobian matrix. */
iflag = 2;
(*fcn)(&x[1], &fvec[1], &fjac[fjac_offset], ldfjac, iflag, &y[1]);
++(*njev);
if (iflag < 0)
goto L_end;
/* if requested, call fcn to enable printing of iterates. */
if (nprint > 0) {
iflag = 0;
if ((iter - 1) % nprint == 0)
(*fcn)(&x[1], &fvec[1], &fjac[fjac_offset], ldfjac, iflag, &y[1]);
if (iflag < 0)
goto L_end;
}
/* L40: */
/* compute the qr factorization of the jacobian. */
qrfac(&m, &n, &fjac[fjac_offset], &ldfjac, &c_true, &ipvt[1], &n,
&wa1[1], &wa2[1], &wa3[1]);
/* on the first iteration -- do a some initializations : */
if (iter == 1) {
/* if mode is 1, scale according
to the norms of the columns of the initial jacobian. */
if (mode == 1) {
for (j = 1; j <= n; ++j)
diag[j] = ((wa2[j] != 0.)? wa2[j] : 1.);
}
/* calculate the norm of the scaled x and
initialize the step bound delta. */
for (j = 1; j <= n; ++j)
wa3[j] = diag[j] * x[j];
xnorm = enorm(n, &wa3[1]);
delta = factor * xnorm;
if (delta == 0.) {
delta = factor;
}
}
/* L80: */
/* form (q transpose)*fvec and store the first n components in qtf. */
for (i__ = 1; i__ <= m; ++i__) {
wa4[i__] = fvec[i__];
}
for (j = 1; j <= n; ++j) {
if (fjac[j + j * ldfjac] != 0.) {
sum = 0.;
for (i__ = j; i__ <= m; ++i__)
sum += fjac[i__ + j * ldfjac] * wa4[i__];
temp = -sum / fjac[j + j * ldfjac];
for (i__ = j; i__ <= m; ++i__)
wa4[i__] += fjac[i__ + j * ldfjac] * temp;
}
/* L120: */
fjac[j + j * ldfjac] = wa1[j];
qtf[j] = wa4[j];
}
/* compute the norm of the scaled gradient. */
T_gnorm = 0.;
if (fd_min_fnorm != 0.) {
for (j = 1; j <= n; ++j) {
l = ipvt[j];
if (wa2[l] != 0.) {
sum = 0.;
for (i__ = 1; i__ <= j; ++i__)
sum += fjac[i__ + j * ldfjac] * (qtf[i__] / fd_min_fnorm);
T_gnorm = fmax2(T_gnorm, fabs(sum / wa2[l]));
}
}
}
/* L170: */
/* test for convergence of the gradient norm. */
if (T_gnorm <= gtol) *info = 4;
if (*info != 0)
goto L_end;
/* rescale if necessary. */
if (mode == 1) {
for (j = 1; j <= n; ++j)
diag[j] = fmax2(diag[j], wa2[j]);
}
/* L190: */
do { // ------------- the inner loop. ------------------------------------
/* determine the levenberg-marquardt parameter. */
par = lmpar(n, &fjac[fjac_offset], &ldfjac, &ipvt[1],
&diag[1], &qtf[1], &delta,
par,
&wa1[1], &wa2[1], &wa3[1], &wa4[1]);
/* store the direction p and x + p. calculate the norm of p. */
for (j = 1; j <= n; ++j) {
wa1[j] = -wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j] * wa1[j];
}
enorm_n = enorm(n, &wa3[1]);
/* on the first iteration, adjust the initial step bound. */
if (iter == 1) {
delta = fmin2(delta,enorm_n);
}
/* evaluate the function at x + p and calculate its norm. */
iflag = 1;
(*fcn)(&wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, iflag, &y[1]);
++(*nfev);
if (iflag < 0)
goto L_end;
fnorm1 = fmin2(enorm(m, &wa4[1]), mauxfd_1.bignum);
/* compute the scaled actual reduction. */
actred = -1.;
if (p1 * fnorm1 < fd_min_fnorm) {
d__1 = fnorm1 / fd_min_fnorm;
actred = 1. - d__1 * d__1;
}
/* actred = (fnorm*fnorm - fnorm1*fnorm1) */
/* compute the scaled predicted reduction and
the scaled directional derivative. */
for (j = 1; j <= n; ++j) {
wa3[j] = 0.;
l = ipvt[j];
temp = wa1[l];
for (i__ = 1; i__ <= j; ++i__) {
wa3[i__] += fjac[i__ + j * ldfjac] * temp;
}
}
temp1 = enorm(n, &wa3[1]) / fd_min_fnorm;
temp2 = sqrt(par) * enorm_n / fd_min_fnorm;
prered = temp1 * temp1 + temp2 * temp2 / p5;
/* temp1 = enorm(n,wa3)
temp2 = (dsqrt(par)*enorm_n)
prered = (temp1**2 + 2.d0*temp2**2)
*/
dirder = -(temp1 * temp1 + temp2 * temp2);
/* compute the ratio of the actual to the predicted reduction. */
if (prered != 0.)
ratio = actred / prered;
else
ratio = 0.;
/* update the step bound. */
if (ratio <= p25) {
if (actred >= 0.)
temp = p5;
else /* (actred < 0.) */
temp = p5 * dirder / (dirder + p5 * actred);
if (p1 * fnorm1 >= fd_min_fnorm || temp < p1)
temp = p1;
delta = temp * fmin2(delta, enorm_n / p1);
par /= temp;
}
else { /* ratio > p25 */
if (par == 0. || ratio >= p75) {
delta = enorm_n / p5;
par = p5 * par;
}
}
/* L260: */
/* test for successful iteration. */
if (ratio >= p0001) {
/* successful iteration. update x, fvec, and their norms. */
for (j = 1; j <= n; ++j) {
x[j] = wa2[j];
wa2[j] = diag[j] * x[j];
}
for (i__ = 1; i__ <= m; ++i__)
fvec[i__] = wa4[i__];
xnorm = enorm(n, &wa2[1]);
fd_min_fnorm = fnorm1;
++iter;
}
/* L290: tests for convergence. */
if((fabs(actred) <= ftol && prered <= ftol && p5 * ratio <= 1.) ||
(fd_min_fnorm <= ftol))
*info = 1;
if (delta <= xtol) {
*info = 2;
if (fabs(actred) <= ftol &&
prered <= ftol &&
p5 * ratio <= 1.)
*info = 3;
}
if (*info != 0)
goto L_end;
/* tests for termination and stringent tolerances. */
if (*nfev >= maxfev) *info = 5;
if (fabs(actred) <= machfd_.epsmax &&
prered <= machfd_.epsmax &&
p5 * ratio <= 1.) *info = 6;
if (delta <= machfd_.epsmax) *info = 7;
if (T_gnorm <= machfd_.epsmax) *info = 8;
if (*info != 0)
goto L_end;
/* end of the inner loop. repeat if iteration unsuccessful. */
} while (ratio < p0001);
/* end of the outer loop. */
goto L30;
L_end: // termination, either normal or user imposed.
if (iflag < 0) {
*info = iflag;
}
iflag = 0;
if (nprint > 0) {
(*fcn)(&x[1], &fvec[1], &fjac[fjac_offset], ldfjac, iflag, &y[1]);
}
return fd_min_fnorm;
} /* lmder1 */
/* Subroutine */ void dogleg(int n, const double *r__, int lr,
const double *diag, const double *qtb, double delta, double *x,
double *wa1, double *wa2)
{
/* System generated locals */
int i__1, i__2;
double d__1, d__2, d__3, d__4;
/* Local variables */
int i__, j, k, l, jj, jp1;
double sum, temp, alpha, bnorm;
double gnorm, qnorm, epsmch;
double sgnorm;
/* ********** */
/* subroutine dogleg */
/* given an m by n matrix a, an n by n nonsingular diagonal */
/* matrix d, an m-vector b, and a positive number delta, the */
/* problem is to determine the convex combination x of the */
/* gauss-newton and scaled gradient directions that minimizes */
/* (a*x - b) in the least squares sense, subject to the */
/* restriction that the euclidean norm of d*x be at most delta. */
/* this subroutine completes the solution of the problem */
/* if it is provided with the necessary information from the */
/* qr factorization of a. that is, if a = q*r, where q has */
/* orthogonal columns and r is an upper triangular matrix, */
/* then dogleg expects the full upper triangle of r and */
/* the first n components of (q transpose)*b. */
/* the subroutine statement is */
/* subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) */
/* where */
/* n is a positive integer input variable set to the order of r. */
/* r is an input array of length lr which must contain the upper */
/* triangular matrix r stored by rows. */
/* lr is a positive integer input variable not less than */
/* (n*(n+1))/2. */
/* diag is an input array of length n which must contain the */
/* diagonal elements of the matrix d. */
/* qtb is an input array of length n which must contain the first */
/* n elements of the vector (q transpose)*b. */
/* delta is a positive input variable which specifies an upper */
/* bound on the euclidean norm of d*x. */
/* x is an output array of length n which contains the desired */
/* convex combination of the gauss-newton direction and the */
/* scaled gradient direction. */
/* wa1 and wa2 are work arrays of length n. */
/* subprograms called */
/* minpack-supplied ... dpmpar,enorm */
/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* Parameter adjustments */
--wa2;
--wa1;
--x;
--qtb;
--diag;
--r__;
/* Function Body */
/* epsmch is the machine precision. */
epsmch = dpmpar(1);
/* first, calculate the gauss-newton direction. */
jj = n * (n + 1) / 2 + 1;
i__1 = n;
for (k = 1; k <= i__1; ++k) {
j = n - k + 1;
jp1 = j + 1;
jj -= k;
l = jj + 1;
sum = 0.;
if (n < jp1) {
goto L20;
}
i__2 = n;
for (i__ = jp1; i__ <= i__2; ++i__) {
sum += r__[l] * x[i__];
++l;
/* L10: */
}
L20:
temp = r__[jj];
if (temp != 0.) {
goto L40;
}
l = j;
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = fabs(r__[l]);
temp = max(d__2,d__3);
l = l + n - i__;
/* L30: */
}
temp = epsmch * temp;
if (temp == 0.) {
temp = epsmch;
}
L40:
x[j] = (qtb[j] - sum) / temp;
/* L50: */
}
/* test whether the gauss-newton direction is acceptable. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa1[j] = 0.;
wa2[j] = diag[j] * x[j];
/* L60: */
}
qnorm = enorm(n, &wa2[1]);
if (qnorm <= delta) {
/* goto L140; */
return;
}
/* the gauss-newton direction is not acceptable. */
/* next, calculate the scaled gradient direction. */
l = 1;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
temp = qtb[j];
i__2 = n;
for (i__ = j; i__ <= i__2; ++i__) {
wa1[i__] += r__[l] * temp;
++l;
/* L70: */
}
wa1[j] /= diag[j];
/* L80: */
}
/* calculate the norm of the scaled gradient and test for */
/* the special case in which the scaled gradient is zero. */
gnorm = enorm(n, &wa1[1]);
sgnorm = 0.;
alpha = delta / qnorm;
if (gnorm == 0.) {
goto L120;
}
/* calculate the point along the scaled gradient */
/* at which the quadratic is minimized. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa1[j] = wa1[j] / gnorm / diag[j];
/* L90: */
}
l = 1;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = n;
for (i__ = j; i__ <= i__2; ++i__) {
sum += r__[l] * wa1[i__];
++l;
/* L100: */
}
wa2[j] = sum;
/* L110: */
}
temp = enorm(n, &wa2[1]);
sgnorm = gnorm / temp / temp;
/* test whether the scaled gradient direction is acceptable. */
alpha = 0.;
if (sgnorm >= delta) {
goto L120;
}
/* the scaled gradient direction is not acceptable. */
/* finally, calculate the point along the dogleg */
/* at which the quadratic is minimized. */
bnorm = enorm(n, &qtb[1]);
temp = bnorm / gnorm * (bnorm / qnorm) * (sgnorm / delta);
/* Computing 2nd power */
d__1 = sgnorm / delta;
/* Computing 2nd power */
d__2 = temp - delta / qnorm;
/* Computing 2nd power */
d__3 = delta / qnorm;
/* Computing 2nd power */
d__4 = sgnorm / delta;
temp = temp - delta / qnorm * (d__1 * d__1) + sqrt(d__2 * d__2 + (1. -
d__3 * d__3) * (1. - d__4 * d__4));
/* Computing 2nd power */
d__1 = sgnorm / delta;
alpha = delta / qnorm * (1. - d__1 * d__1) / temp;
L120:
/* form appropriate convex combination of the gauss-newton */
/* direction and the scaled gradient direction. */
temp = (1. - alpha) * min(sgnorm,delta);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
x[j] = temp * wa1[j] + alpha * x[j];
/* L130: */
}
/* L140: */
return;
/* last card of subroutine dogleg. */
} /* dogleg_ */
void lmpar(double *r,int ldr,int N,int *ipvt,double *diag,double *qtb,double delta,double *par,double *x,double *sdiag) {
int i,iter,j,jm1,jp1,k,l,nsing;
double dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,sum,temp,zero;
double *wa1,*wa2;
/*
* This routine is a C translation of Fortran Code by
* argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
* N is a positive integer input variable set to the order of r.
r is an N by N array. on input the full upper triangle
must contain the full upper triangle of the matrix r.
on output the full upper triangle is unaltered, and the
strict lower triangle contains the strict upper triangle
(transposed) of the upper triangular matrix s.
ldr is a positive integer input variable not less than n
which specifies the leading dimension of the array r.
ipvt is an integer input array of length N which defines the
permutation matrix p such that a*p = q*r. column j of p
is column ipvt(j) of the identity matrix.
diag is an input array of length N which must contain the
diagonal elements of the matrix d.
qtb is an input array of length N which must contain the first
N elements of the vector (q transpose)*b.
delta is a positive input variable which specifies an upper
bound on the euclidean norm of d*x.
par is a nonnegative variable. on input par contains an
initial estimate of the levenberg-marquardt parameter.
on output par contains the final estimate.
x is an output array of length N which contains the least
squares solution of the system a*x = b, sqrt(par)*d*x = 0,
for the output par.
sdiag is an output array of length N which contains the
diagonal elements of the upper triangular matrix s.
*/
wa1 = (double*) malloc(sizeof(double) *N);
wa2 = (double*) malloc(sizeof(double) *N);
p1 = 1.0e-01;
p001 = 1.0e-03;
zero = 0.0;
dwarf = 2.22507385852e-308;
// compute and store in x the gauss-newton direction. if the
// jacobian is rank-deficient, obtain a least squares solution.
nsing = N;
for(j = 1; j <= N; ++j) {
wa1[j-1] = qtb[j-1];
if (r[(j-1)*N+j-1] == zero && nsing == N) {
nsing = j - 1;
}
if (nsing < N) {
wa1[j-1] = zero;
}
}
if (nsing >= 1) {//50
for(k = 1; k <= nsing; ++k) {
j = nsing - k + 1;
wa1[j-1] = wa1[j-1]/r[(j-1)*N+j-1];
temp = wa1[j-1];
jm1 = j - 1;
if (jm1 >= 1) {
for(i = 1; i <= jm1; ++i) {
wa1[i-1] = wa1[i-1] - r[(i-1)*N+j-1]*temp;
}
}
}
}//50
for (j = 0; j < N; ++j) {
l = ipvt[j];
x[l] = wa1[j];
}
// initialize the iteration counter.
// evaluate the function at the origin, and test
// for acceptance of the gauss-newton direction.
iter = 0;
for(j = 0; j < N; ++j) {
wa2[j] = diag[j]*x[j];
}
dxnorm = enorm(wa2,N);
fp = dxnorm - delta;
if (fp > p1*delta) {//220
// if the jacobian is not rank deficient, the newton
// step provides a lower bound, parl, for the zero of
// the function. otherwise set this bound to zero.
parl = zero;
if (nsing >= N) { //120 nsing only takes values upto N
for(j = 0; j < N; ++j) {
l = ipvt[j];
wa1[j] = diag[l]*(wa2[l]/dxnorm);
}
for(j = 0; j < N; ++j) { //110
sum = zero;
jm1 = j - 1;
if (jm1 >= 0) {//100
for(i = 0; i <= jm1; ++i) { //check
sum = sum + r[i*N+j]*wa1[i];
}
}//100
wa1[j] = (wa1[j] - sum)/r[j*N+j];
}//110
temp = enorm(wa1,N);
parl = ((fp/delta)/temp)/temp;
}//120
// calculate an upper bound, paru, for the zero of the function.
for(j = 0; j < N; ++j) { //140
sum = zero;
for(i = 0; i <= j; ++i) { //check
sum = sum + r[i*N+j]*qtb[i];
}
l = ipvt[j];
wa1[j] = sum/diag[l];
}//140
gnorm = enorm(wa1,N);
paru = gnorm/delta;
if (paru == zero) {
paru = dwarf/pmin(delta,p1);
}
// if the input par lies outside of the interval (parl,paru),
// set par to the closer endpoint.
*par = pmax(*par,parl);
*par = pmin(*par,paru);
if (*par == zero) {
*par = gnorm/dxnorm;
}
//Iteration begins
while(1) {
iter++;
// evaluate the function at the current value of par.
if (*par == zero) {
*par = pmax(dwarf,p001*paru);
}
temp = sqrt(*par);
for(j = 0; j < N; ++j) {
wa1[j] = temp*diag[j];
}
qrsolv(r,ldr,N,ipvt,wa1,qtb,x,sdiag);
for(j = 0; j < N; ++j) {
wa2[j] = diag[j]*x[j];
}
dxnorm = enorm(wa2,N);
temp = fp;
fp = dxnorm - delta;
// if the function is small enough, accept the current value
// of par. also test for the exceptional cases where parl
// is zero or the number of iterations has reached 10.
if (fabs(fp) <= p1*delta) {
break;
}
if (iter == 10) {
break;
}
if (parl == zero && fp <= temp && temp < zero) {
break;
}
// compute the newton correction.
for(j = 0; j < N; ++j) { //180
l = ipvt[j];
wa1[j] = diag[l]*(wa2[l]/dxnorm);
}//180
for(j = 0; j < N; ++j) { //210
wa1[j] = wa1[j]/sdiag[j];
temp = wa1[j];
jp1 = j + 1;
if (N >= jp1+1) {
for(i = jp1; i < N; ++i) {
wa1[i] = wa1[i] - r[i*N+j]*temp;
}
}
}//210
temp = enorm(wa1,N);
parc = ((fp/delta)/temp)/temp;
// depending on the sign of the function, update parl or paru.
if (fp > zero) {
parl = pmax(parl,*par);
}
if (fp < zero) {
paru = pmin(paru,*par);
}
// compute an improved estimate for par.
*par = pmax(parl,*par+parc);
}
}//220
if (iter == 0) {
*par = zero;
}
free(wa1);
free(wa2);
}
int lmder(custom_funcmult *funcmult, custom_jacobian *jacobian, double *x, int M, int N,
double *fvec,double *fjac,int ldfjac,int maxfev,double *diag,int mode,double factor,int nprint,
double eps,double ftol,double gtol,double xtol,int *nfev,int *njev,int *ipvt, double *qtf) {
int info;
int i,j,l,iter;
double actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
sum,temp,temp1,temp2,xnorm,zero;
double *wa1,*wa2,*wa3,*wa4;
/*
* * This routine is a C translation of Fortran Code by
* argonne national laboratory. minpack project. march 1980.
burton s. garbow, kenneth e. hillstrom, jorge j. more
* M is a positive integer input variable set to the number
c of functions.
c
c N is a positive integer input variable set to the number
c of variables. N must not exceed M.
c
c x is an array of length N. on input x must contain
c an initial estimate of the solution vector. on output x
c contains the final estimate of the solution vector.
c
c fvec is an output array of length M which contains
c the functions evaluated at the output x.
c
c fjac is an output M by N array. the upper N by N submatrix
c of fjac contains an upper triangular matrix r with
c diagonal elements of nonincreasing magnitude such that
c
c t t t
c p *(jac *jac)*p = r *r,
c
c where p is a permutation matrix and jac is the final
c calculated jacobian. column j of p is column ipvt(j)
c (see below) of the identity matrix. the lower trapezoidal
c part of fjac contains information generated during
c the computation of r.
c
c ldfjac is a positive integer input variable not less than M
c which specifies the leading dimension of the array fjac.
c
c ftol is a nonnegative input variable. termination
c occurs when both the actual and predicted relative
c reductions in the sum of squares are at most ftol.
c therefore, ftol measures the relative error desired
c in the sum of squares.
c
c xtol is a nonnegative input variable. termination
c occurs when the relative error between two consecutive
c iterates is at most xtol. therefore, xtol measures the
c relative error desired in the approximate solution.
c
c gtol is a nonnegative input variable. termination
c occurs when the cosine of the angle between fvec and
c any column of the jacobian is at most gtol in absolute
c value. therefore, gtol measures the orthogonality
c desired between the function vector and the columns
c of the jacobian.
c
c maxfev is a positive integer input variable. termination
c occurs when the number of calls to fcn with iflag = 1
c has reached maxfev.
c
c diag is an array of length N. if mode = 1 (see
c below), diag is internally set. if mode = 2, diag
c must contain positive entries that serve as
c multiplicative scale factors for the variables.
c
c mode is an integer input variable. if mode = 1, the
c variables will be scaled internally. if mode = 2,
c the scaling is specified by the input diag. other
c values of mode are equivalent to mode = 1.
c
c factor is a positive input variable used in determining the
c initial step bound. this bound is set to the product of
c factor and the euclidean norm of diag*x if nonzero, or else
c to factor itself. in most cases factor should lie in the
c interval (.1,100.).100. is a generally recommended value.
c
c nprint is an integer input variable that enables controlled
c printing of iterates if it is positive. in this case,
c fcn is called with iflag = 0 at the beginning of the first
c iteration and every nprint iterations thereafter and
c immediately prior to return, with x, fvec, and fjac
c available for printing. fvec and fjac should not be
c altered. if nprint is not positive, no special calls
c of fcn with iflag = 0 are made.
c
c info is an integer output variable. if the user has
c terminated execution, info is set to the (negative)
c value of iflag. see description of fcn. otherwise,
c info is set as follows.
c
c info = 0 improper input parameters.
c
c info = 1 both actual and predicted relative reductions
c in the sum of squares are at most ftol.
c
c info = 2 relative error between two consecutive iterates
c is at most xtol.
c
c info = 3 conditions for info = 1 and info = 2 both hold.
c
c info = 4 the cosine of the angle between fvec and any
c column of the jacobian is at most gtol in
c absolute value.
c
c info = 5 number of calls to fcn with iflag = 1 has
c reached maxfev.
c
c info = 6 ftol is too small. no further reduction in
c the sum of squares is possible.
c
c info = 7 xtol is too small. no further improvement in
c the approximate solution x is possible.
c
c info = 8 gtol is too small. fvec is orthogonal to the
c columns of the jacobian to machine precision.
c
c nfev is an integer output variable set to the number of
c calls to fcn with iflag = 1.
c
c njev is an integer output variable set to the number of
c calls to fcn with iflag = 2.
c
c ipvt is an integer output array of length N. ipvt
c defines a permutation matrix p such that jac*p = q*r,
c where jac is the final calculated jacobian, q is
c orthogonal (not stored), and r is upper triangular
c with diagonal elements of nonincreasing magnitude.
c column j of p is column ipvt(j) of the identity matrix.
c
c qtf is an output array of length N which contains
c the first n elements of the vector (q transpose)*fvec.
*/
wa1 = (double*) malloc(sizeof(double) *N);
wa2 = (double*) malloc(sizeof(double) *N);
wa3 = (double*) malloc(sizeof(double) *N);
wa4 = (double*) malloc(sizeof(double) *M);
one = 1.0;
zero = 0.0;
p1 = 1.0e-1;
p5 = 5.0e-1;
p25 = 2.5e-1;
p75 = 7.5e-1;
p0001 = 1.0e-4;
epsmch = eps;
info = 0;
*nfev = 0;
*njev = 0;
if (N <= 0 || M < N || ldfjac < M || ftol < zero || xtol < zero || gtol < zero || maxfev <= 0 || factor <= zero) {
return info;
}
if (mode == 2) {
for(j = 0; j < N; ++j) {
if (diag[j] <= 0.0) {
return info;
}
}
}
// evaluate the function at the starting point
// and calculate its norm.
FUNCMULT_EVAL(funcmult,x,M,N,fvec);
*nfev= 1;
fnorm = enorm(fvec,M);
// initialize levenberg-marquardt parameter and iteration counter.
par = zero;
iter = 1;
ratio = zero;
// beginning of the outer loop.
while(1) {
// calculate the jacobian matrix.
ratio = zero;
JACOBIAN_EVAL(jacobian,x,M,N,fjac);
*njev = *njev +1;
// compute the qr factorization of the jacobian.
qrfac(fjac,M,N,ldfjac,1,ipvt,N,wa1,wa2,eps);
// on the first iteration and if mode is 1, scale according
// to the norms of the columns of the initial jacobian.
if (iter == 1) {//80
if (mode != 2) {//60
for(j = 0; j < N; ++j) {
diag[j] = wa2[j];
if (wa2[j] == zero) {
diag[j] = one;
}
}
}//60
// on the first iteration, calculate the norm of the scaled x
// and initialize the step bound delta.
for(j = 0; j < N; ++j) {
wa3[j] = diag[j]*x[j];
}
xnorm = enorm(wa3,N);
delta = factor*xnorm;
if (delta == zero) {
delta = factor;
}
}//80
// form (q transpose)*fvec and store the first n components in
// qtf.
for(i = 0; i < M; ++i) {
wa4[i] = fvec[i];
}
for(j = 0; j < N; ++j) { //130
if (fjac[j*N+j] != zero) {//120
sum = zero;
for(i = j; i < M; ++i) { //100
sum = sum + fjac[i*N+j]*wa4[i];
}//100
temp = -sum/fjac[j*N+j];
for(i = j; i < M; ++i) { //110
wa4[i] = wa4[i] + fjac[i*N+j]*temp;
}//110
}//120
fjac[j*N+j] = wa1[j];
qtf[j] = wa4[j];
}//130
// compute the norm of the scaled gradient.
gnorm = zero;
if (fnorm != zero) {//170
for(j = 0; j < N; ++j) { //160
l = ipvt[j];
if (wa2[l] != zero) {//150
sum = zero;
for(i = 0; i <= j; ++i) { //140
sum = sum + fjac[i*N+j]*(qtf[i]/fnorm);
}//140
gnorm = pmax(gnorm,fabs(sum/wa2[l]));
}//150
}//160
}//170
// test for convergence of the gradient norm.
if (gnorm <= gtol) {
info = 4;
}
if (info != 0) {
break;
}
// rescale if necessary.
if (mode != 2) { //190
for(j = 0; j < N; ++j) {
diag[j] = pmax(diag[j],wa2[j]);
}
}//190
// beginning of the inner loop.
while(ratio < p0001) {
// determine the levenberg-marquardt parameter.
lmpar(fjac,ldfjac,N,ipvt,diag,qtf,delta,&par,wa1,wa2);
// store the direction p and x + p. calculate the norm of p.
for(j = 0; j < N; ++j) {
wa1[j] = -wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j]*wa1[j];
}
pnorm = enorm(wa3,N);
// on the first iteration, adjust the initial step bound.
if (iter == 1) {
delta = pmin(delta,pnorm);
}
// evaluate the function at x + p and calculate its norm.
FUNCMULT_EVAL(funcmult,wa2,M,N,wa4);
*nfev = *nfev + 1;
fnorm1 = enorm(wa4,M);
// compute the scaled actual reduction.
actred = -one;
if (p1*fnorm1 < fnorm) {
actred = one - (fnorm1/fnorm)*(fnorm1/fnorm);
}
// compute the scaled predicted reduction and
// the scaled directional derivative.
for(j = 0; j < N; ++j) {
wa3[j] = zero;
l = ipvt[j];
temp = wa1[l];
for(i = 0; i <= j; ++i) {
wa3[i] = wa3[i] + fjac[i*N+j]*temp;
}
}
temp1 = enorm(wa3,N);
temp1 = temp1/fnorm;
temp2 = (sqrt(par)*pnorm)/fnorm;
prered = temp1*temp1 + temp2*temp2/p5;
dirder = -(temp1*temp1 + temp2*temp2);
// compute the ratio of the actual to the predicted
// reduction.
ratio = zero;
if (prered != zero) {
ratio = actred/prered;
}
// update the step bound.
if (ratio <= p25) {//240
if (actred >= zero) {
temp = p5;
}
if (actred < zero) {
temp = p5*dirder/(dirder + p5*actred);
}
if (p1*fnorm1 >= fnorm || temp < p1) {
temp = p1;
}
delta = temp*pmin(delta,pnorm/p1);
par = par/temp;
} else if (par == zero || ratio >= p75) { //240 - 260
delta = pnorm/p5;
par = p5*par;
}//260
// test for successful iteration.
if (ratio >= p0001) {//290
// successful iteration. update x, fvec, and their norms.
for(j = 0; j < N; ++j) {
x[j] = wa2[j];
wa2[j] = diag[j]*x[j];
}
for(i = 0; i < M; ++i) {
fvec[i] = wa4[i];
}
xnorm = enorm(wa2,N);
fnorm = fnorm1;
iter = iter + 1;
}//290
// tests for convergence.
if ((fabs(actred) <= ftol) && (prered <= ftol) && (p5*ratio <= one)) {
info = 1;
}
if (delta <= xtol*xnorm) {
info = 2;
}
if ((fabs(actred) <= ftol) && (prered <= ftol) && (p5*ratio <= one) && (info == 2)) {
info = 3;
}
if (info != 0) {
break;
}
// tests for termination and stringent tolerances.
if (*nfev >= maxfev) {
info = 5;
}
if ((fabs(actred) <= epsmch) && (prered <= epsmch) && (p5*ratio <= one)) {
info = 6;
}
if (delta <= epsmch*xnorm) {
info = 7;
}
if (gnorm <= epsmch) {
info = 8;
}
if (info != 0) {
break;
}
}
if (info != 0) {
break;
}
}
free(wa1);
free(wa2);
free(wa3);
free(wa4);
return info;
}
static int
gnewton_iterate (void * vstate, gsl_multiroot_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx)
{
gnewton_state_t * state = (gnewton_state_t *) vstate;
int signum ;
double t, phi0, phi1;
size_t i;
size_t n = fdf->n ;
gsl_matrix_memcpy (state->lu, J);
gsl_linalg_LU_decomp (state->lu, state->permutation, &signum);
{
int status = gsl_linalg_LU_solve (state->lu, state->permutation, f, state->d);
if (status)
return status;
}
t = 1;
phi0 = state->phi;
new_step:
for (i = 0; i < n; i++)
{
double di = gsl_vector_get (state->d, i);
double xi = gsl_vector_get (x, i);
gsl_vector_set (state->x_trial, i, xi - t*di);
}
{
int status = GSL_MULTIROOT_FN_EVAL_F (fdf, state->x_trial, f);
if (status != GSL_SUCCESS)
{
return GSL_EBADFUNC;
}
}
phi1 = enorm (f);
if (phi1 > phi0 && t > GSL_DBL_EPSILON)
{
/* full step goes uphill, take a reduced step instead */
double theta = phi1 / phi0;
double u = (sqrt(1.0 + 6.0 * theta) - 1.0) / (3.0 * theta);
t *= u ;
goto new_step;
}
/* copy x_trial into x */
gsl_vector_memcpy (x, state->x_trial);
for (i = 0; i < n; i++)
{
double di = gsl_vector_get (state->d, i);
gsl_vector_set (dx, i, -t*di);
}
{
int status = GSL_MULTIROOT_FN_EVAL_DF (fdf, x, J);
if (status != GSL_SUCCESS)
{
return GSL_EBADFUNC;
}
}
state->phi = phi1;
return GSL_SUCCESS;
}
/* Subroutine */ void lmpar(int n, double *r__, int ldr,
const int *ipvt, const double *diag, const double *qtb, double delta,
double *par, double *x, double *sdiag, double *wa1,
double *wa2)
{
/* Initialized data */
#define p1 .1
#define p001 .001
/* System generated locals */
int r_dim1, r_offset, i__1, i__2;
double d__1, d__2;
/* Local variables */
int i__, j, k, l;
double fp;
int jm1, jp1;
double sum, parc, parl;
int iter;
double temp, paru, dwarf;
int nsing;
double gnorm;
double dxnorm;
/* ********** */
/* subroutine lmpar */
/* given an m by n matrix a, an n by n nonsingular diagonal */
/* matrix d, an m-vector b, and a positive number delta, */
/* the problem is to determine a value for the parameter */
/* par such that if x solves the system */
/* a*x = b , sqrt(par)*d*x = 0 , */
/* in the least squares sense, and dxnorm is the euclidean */
/* norm of d*x, then either par is zero and */
/* (dxnorm-delta) .le. 0.1*delta , */
/* or par is positive and */
/* abs(dxnorm-delta) .le. 0.1*delta . */
/* this subroutine completes the solution of the problem */
/* if it is provided with the necessary information from the */
/* qr factorization, with column pivoting, of a. that is, if */
/* a*p = q*r, where p is a permutation matrix, q has orthogonal */
/* columns, and r is an upper triangular matrix with diagonal */
/* elements of nonincreasing magnitude, then lmpar expects */
/* the full upper triangle of r, the permutation matrix p, */
/* and the first n components of (q transpose)*b. on output */
/* lmpar also provides an upper triangular matrix s such that */
/* t t t */
/* p *(a *a + par*d*d)*p = s *s . */
/* s is employed within lmpar and may be of separate interest. */
/* only a few iterations are generally needed for convergence */
/* of the algorithm. if, however, the limit of 10 iterations */
/* is reached, then the output par will contain the best */
/* value obtained so far. */
/* the subroutine statement is */
/* subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, */
/* wa1,wa2) */
/* where */
/* n is a positive integer input variable set to the order of r. */
/* r is an n by n array. on input the full upper triangle */
/* must contain the full upper triangle of the matrix r. */
/* on output the full upper triangle is unaltered, and the */
/* strict lower triangle contains the strict upper triangle */
/* (transposed) of the upper triangular matrix s. */
/* ldr is a positive integer input variable not less than n */
/* which specifies the leading dimension of the array r. */
/* ipvt is an integer input array of length n which defines the */
/* permutation matrix p such that a*p = q*r. column j of p */
/* is column ipvt(j) of the identity matrix. */
/* diag is an input array of length n which must contain the */
/* diagonal elements of the matrix d. */
/* qtb is an input array of length n which must contain the first */
/* n elements of the vector (q transpose)*b. */
/* delta is a positive input variable which specifies an upper */
/* bound on the euclidean norm of d*x. */
/* par is a nonnegative variable. on input par contains an */
/* initial estimate of the levenberg-marquardt parameter. */
/* on output par contains the final estimate. */
/* x is an output array of length n which contains the least */
/* squares solution of the system a*x = b, sqrt(par)*d*x = 0, */
/* for the output par. */
/* sdiag is an output array of length n which contains the */
/* diagonal elements of the upper triangular matrix s. */
/* wa1 and wa2 are work arrays of length n. */
/* subprograms called */
/* minpack-supplied ... dpmpar,enorm,qrsolv */
/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* Parameter adjustments */
--wa2;
--wa1;
--sdiag;
--x;
--qtb;
--diag;
--ipvt;
r_dim1 = ldr;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
/* Function Body */
/* dwarf is the smallest positive magnitude. */
dwarf = dpmpar(2);
/* compute and store in x the gauss-newton direction. if the */
/* jacobian is rank-deficient, obtain a least squares solution. */
nsing = n;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa1[j] = qtb[j];
if (r__[j + j * r_dim1] == 0. && nsing == n) {
nsing = j - 1;
}
if (nsing < n) {
wa1[j] = 0.;
}
/* L10: */
}
if (nsing < 1) {
goto L50;
}
i__1 = nsing;
for (k = 1; k <= i__1; ++k) {
j = nsing - k + 1;
wa1[j] /= r__[j + j * r_dim1];
temp = wa1[j];
jm1 = j - 1;
if (jm1 < 1) {
goto L30;
}
i__2 = jm1;
for (i__ = 1; i__ <= i__2; ++i__) {
wa1[i__] -= r__[i__ + j * r_dim1] * temp;
/* L20: */
}
L30:
/* L40: */
;
}
L50:
i__1 = n;
for (j = 1; j <= i__1; ++j) {
l = ipvt[j];
x[l] = wa1[j];
/* L60: */
}
/* initialize the iteration counter. */
/* evaluate the function at the origin, and test */
/* for acceptance of the gauss-newton direction. */
iter = 0;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa2[j] = diag[j] * x[j];
/* L70: */
}
dxnorm = enorm(n, &wa2[1]);
fp = dxnorm - delta;
if (fp <= p1 * delta) {
goto L220;
}
/* if the jacobian is not rank deficient, the newton */
/* step provides a lower bound, parl, for the zero of */
/* the function. otherwise set this bound to zero. */
parl = 0.;
if (nsing < n) {
goto L120;
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
l = ipvt[j];
wa1[j] = diag[l] * (wa2[l] / dxnorm);
/* L80: */
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
jm1 = j - 1;
if (jm1 < 1) {
goto L100;
}
i__2 = jm1;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += r__[i__ + j * r_dim1] * wa1[i__];
/* L90: */
}
L100:
wa1[j] = (wa1[j] - sum) / r__[j + j * r_dim1];
/* L110: */
}
temp = enorm(n, &wa1[1]);
parl = fp / delta / temp / temp;
L120:
/* calculate an upper bound, paru, for the zero of the function. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += r__[i__ + j * r_dim1] * qtb[i__];
/* L130: */
}
l = ipvt[j];
wa1[j] = sum / diag[l];
/* L140: */
}
gnorm = enorm(n, &wa1[1]);
paru = gnorm / delta;
if (paru == 0.) {
paru = dwarf / min(delta,p1);
}
/* if the input par lies outside of the interval (parl,paru), */
/* set par to the closer endpoint. */
*par = max(*par,parl);
*par = min(*par,paru);
if (*par == 0.) {
*par = gnorm / dxnorm;
}
/* beginning of an iteration. */
L150:
++iter;
/* evaluate the function at the current value of par. */
if (*par == 0.) {
/* Computing MAX */
d__1 = dwarf, d__2 = p001 * paru;
*par = max(d__1,d__2);
}
temp = sqrt(*par);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa1[j] = temp * diag[j];
/* L160: */
}
qrsolv(n, &r__[r_offset], ldr, &ipvt[1], &wa1[1], &qtb[1], &x[1], &sdiag[
1], &wa2[1]);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa2[j] = diag[j] * x[j];
/* L170: */
}
dxnorm = enorm(n, &wa2[1]);
temp = fp;
fp = dxnorm - delta;
/* if the function is small enough, accept the current value */
/* of par. also test for the exceptional cases where parl */
/* is zero or the number of iterations has reached 10. */
if (abs(fp) <= p1 * delta || (parl == 0. && fp <= temp && temp < 0.) ||
iter == 10) {
goto L220;
}
/* compute the newton correction. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
l = ipvt[j];
wa1[j] = diag[l] * (wa2[l] / dxnorm);
/* L180: */
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
wa1[j] /= sdiag[j];
temp = wa1[j];
jp1 = j + 1;
if (n < jp1) {
goto L200;
}
i__2 = n;
for (i__ = jp1; i__ <= i__2; ++i__) {
wa1[i__] -= r__[i__ + j * r_dim1] * temp;
/* L190: */
}
L200:
/* L210: */
;
}
temp = enorm(n, &wa1[1]);
parc = fp / delta / temp / temp;
/* depending on the sign of the function, update parl or paru. */
if (fp > 0.) {
parl = max(parl,*par);
}
if (fp < 0.) {
paru = min(paru,*par);
}
/* compute an improved estimate for par. */
/* Computing MAX */
d__1 = parl, d__2 = *par + parc;
*par = max(d__1,d__2);
/* end of an iteration. */
goto L150;
L220:
/* termination. */
if (iter == 0) {
*par = 0.;
}
return;
/* last card of subroutine lmpar. */
} /* lmpar_ */
/* PROCEDURE : lmpar
*
* ENTREE :
* n Ordre de la matrice "r".
* r Matrice de taille "n" x "n". En entree, la toute la partie
* triangulaire superieure doit contenir toute la partie triangulaire
* superieure de "r".
*
* ldr Taille maximum de la matrice "r". "ldr" >= "n".
*
* ipvt Vecteur de taille "n" qui definit la matrice de permutation "p"
* tel que :
* a * p = q * r.
* La jeme colonne de p la colonne ipvt[j] de la matrice d'identite.
*
* diag Vecteur de taille "n" contenant les elements diagonaux de la
* matrice "d".
*
* qtb Vecteur de taille "n" contenant les "n" premiers elements du
* vecteur (q transpose)*b.
*
* delta Limite superieure de la norme euclidienne de d * x.
*
* par Estimee initiale du parametre de Levenberg-Marquardt.
* wa1, wa2 Vecteurs de taille "n" de travail.
*
* DESCRIPTION :
* La procedure determine le parametre de Levenberg-Marquardt. Soit une matrice
* "a" de taille "m" x "n", une matrice diagonale "d" non singuliere de taille
* "n" x "n", un vecteur "b" de taille "m" et un nombre positf delta, le probleme
* est le calcul du parametre "par" de telle facon que si "x" resoud le systeme
*
* a * x = b , sqrt(par) * d * x = 0 ,
*
* au sens des moindre carre, et dxnorm est la norme euclidienne de d * x
* alors "par" vaut 0.0 et (dxnorm - delta) <= 0.1 * delta ,
* ou "par" est positif et abs(dxnorm-delta) <= 0.1 * delta.
* Cette procedure complete la solution du probleme si on lui fourni les infos
* nessaires de la factorisation qr, avec pivotage de colonnes de a.
* Donc, si a * p = q * r, ou "p" est une matrice de permutation, les colonnes
* de "q" sont orthogonales, et "r" est une matrice triangulaire superieure
* avec les elements diagonaux classes par ordre decroissant de leur valeur, lmpar
* attend une matrice triangulaire superieure complete, la matrice de permutation
* "p" et les "n" premiers elements de (q transpose) * b. En sortie, la procedure
* lmpar fournit aussi une matrice triangulaire superieure "s" telle que
*
* t t t
* p * (a * a + par * d * d )* p = s * s .
*
* "s" est utilise a l'interieure de lmpar et peut etre d'un interet separe.
*
* Seulement quelques iterations sont necessaire pour la convergence de
* l'algorithme. Si neanmoins la limite de 10 iterations est atteinte, la
* valeur de sortie "par" aura la derniere meilleure valeur.
*
* SORTIE :
* r En sortie, tout le triangle superieur est inchange, et le
* le triangle inferieur contient les elements de la partie
* triangulaire superieure (transpose) de la matrice triangulaire
* superieure de "s".
* par Estimee finale du parametre de Levenberg-Marquardt.
* x Vecteur de taille "n" contenant la solution au sens des moindres
* carres du systeme a * x = b, sqrt(par) * d * x = 0, pour le
* parametre en sortie "par"
* sdiag Vecteur de taille "n" contenant les elements diagonaux de la
* matrice triangulaire "s".
*
* RETOUR :
* En cas de succes, la valeur 0.0 est retournee.
*
*/
int lmpar(int n, double *r, int ldr, int *ipvt, double *diag, double *qtb,
double *delta, double *par, double *x, double *sdiag, double *wa1, double *wa2)
{
const double tol1 = 0.1, tol001 = 0.001; /* tolerance a 0.1 et a 0.001 */
long i, j, jm1, jp1, k, l; /* compteur de boucle */
int iter; /* compteur d'iteration */
int nsing; /* nombre de singularite de la matrice */
double dxnorm, fp, gnorm, parc;
double parl, paru; /* borne inf et sup de par */
double sum, temp;
double dwarf = DBL_MIN; /* plus petite amplitude positive */
/*
* calcul et stockage dans "x" de la direction de Gauss-Newton. Si
* le jacobien a une rangee de moins, on a une solution au moindre
* carres.
*/
nsing = n;
for (i = 0; i < (long) n; i++)
{
wa1[i] = qtb[i];
if (*MIJ(r, i, i, ldr) == 0.0 && nsing == n)
nsing = (int) i - 1;
if (nsing < n)
wa1[i] = 0.0;
}
if ((int) nsing >= 0)
{
for (k = 0; k < (long) nsing; k++)
{
i = nsing - 1 - k;
wa1[i] /= *MIJ(r, i, i, ldr);
temp = wa1[i];
jm1 = i - 1;
if (jm1 >= 0)
{
for (j = 0; j <= jm1; j++)
wa1[j] -= *MIJ(r, i, j, ldr) * temp;
}
}
}
for (j = 0; j < (long) n; j++)
{
l = ipvt[j];
x[l] = wa1[j];
}
/*
* initialisation du compteur d'iteration.
* evaluation de la fonction a l'origine, et test
* d'acceptation de la direction de Gauss-Newton.
*/
iter = 0;
for (i = 0; i < (long) n; i++)
wa2[i] = diag[i] * x[i];
dxnorm = enorm(wa2, n);
fp = dxnorm - *delta;
if (fp > tol1 * (*delta))
{
/*
* Si le jacobien n'a pas de rangee deficiente,l'etape de
* Newton fournit une limite inferieure, parl pour le
* zero de la fonction. Sinon cette limite vaut 0.0.
*/
parl = 0.0;
if (nsing >= n)
{
for (i = 0; i < (long) n; i++)
{
l = ipvt[i];
wa1[i] = diag[l] * (wa2[l] / dxnorm);
}
for (i = 0; i < (long) n; i++)
{
long im1;
sum = 0.0;
im1 = (i - 1L);
if (im1 >= 0)
{
for (j = 0; j <= im1; j++)
sum += (*MIJ(r, i, j, ldr) * wa1[j]);
}
wa1[i] = (wa1[i] - sum) / *MIJ(r, i, i, ldr);
}
temp = enorm(wa1, n);
parl = ((fp / *delta) / temp) / temp;
}
/*
* calcul d'une limite superieure, paru, pour le zero de la
* fonction.
*/
for (i = 0; i < (long) n; i++)
{
sum = 0.0;
for (j = 0; j <= i; j++)
sum += *MIJ(r, i, j, ldr) * qtb[j];
l = ipvt[i];
wa1[i] = sum / diag[l];
}
gnorm = enorm(wa1, n);
paru = gnorm / *delta;
if (paru == 0.0)
paru = dwarf / vpMath::minimum(*delta, tol1);
/*
* Si "par" en entree tombe hors de l'intervalle (parl,paru),
* on le prend proche du point final.
*/
*par = vpMath::maximum(*par, parl);
*par = vpMath::minimum(*par, paru);
if (*par == 0.0)
*par = gnorm / dxnorm;
/*
* debut d'une iteration.
*/
while (iter >= 0)
{
iter++;
/*
* evaluation de la fonction a la valeur courant
* de "par".
*/
if (*par == 0.0)
*par = vpMath::maximum(dwarf, (tol001 * paru));
temp = sqrt(*par);
for (i = 0; i < (long) n; i++)
wa1[i] = temp * diag[i];
qrsolv(n, r, ldr, ipvt, wa1, qtb, x, sdiag, wa2);
for (i = 0; i < (long) n; i++)
wa2[i] = diag[i] * x[i];
dxnorm = enorm(wa2, n);
temp = fp;
fp = dxnorm - *delta;
/*
* si la fonction est assez petite, acceptation de
* la valeur courant de "par". de plus, test des cas
* ou parl est nul et ou le nombre d'iteration a
* atteint 10.
*/
if ((fabs(fp) <= tol1 * *delta) || ((parl == 0.0) && (fp <= temp)
&& (temp < 0.0)) || (iter == 10))
{
/*
* terminaison.
*/
if (iter == 0)
*par = 0.0;
return (0);
}
/*
* calcul de la correction de Newton.
*/
for (i = 0; i < (long) n; i++)
{
l = ipvt[i];
wa1[i] = diag[l] * (wa2[l] / dxnorm);
}
for (i = 0; i < (long) n; i++)
{
wa1[i] = wa1[i] / sdiag[i];
temp = wa1[i];
jp1 = i + 1;
if ( (long) n >= jp1)
{
for (j = jp1; j < (long) n; j++)
wa1[j] -= (*MIJ(r, i, j, ldr) * temp);
}
}
temp = enorm(wa1, n);
parc = ((fp / *delta) / temp) / temp;
/*
* selon le signe de la fonction, mise a jour
* de parl ou paru.
*/
if (fp > 0.0)
parl = vpMath::maximum(parl, *par);
if (fp < 0.0)
paru = vpMath::minimum(paru, *par);
/*
* calcul d'une estimee ameliree de "par".
*/
*par = vpMath::maximum(parl, (*par + parc));
}/* fin boucle sur iter */
}/* fin fp > tol1 * delta */
/*
* terminaison.
*/
if (iter == 0)
*par = 0.0;
return (0);
}
/*
* PROCEDURE : qrfac
*
* ENTREE :
* m Nombre de lignes de la matrice "a".
* n Nombre de colonne de la matrice "a".
* a Matrice de taille "m" x "n". elle contient, en entree la matrice
* dont on veut sa factorisation qr.
* lda Taille maximale de "a". lda >= m.
* pivot Booleen. Si pivot est TRUE, le pivotage de colonnes est realise
* Si pivot = FALSE, pas de pivotage.
* lipvt Taille du vecteur "ipvt". Si pivot est FALSE, lipvt est de
* l'ordre de 1. Sinon lipvt est de l'ordre de "n".
* wa Vecteur de travail de taille "n". Si pivot = FALSE "wa"
* coincide avec rdiag.
*
* DESCRIPTION :
* La procedure effectue une decomposition de la matrice "a"par la methode qr.
* Elle utilise les transformations de householders avec pivotage sur les colonnes
* (option) pour calculer la factorisation qr de la matrice "a" de taille "m" x "n".
* La procedure determine une matrice orthogonale "q", une matrice de permutation
* "p" et une matrice trapesoidale superieure "r" dont les elements diagonaux
* sont ordonnes dans l'ordre decroissant de leurs valeurs,tel que a * p = q * r.
* La transformation de householder pour la colonne k, k = 1,2,...,min(m,n),
* est de la forme
* t
* i - (1 / u(k)) * u * u
*
* Ou u a des zeros dans les k-1 premieres positions.
*
* SORTIE :
* a Matrice de taille "m" x "n" dont le trapeze superieur de "a"
* contient la partie trapezoidale superieure de "r" et la partie
* trapezoidale inferieure de "a" contient une forme factorisee
* de "q" (les elements non triviaux du vecteurs "u" sont decrits
* ci-dessus).
* ipvt Vecteur de taille "n". Il definit la matrice de permutation "p"
* tel que a * p = q * r. La jeme colonne de p est la colonne
* ipvt[j] de la matrice d'identite. Si pivot = FALSE, ipvt n'est
* pas referencee.
* rdiag Vecteur de taille "n" contenant les elements diagonaux de la
* matrice "r".
* acnorm Vecteur de taille "n" contenant les normes des lignes
* correspondantes de la matrice "a". Si cette information n'est
* pas requise, acnorm coincide avec rdiag.
*
*/
int qrfac(int m, int n, double *a, int lda, int *pivot, int *ipvt,
int /* lipvt */, double *rdiag, double *acnorm, double *wa)
{
const double tolerance = 0.05;
int i, j, ip1, k, kmax, minmn;
double ajnorm, epsmch;
double sum, temp, tmp;
/*
* epsmch est la precision machine.
*/
epsmch = DBL_EPSILON;
/*
* calcul des normes initiales des lignes et initialisation
* de plusieurs tableaux.
*/
for (i = 0; i < m; i++)
{
acnorm[i] = enorm(MIJ(a, i, 0, lda), n);
rdiag[i] = acnorm[i];
wa[i] = rdiag[i];
if (pivot)
ipvt[i] = i;
}
/*
* reduction de "a" en "r" avec les tranformations de Householder.
*/
minmn = vpMath::minimum(m, n);
for (i = 0; i < minmn; i++)
{
if (pivot)
{
/*
* met la ligne de plus grande norme en position
* de pivot.
*/
kmax = i;
for (k = i; k < m; k++)
{
if (rdiag[k] > rdiag[kmax])
kmax = k;
}
if (kmax != i)
{
for (j = 0; j < n; j++)
SWAP(*MIJ(a, i, j, lda),
*MIJ(a, kmax, j, lda), tmp);
rdiag[kmax] = rdiag[i];
wa[kmax] = wa[i];
SWAP( ipvt[i], ipvt[kmax], k);
}
}
/*
* calcul de al transformationde Householder afin de reduire
* la jeme ligne de "a" a un multiple du jeme vecteur unite.
*/
ajnorm = enorm(MIJ(a, i, i, lda), n - i);
if (ajnorm != 0.0)
{
if (*MIJ(a, i, i, lda) < 0.0)
ajnorm = -ajnorm;
for (j = i; j < n; j++)
*MIJ(a, i, j, lda) /= ajnorm;
*MIJ(a, i, i, lda) += 1.0;
/*
* application de la tranformation aux lignes
* restantes et mise a jour des normes.
*/
ip1 = i + 1;
if (m >= ip1)
{
for (k = ip1; k < m; k++)
{
sum = 0.0;
for (j = i; j < n; j++)
sum += *MIJ(a, i, j, lda) * *MIJ(a, k, j, lda);
temp = sum / *MIJ(a, i, i, lda);
for (j = i; j < n; j++)
*MIJ(a, k, j, lda) -= temp * *MIJ(a, i, j, lda);
if (pivot && rdiag[k] != 0.0)
{
temp = *MIJ (a, k, i, lda) / rdiag[k];
rdiag[k] *= sqrt(vpMath::maximum(0.0, (1.0 - temp * temp)));
if (tolerance * (rdiag[k] / wa[k]) * (rdiag[k] / wa[k]) <= epsmch)
{
rdiag[k] = enorm(MIJ(a, k, ip1, lda), (n -1 - (int) i));
wa[k] = rdiag[k];
}
}
}/* fin boucle for k */
}
} /* fin if (ajnorm) */
rdiag[i] = -ajnorm;
} /* fin for (i = 0; i < minmn; i++) */
return (0);
}
/*
* PROCEDURE : lmder
*
*
* ENTREE :
* fcn Fonction qui calcule la fonction et le jacobien de la fonction.
* m Nombre de fonctions.
* n Nombre de variables. n <= m
* x Vecteur de taille "n" contenant en entree une estimation
* initiale de la solution.
* ldfjac Taille dominante de la matrice "fjac". ldfjac >= "m".
* ftol Erreur relative desiree dans la somme des carre. La terminaison
* survient quand les preductions estimee et vraie de la somme des
* carres sont toutes deux au moins egal a ftol.
* xtol Erreur relative desiree dans la solution approximee. La
* terminaison survient quand l'erreur relative entre deux
* iterations consecutives est au moins egal a xtol.
* gtol Mesure de l'orthogonalité entre le vecteur des fonctions et les
* colonnes du jacobien. La terminaison survient quand le cosinus
* de l'angle entre fvec et n'importe quelle colonne du jacobien
* est au moins egal a gtol, en valeur absolue.
* maxfev Nombre d'appel maximum. La terminaison se produit lorsque le
* nombre d'appel a fcn avec iflag = 1 a atteint "maxfev".
* diag Vecteur de taille "n". Si mode = 1 (voir ci-apres), diag est
* initialisee en interne. Si mode = 2, diag doit contenir les
* entree positives qui servent de facteurs d'echelle aux variables.
* mode Si mode = 1, les variables seront mis a l'echelle en interne.
* Si mode = 2, la mise a l'echelle est specifie par l'entree diag.
* Les autres valeurs de mode sont equivalents a mode = 1.
* factor Definit la limite de l'etape initial. Cette limite est initialise
* au produit de "factor" et de la norme euclidienne de "diag" * "x"
* sinon nul. ou a "factor" lui meme. Dans la plupart des cas,
* "factor" doit se trouve dans l'intervalle (1, 100); ou 100 est
* la valeur recommandee.
* nprint Controle de l'impression des iterees (si valeur positive).
* Dans ce cas, fcn est appelle avec iflag = 0 au debut de la
* premiere iteration et apres chaque nprint iteration, x, fvec,
* et fjac sont disponible pour impression, cela avant de quitter
* la procedure. Si "nprint" est negatif, aucun appel special de
* fcn est faite.
* wa1, wa2, wa3 Vecteur de travail de taille "n".
* wa4 Vecteur de travail de taille "m".
*
*
* SORTIE :
* x Vecteur de taille "n" contenant en sortie l'estimee finale
* de la solution.
* fvec Vecteur de taille "m" contenant les fonctions evaluee en "x".
* fjac Matrice de taille "m" x "n". La sous matrice superieure de
* taille "n" x "n" de fjac contient une matrice triangulaire
* superieure r dont les elements diagonaux, classe dans le sens
* decroissant de leur valeur, sont de la forme :
*
* T T T
* p * (jac * jac) * p = r * r
*
* Ou p est une matrice de permutation et jac est le jacobien
* final calcule.
* La colonne j de p est la colonne ipvt (j) (voir ci apres) de
* la matrice identite. La partie trapesoidale inferieure de fjac
* contient les informations genere durant le calcul de r.
* info Information de l'execution de la procedure. Lorsque la procedure
* a termine son execution, "info" est inialisee a la valeur
* (negative) de iflag. sinon elle prend les valeurs suivantes :
* info = 0 : parametres en entree non valides.
* info = 1 : les reductions relatives reelle et estimee de la
* somme des carres sont au moins egales a ftol.
* info = 2 : erreur relative entre deux iteres consecutives sont
* egaux a xtol.
* info = 3 : conditions info = 1 et info = 2 tous deux requis.
* info = 4 : le cosinus de l'angle entre fvec et n'importe quelle
* colonne du jacobien est au moins egal a gtol, en
* valeur absolue.
* info = 5 : nombre d'appels a fcn avec iflag = 1 a atteint
* maxfev.
* info = 6 : ftol est trop petit. Plus moyen de reduire de la
* somme des carres.
* info = 7 : xtol est trop petit. Plus d'amelioration possible
* pour approximer la solution x.
* info = 8 : gtol est trop petit. "fvec" est orthogonal aux
* colonnes du jacobien a la precision machine pres.
* nfev Nombre d'appel a "fcn" avec iflag = 1.
* njev Nombre d'appel a "fcn" avec iflag = 2.
* ipvt Vecteur de taille "n". Il definit une matrice de permutation p
* tel que jac * p = q * p, ou jac est le jacbien final calcule,
* q est orthogonal (non socke) et r est triangulaire superieur,
* avec les elements diagonaux classes en ordre decroissant de
* leur valeur. La colonne j de p est ipvt[j] de la matrice identite.
* qtf Vecteur de taille n contenant les n premiers elements du
* vecteur qT * fvec.
*
* DESCRIPTION :
* La procedure minimize la somme de carre de m equation non lineaire a n
* variables par une modification de l'algorithme de Levenberg - Marquardt.
*
* REMARQUE :
* L'utilisateur doit fournir une procedure "fcn" qui calcule la fonction et
* le jacobien.
* "fcn" doit etre declare dans une instruction externe a la procedure et doit
* etre appele comme suit :
* fcn (int m, int n, int ldfjac, double *x, double *fvec, double *fjac, int *iflag)
*
* si iflag = 1 calcul de la fonction en x et retour de ce vecteur dans fvec.
* fjac n'est pas modifie.
* si iflag = 2 calcul du jacobien en x et retour de cette matrice dans fjac.
* fvec n'est pas modifie.
*
* RETOUR :
* En cas de succes, la valeur zero est retournee.
* Sinon la valeur -1 est retournee.
*/
int lmder (void (*ptr_fcn)(int m, int n, double *xc, double *fvecc,
double *jac, int ldfjac, int iflag), int m, int n, double *x,
double *fvec, double *fjac, int ldfjac, double ftol, double xtol,
double gtol, int maxfev, double *diag, int mode,
const double factor, int nprint, int *info, int *nfev,
int *njev, int *ipvt, double *qtf, double *wa1, double *wa2,
double *wa3, double *wa4)
{
const double tol1 = 0.1, tol5 = 0.5, tol25 = 0.25, tol75 = 0.75, tol0001 = 0.0001;
int oncol = TRUE;
int iflag, iter, count = 0;
int i, j, l;
double actred, delta, dirder, epsmch, fnorm, fnorm1, gnorm;
double ratio = DBL_EPSILON;
double par, pnorm, prered;
double sum, temp, temp1, temp2, xnorm = 0.0;
/* epsmch est la precision machine. */
epsmch = DBL_EPSILON;
*info = 0;
iflag = 0;
*nfev = 0;
*njev = 0;
/* verification des parametres d'entree. */
if ((n <= 0) || (m < n) || (ldfjac < m) || (ftol < 0.0) || (xtol < 0.0)
|| (gtol < 0.0) || (maxfev <= 0) || (factor <= 0.0))
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
if (mode == 2)
{
for (j = 0; j < n; j++)
{
if (diag[j] <= 0.0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
}
}
/*
* evaluation de la fonction au point de depart
* et calcul de sa norme.
*/
iflag = 1;
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
*nfev = 1;
if (iflag < 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
fnorm = enorm(fvec, m);
/*
* initialisation du parametre de Levenberg-Marquardt
* et du conteur d'iteration.
*/
par = 0.0;
iter = 1;
/*
* debut de la boucle la plus externe.
*/
while (count < maxfev)
{
count++;
/*
* calcul de la matrice jacobienne.
*/
iflag = 2;
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
(*njev) ++;
if (iflag < 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
/*
* si demandee, appel de fcn pour impression des iterees.
*/
if (nprint > 0)
{
iflag = 0;
if ((iter-1) % nprint == 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
if (iflag < 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
}
/*
* calcul de la factorisation qr du jacobien.
*/
qrfac(n, m, fjac, ldfjac, &oncol, ipvt, n, wa1, wa2, wa3);
/*
* a la premiere iteration et si mode est 1, mise a l'echelle
* en accord avec les normes des colonnes du jacobien initial.
*/
if (iter == 1)
{
if (mode != 2)
{
for (j = 0; j < n; j++)
{
diag[j] = wa2[j];
if (wa2[j] == 0.0)
diag[j] = 1.0;
}
}
/*
* a la premiere iteration, calcul de la norme de x mis
* a l'echelle et initialisation de la limite delta de
* l'etape.
*/
for (j = 0; j < n; j++)
wa3[j] = diag[j] * x[j];
xnorm = enorm (wa3, n);
delta = factor * xnorm;
if (delta == 0.0)
delta = factor;
}
/*
* formation de (q transpose) * fvec et stockage des n premiers
* composants dans qtf.
*/
for (i = 0; i < m; i++)
wa4[i] = fvec[i];
for (i = 0; i < n; i++)
{
if (*MIJ(fjac, i, i, ldfjac) != 0.0)
{
sum = 0.0;
for (j = i; j < m; j++)
sum += *MIJ(fjac, i, j, ldfjac) * wa4[j];
temp = - sum / *MIJ(fjac, i, i, ldfjac);
for (j = i; j < m; j++)
wa4[j] += *MIJ(fjac, i, j, ldfjac) * temp;
}
*MIJ(fjac, i, i, ldfjac) = wa1[i];
qtf[i] = wa4[i];
}
/*
* calcul de la norme du gradient mis a l'echelle.
*/
gnorm = 0.0;
if (fnorm != 0.0)
{
for (i = 0; i < n; i++)
{
l = ipvt[i];
if (wa2[l] != 0.0)
{
sum = 0.0;
for (j = 0; j <= i; j++)
sum += *MIJ(fjac, i, j, ldfjac) * (qtf[j] / fnorm);
gnorm = vpMath::maximum(gnorm, fabs(sum / wa2[l]));
}
}
}
/*
* test pour la convergence de la norme du gradient .
*/
if (gnorm <= gtol)
*info = 4;
if (*info != 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
/*
* remise a l'echelle si necessaire.
*/
if (mode != 2)
{
for (j = 0; j < n; j++)
diag[j] = vpMath::maximum(diag[j], wa2[j]);
}
/*
* debut de la boucle la plus interne.
*/
ratio = 0.0;
while (ratio < tol0001)
{
/*
* determination du parametre de Levenberg-Marquardt.
*/
lmpar(n, fjac, ldfjac, ipvt, diag, qtf, &delta, &par, wa1,
wa2, wa3, wa4);
/*
* stockage de la direction p et x + p. calcul de la norme de p.
*/
for (j = 0; j < n; j++)
{
wa1[j] = - wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j] * wa1[j];
}
pnorm = enorm(wa3, n);
/*
* a la premiere iteration, ajustement de la premiere limite de
* l'etape.
*/
if (iter == 1)
delta = vpMath::minimum(delta, pnorm);
/*
* evaluation de la fonction en x + p et calcul de leur norme.
*/
iflag = 1;
(*ptr_fcn)(m, n, wa2, wa4, fjac, ldfjac, iflag);
(*nfev)++;
if (iflag < 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
fnorm1 = enorm(wa4, m);
/*
* calcul de la reduction reelle mise a l'echelle.
*/
actred = - 1.0;
if ((tol1 * fnorm1) < fnorm)
actred = 1.0 - ((fnorm1 / fnorm) * (fnorm1 / fnorm));
/*
* calcul de la reduction predite mise a l'echelle et
* de la derivee directionnelle mise a l'echelle.
*/
for (i = 0; i < n; i++)
{
wa3[i] = 0.0;
l = ipvt[i];
temp = wa1[l];
for (j = 0; j <= i; j++)
wa3[j] += *MIJ(fjac, i, j, ldfjac) * temp;
}
temp1 = enorm(wa3, n) / fnorm;
temp2 = (sqrt(par) * pnorm) / fnorm;
prered = (temp1 * temp1) + (temp2 * temp2) / tol5;
dirder = - ((temp1 * temp1) + (temp2 * temp2));
/*
* calcul du rapport entre la reduction reel et predit.
*/
ratio = 0.0;
if (prered != 0.0)
ratio = actred / prered;
/*
* mise a jour de la limite de l'etape.
*/
if (ratio > tol25)
{
if ((par == 0.0) || (ratio <= tol75))
{
delta = pnorm / tol5;
par *= tol5;
}
}
else
{
if (actred >= 0.0)
temp = tol5;
else
temp = tol5 * dirder / (dirder + tol5 * actred);
if ((tol1 * fnorm1 >= fnorm) || (temp < tol1))
temp = tol1;
delta = temp * vpMath::minimum(delta, (pnorm / tol1));
par /= temp;
}
/*
* test pour une iteration reussie.
*/
if (ratio >= tol0001)
{
/*
* iteration reussie. mise a jour de x, de fvec, et de
* leurs normes.
*/
for (j = 0; j < n; j++)
{
x[j] = wa2[j];
wa2[j] = diag[j] * x[j];
}
for (i = 0; i < m; i++)
fvec[i] = wa4[i];
xnorm = enorm(wa2, n);
fnorm = fnorm1;
iter++;
}
/*
* tests pour convergence.
*/
if ((fabs(actred) <= ftol) && (prered <= ftol) && (tol5 * ratio <= 1.0))
*info = 1;
if (delta <= xtol * xnorm)
*info = 2;
if ((fabs(actred) <= ftol) && (prered <= ftol) && (tol5 * ratio <= 1.0)
&& *info == 2)
*info = 3;
if (*info != 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m,n,x,fvec,fjac,ldfjac, iflag);
return (count);
}
/*
* tests pour termination et
* verification des tolerances.
*/
if (*nfev >= maxfev)
*info = 5;
if ((fabs(actred) <= epsmch) && (prered <= epsmch)
&& (tol5 * ratio <= 1.0))
*info = 6;
if (delta <= epsmch * xnorm)
*info = 7;
if (gnorm <= epsmch)
*info = 8;
if (*info != 0)
{
/*
* termination, normal ou imposee par l'utilisateur.
*/
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
(*ptr_fcn)(m, n, x, fvec, fjac, ldfjac, iflag);
return (count);
}
}/* fin while ratio >=tol0001 */
}/*fin while 1*/
return 0 ;
}
/*
* **********
*
* subroutine lmdif
*
* the purpose of lmdif is to minimize the sum of the squares of
* m nonlinear functions in n variables by a modification of
* the levenberg-marquardt algorithm. the user must provide a
* subroutine which calculates the functions. the jacobian is
* then calculated by a forward-difference approximation.
*
* the subroutine statement is
*
* subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
* diag,mode,factor,nprint,info,nfev,fjac,
* ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
*
* where
*
* fcn is the name of the user-supplied subroutine which
* calculates the functions. fcn must be declared
* in an external statement in the user calling
* program, and should be written as follows.
*
* subroutine fcn(m,n,x,fvec,iflag)
* integer m,n,iflag
* double precision x(n),fvec(m)
* ----------
* calculate the functions at x and
* return this vector in fvec.
* ----------
* return
* end
*
* the value of iflag should not be changed by fcn unless
* the user wants to terminate execution of lmdif.
* in this case set iflag to a negative integer.
*
* m is a positive integer input variable set to the number
* of functions.
*
* n is a positive integer input variable set to the number
* of variables. n must not exceed m.
*
* x is an array of length n. on input x must contain
* an initial estimate of the solution vector. on output x
* contains the final estimate of the solution vector.
*
* fvec is an output array of length m which contains
* the functions evaluated at the output x.
*
* ftol is a nonnegative input variable. termination
* occurs when both the actual and predicted relative
* reductions in the sum of squares are at most ftol.
* therefore, ftol measures the relative error desired
* in the sum of squares.
*
* xtol is a nonnegative input variable. termination
* occurs when the relative error between two consecutive
* iterates is at most xtol. therefore, xtol measures the
* relative error desired in the approximate solution.
*
* gtol is a nonnegative input variable. termination
* occurs when the cosine of the angle between fvec and
* any column of the jacobian is at most gtol in absolute
* value. therefore, gtol measures the orthogonality
* desired between the function vector and the columns
* of the jacobian.
*
* maxfev is a positive integer input variable. termination
* occurs when the number of calls to fcn is at least
* maxfev by the end of an iteration.
*
* epsfcn is an input variable used in determining a suitable
* step length for the forward-difference approximation. this
* approximation assumes that the relative errors in the
* functions are of the order of epsfcn. if epsfcn is less
* than the machine precision, it is assumed that the relative
* errors in the functions are of the order of the machine
* precision.
*
* diag is an array of length n. if mode = 1 (see
* below), diag is internally set. if mode = 2, diag
* must contain positive entries that serve as
* multiplicative scale factors for the variables.
*
* mode is an integer input variable. if mode = 1, the
* variables will be scaled internally. if mode = 2,
* the scaling is specified by the input diag. other
* values of mode are equivalent to mode = 1.
*
* factor is a positive input variable used in determining the
* initial step bound. this bound is set to the product of
* factor and the euclidean norm of diag*x if nonzero, or else
* to factor itself. in most cases factor should lie in the
* interval (.1,100.). 100. is a generally recommended value.
*
* nprint is an integer input variable that enables controlled
* printing of iterates if it is positive. in this case,
* fcn is called with iflag = 0 at the beginning of the first
* iteration and every nprint iterations thereafter and
* immediately prior to return, with x and fvec available
* for printing. if nprint is not positive, no special calls
* of fcn with iflag = 0 are made.
*
* info is an integer output variable. if the user has
* terminated execution, info is set to the (negative)
* value of iflag. see description of fcn. otherwise,
* info is set as follows.
*
* info = 0 improper input parameters.
*
* info = 1 both actual and predicted relative reductions
* in the sum of squares are at most ftol.
*
* info = 2 relative error between two consecutive iterates
* is at most xtol.
*
* info = 3 conditions for info = 1 and info = 2 both hold.
*
* info = 4 the cosine of the angle between fvec and any
* column of the jacobian is at most gtol in
* absolute value.
*
* info = 5 number of calls to fcn has reached or
* exceeded maxfev.
*
* info = 6 ftol is too small. no further reduction in
* the sum of squares is possible.
*
* info = 7 xtol is too small. no further improvement in
* the approximate solution x is possible.
*
* info = 8 gtol is too small. fvec is orthogonal to the
* columns of the jacobian to machine precision.
*
* nfev is an integer output variable set to the number of
* calls to fcn.
*
* fjac is an output m by n array. the upper n by n submatrix
* of fjac contains an upper triangular matrix r with
* diagonal elements of nonincreasing magnitude such that
*
* t t t
* p *(jac *jac)*p = r *r,
*
* where p is a permutation matrix and jac is the final
* calculated jacobian. column j of p is column ipvt(j)
* (see below) of the identity matrix. the lower trapezoidal
* part of fjac contains information generated during
* the computation of r.
*
* ldfjac is a positive integer input variable not less than m
* which specifies the leading dimension of the array fjac.
*
* ipvt is an integer output array of length n. ipvt
* defines a permutation matrix p such that jac*p = q*r,
* where jac is the final calculated jacobian, q is
* orthogonal (not stored), and r is upper triangular
* with diagonal elements of nonincreasing magnitude.
* column j of p is column ipvt(j) of the identity matrix.
*
* qtf is an output array of length n which contains
* the first n elements of the vector (q transpose)*fvec.
*
* wa1, wa2, and wa3 are work arrays of length n.
*
* wa4 is a work array of length m.
*
* subprograms called
*
* user-supplied ...... fcn
*
* minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac
*
* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod
*
* argonne national laboratory. minpack project. march 1980.
* burton s. garbow, kenneth e. hillstrom, jorge j. more
*
* **********
*/
void lmdif_C(
void (*fcn)(int, int, double[], double[], int *, void *),
int m,
int n,
double x[],
double fvec[],
double ftol,
double xtol,
double gtol,
int maxfev,
double epsfcn,
double diag[],
int mode,
double factor,
int nprint,
int *info,
int *nfev,
double fjac[],
int ldfjac,
int ipvt[],
double qtf[],
double wa1[],
double wa2[],
double wa3[],
double wa4[],
void *data)
{
int i;
int iflag;
int ij;
int jj;
int iter;
int j;
int l;
double actred;
double delta;
double dirder;
double fnorm;
double fnorm1;
double gnorm;
double par;
double pnorm;
double prered;
double ratio;
double sum;
double temp;
double temp1;
double temp2;
double temp3;
double xnorm;
static double one = 1.0;
static double p1 = 0.1;
static double p5 = 0.5;
static double p25 = 0.25;
static double p75 = 0.75;
static double p0001 = 1.0e-4;
static double zero = 0.0;
//static double p05 = 0.05;
*info = 0;
iflag = 0;
*nfev = 0;
/*
* check the input parameters for errors.
*/
if ((n <= 0) || (m < n) || (ldfjac < m) || (ftol < zero)
|| (xtol < zero) || (gtol < zero) || (maxfev <= 0)
|| (factor <= zero))
goto L300;
if (mode == 2)
{
/* scaling by diag[] */
for (j=0; j<n; j++)
{
if (diag[j] <= 0.0)
goto L300;
}
}
#ifdef BUG
printf( "lmdif\n" );
#endif
/* evaluate the function at the starting point
* and calculate its norm.
*/
iflag = 1;
fcn(m,n,x,fvec,&iflag, data);
*nfev = 1;
if (iflag < 0)
goto L300;
fnorm = enorm(m,fvec);
/* initialize levenberg-marquardt parameter and iteration counter. */
par = zero;
iter = 1;
/* beginning of the outer loop. */
L30:
/* calculate the jacobian matrix. */
iflag = 2;
fdjac2(fcn, m,n,x,fvec,fjac,ldfjac,&iflag,epsfcn,wa4, data);
// commented out DKB
// *nfev += n;
if (iflag < 0)
goto L300;
/* if requested, call fcn to enable printing of iterates. */
if (nprint > 0)
{
iflag = 0;
if (mod(iter-1,nprint) == 0)
{
fcn(m,n,x,fvec,&iflag, data);
if (iflag < 0)
goto L300;
// printf( "fnorm %.15e\n", enorm(m,fvec));
}
}
/* compute the qr factorization of the jacobian. */
qrfac(m,n,fjac,ldfjac,1,ipvt,n,wa1,wa2,wa3);
// for (j = 0; j < n; j++)
// {
// printf("wa1[%d] = %e\n", j, wa1[j]);
// printf("wa2[%d] = %e\n", j, wa2[j]);
// printf("wa3[%d] = %e\n", j, wa3[j]);
// }
/* on the first iteration and if mode is 1, scale according
* to the norms of the columns of the initial jacobian.
*/
if (iter == 1)
{
// printf("iter = 1, mode = %d\n", mode);
if (mode != 2)
{
for (j=0; j<n; j++)
{
diag[j] = wa2[j];
if (wa2[j] == zero)
diag[j] = one;
}
}
/* on the first iteration, calculate the norm of the scaled x
* and initialize the step bound delta.
*/
for (j=0; j<n; j++)
wa3[j] = diag[j] * x[j];
xnorm = enorm(n,wa3);
delta = factor*xnorm;
// printf("iter1: xnorm = %e, delta = %e\n", xnorm, delta);
//dkb
if (fabs(delta) <= 1e-4)
// if (delta == zero)
delta = factor;
}
/* form (q transpose)*fvec and store the first n components in qtf. */
for (i=0; i<m; i++)
wa4[i] = fvec[i];
jj = 0;
for (j=0; j<n; j++)
{
temp3 = fjac[jj];
if (temp3 != zero)
{
sum = zero;
ij = jj;
for (i=j; i<m; i++)
{
sum += fjac[ij] * wa4[i];
ij += 1; /* fjac[i+m*j] */
}
temp = -sum / temp3;
ij = jj;
for (i=j; i<m; i++)
{
wa4[i] += fjac[ij] * temp;
ij += 1; /* fjac[i+m*j] */
}
}
fjac[jj] = wa1[j];
jj += m+1; /* fjac[j+m*j] */
qtf[j] = wa4[j];
}
/* compute the norm of the scaled gradient. */
gnorm = zero;
if (fnorm != zero)
{
jj = 0;
for (j=0; j<n; j++)
{
l = ipvt[j];
if (wa2[l] != zero)
{
sum = zero;
ij = jj;
for (i=0; i<=j; i++)
{
sum += fjac[ij]*(qtf[i]/fnorm);
ij += 1; /* fjac[i+m*j] */
}
gnorm = dmax1(gnorm,fabs(sum/wa2[l]));
}
jj += m;
}
}
/* test for convergence of the gradient norm. */
if (gnorm <= gtol)
*info = 4;
if (*info != 0)
goto L300;
//for (j = 0; j < n; j++)
// printf("diag[%d] = %e, wa2[%d] = %e\n", j, diag[j], j, wa2[j]);
/* rescale if necessary. */
if (mode != 2)
{
for (j=0; j<n; j++)
diag[j] = dmax1(diag[j],wa2[j]);
}
/* beginning of the inner loop. */
L200:
/* determine the levenberg-marquardt parameter. */
lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,&par,wa1,wa2,wa3,wa4);
/* store the direction p and x + p. calculate the norm of p. */
for (j=0; j<n; j++)
{
wa1[j] = -wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j]*wa1[j];
//printf("wa2[%d] = %e + %e = %e\n", j, x[j], wa1[j], wa2[j]);
}
pnorm = enorm(n,wa3);
/* on the first iteration, adjust the initial step bound. */
if (iter == 1)
delta = dmin1(delta,pnorm);
/* evaluate the function at x + p and calculate its norm. */
iflag = 1;
//printf("evaluate at:\n");
//for (j=0; j<n; j++)
// printf("wa2[%d] = %e\n", j, wa2[j]);
fcn(m,n,wa2,wa4,&iflag, data);
*nfev += 1;
if (iflag < 0)
goto L300;
fnorm1 = enorm(m,wa4);
#ifdef BUG
printf( "pnorm %.10e fnorm1 %.10e\n", pnorm, fnorm1 );
#endif
/* compute the scaled actual reduction. */
actred = -one;
if ((p1*fnorm1) < fnorm)
{
temp = fnorm1/fnorm;
actred = one - temp * temp;
}
/* compute the scaled predicted reduction and
* the scaled directional derivative.
*/
jj = 0;
for (j=0; j<n; j++)
{
wa3[j] = zero;
l = ipvt[j];
temp = wa1[l];
ij = jj;
for (i=0; i<=j; i++)
{
wa3[i] += fjac[ij]*temp;
ij += 1; /* fjac[i+m*j] */
}
jj += m;
}
temp1 = enorm(n,wa3)/fnorm;
temp2 = (sqrt(par)*pnorm)/fnorm;
prered = temp1*temp1 + (temp2*temp2)/p5;
dirder = -(temp1*temp1 + temp2*temp2);
/* compute the ratio of the actual to the predicted reduction. */
ratio = zero;
if (prered != zero)
ratio = actred/prered;
/* update the step bound. */
if (ratio <= p25)
{
if (actred >= zero)
temp = p5;
else
temp = p5*dirder/(dirder + p5*actred);
if (((p1*fnorm1) >= fnorm) || (temp < p1))
temp = p1;
delta = temp*dmin1(delta,pnorm/p1);
par = par/temp;
}
else
{
if ((par == zero) || (ratio >= p75))
{
delta = pnorm/p5;
par = p5*par;
}
}
/* test for successful iteration. */
if (ratio >= p0001)
{
/* successful iteration. update x, fvec, and their norms. */
for (j=0; j<n; j++)
{
x[j] = wa2[j];
wa2[j] = diag[j]*x[j];
}
for (i=0; i<m; i++)
fvec[i] = wa4[i];
xnorm = enorm(n,wa2);
fnorm = fnorm1;
iter += 1;
}
/* tests for convergence. */
if ((fabs(actred) <= ftol) && (prered <= ftol) && (p5*ratio <= one))
{
*info = 1;
}
if (delta <= xtol*xnorm)
*info = 2;
if ((fabs(actred) <= ftol) && (prered <= ftol)
&& (p5*ratio <= one) && (*info == 2))
{
*info = 3;
}
if (*info != 0)
goto L300;
/* tests for termination and stringent tolerances. */
if (*nfev >= maxfev)
*info = 5;
if ((fabs(actred) <= MACHEP) && (prered <= MACHEP) && (p5*ratio <= one))
{
*info = 6;
}
if (delta <= MACHEP*xnorm)
*info = 7;
if (gnorm <= MACHEP)
*info = 8;
if (*info != 0)
goto L300;
/* end of the inner loop. repeat if iteration unsuccessful. */
if (ratio < p0001)
goto L200;
/* end of the outer loop. */
goto L30;
L300:
/* termination, either normal or user imposed. */
if (iflag < 0)
*info = iflag;
iflag = 0;
if (nprint > 0)
fcn(m,n,x,fvec,&iflag, data);
}
/* Subroutine */ int lmder(minpack_funcder_mn fcn, void *p, int m, int n, double *x,
double *fvec, double *fjac, int ldfjac, double ftol,
double xtol, double gtol, int maxfev, double *
diag, int mode, double factor, int nprint,
int *nfev, int *njev, int *ipvt, double *qtf,
double *wa1, double *wa2, double *wa3, double *wa4)
{
/* Initialized data */
#define p1 .1
#define p5 .5
#define p25 .25
#define p75 .75
#define p0001 1e-4
/* System generated locals */
double d1, d2;
/* Local variables */
int i, j, l;
double par, sum;
int iter;
double temp, temp1, temp2;
int iflag;
double delta = 0.;
double ratio;
double fnorm, gnorm, pnorm, xnorm = 0., fnorm1, actred, dirder,
epsmch, prered;
int info;
/* ********** */
/* subroutine lmder */
/* the purpose of lmder is to minimize the sum of the squares of */
/* m nonlinear functions in n variables by a modification of */
/* the levenberg-marquardt algorithm. the user must provide a */
/* subroutine which calculates the functions and the jacobian. */
/* the subroutine statement is */
/* subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, */
/* maxfev,diag,mode,factor,nprint,info,nfev, */
/* njev,ipvt,qtf,wa1,wa2,wa3,wa4) */
/* where */
/* fcn is the name of the user-supplied subroutine which */
/* calculates the functions and the jacobian. fcn must */
/* be declared in an external statement in the user */
/* calling program, and should be written as follows. */
/* subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) */
/* integer m,n,ldfjac,iflag */
/* double precision x(n),fvec(m),fjac(ldfjac,n) */
/* ---------- */
/* if iflag = 1 calculate the functions at x and */
/* return this vector in fvec. do not alter fjac. */
/* if iflag = 2 calculate the jacobian at x and */
/* return this matrix in fjac. do not alter fvec. */
/* ---------- */
/* return */
/* end */
/* the value of iflag should not be changed by fcn unless */
/* the user wants to terminate execution of lmder. */
/* in this case set iflag to a negative integer. */
/* m is a positive integer input variable set to the number */
/* of functions. */
/* n is a positive integer input variable set to the number */
/* of variables. n must not exceed m. */
/* x is an array of length n. on input x must contain */
/* an initial estimate of the solution vector. on output x */
/* contains the final estimate of the solution vector. */
/* fvec is an output array of length m which contains */
/* the functions evaluated at the output x. */
/* fjac is an output m by n array. the upper n by n submatrix */
/* of fjac contains an upper triangular matrix r with */
/* diagonal elements of nonincreasing magnitude such that */
/* t t t */
/* p *(jac *jac)*p = r *r, */
/* where p is a permutation matrix and jac is the final */
/* calculated jacobian. column j of p is column ipvt(j) */
/* (see below) of the identity matrix. the lower trapezoidal */
/* part of fjac contains information generated during */
/* the computation of r. */
/* ldfjac is a positive integer input variable not less than m */
/* which specifies the leading dimension of the array fjac. */
/* ftol is a nonnegative input variable. termination */
/* occurs when both the actual and predicted relative */
/* reductions in the sum of squares are at most ftol. */
/* therefore, ftol measures the relative error desired */
/* in the sum of squares. */
/* xtol is a nonnegative input variable. termination */
/* occurs when the relative error between two consecutive */
/* iterates is at most xtol. therefore, xtol measures the */
/* relative error desired in the approximate solution. */
/* gtol is a nonnegative input variable. termination */
/* occurs when the cosine of the angle between fvec and */
/* any column of the jacobian is at most gtol in absolute */
/* value. therefore, gtol measures the orthogonality */
/* desired between the function vector and the columns */
/* of the jacobian. */
/* maxfev is a positive integer input variable. termination */
/* occurs when the number of calls to fcn with iflag = 1 */
/* has reached maxfev. */
/* diag is an array of length n. if mode = 1 (see */
/* below), diag is internally set. if mode = 2, diag */
/* must contain positive entries that serve as */
/* multiplicative scale factors for the variables. */
/* mode is an integer input variable. if mode = 1, the */
/* variables will be scaled internally. if mode = 2, */
/* the scaling is specified by the input diag. other */
/* values of mode are equivalent to mode = 1. */
/* factor is a positive input variable used in determining the */
/* initial step bound. this bound is set to the product of */
/* factor and the euclidean norm of diag*x if nonzero, or else */
/* to factor itself. in most cases factor should lie in the */
/* interval (.1,100.).100. is a generally recommended value. */
/* nprint is an integer input variable that enables controlled */
/* printing of iterates if it is positive. in this case, */
/* fcn is called with iflag = 0 at the beginning of the first */
/* iteration and every nprint iterations thereafter and */
/* immediately prior to return, with x, fvec, and fjac */
/* available for printing. fvec and fjac should not be */
/* altered. if nprint is not positive, no special calls */
/* of fcn with iflag = 0 are made. */
/* info is an integer output variable. if the user has */
/* terminated execution, info is set to the (negative) */
/* value of iflag. see description of fcn. otherwise, */
/* info is set as follows. */
/* info = 0 improper input parameters. */
/* info = 1 both actual and predicted relative reductions */
/* in the sum of squares are at most ftol. */
/* info = 2 relative error between two consecutive iterates */
/* is at most xtol. */
/* info = 3 conditions for info = 1 and info = 2 both hold. */
/* info = 4 the cosine of the angle between fvec and any */
/* column of the jacobian is at most gtol in */
/* absolute value. */
/* info = 5 number of calls to fcn with iflag = 1 has */
/* reached maxfev. */
/* info = 6 ftol is too small. no further reduction in */
/* the sum of squares is possible. */
/* info = 7 xtol is too small. no further improvement in */
/* the approximate solution x is possible. */
/* info = 8 gtol is too small. fvec is orthogonal to the */
/* columns of the jacobian to machine precision. */
/* nfev is an integer output variable set to the number of */
/* calls to fcn with iflag = 1. */
/* njev is an integer output variable set to the number of */
/* calls to fcn with iflag = 2. */
/* ipvt is an integer output array of length n. ipvt */
/* defines a permutation matrix p such that jac*p = q*r, */
/* where jac is the final calculated jacobian, q is */
/* orthogonal (not stored), and r is upper triangular */
/* with diagonal elements of nonincreasing magnitude. */
/* column j of p is column ipvt(j) of the identity matrix. */
/* qtf is an output array of length n which contains */
/* the first n elements of the vector (q transpose)*fvec. */
/* wa1, wa2, and wa3 are work arrays of length n. */
/* wa4 is a work array of length m. */
/* subprograms called */
/* user-supplied ...... fcn */
/* minpack-supplied ... dpmpar,enorm,lmpar,qrfac */
/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* epsmch is the machine precision. */
epsmch = dpmpar(1);
info = 0;
iflag = 0;
*nfev = 0;
*njev = 0;
/* check the input parameters for errors. */
if (n <= 0 || m < n || ldfjac < m || ftol < 0. || xtol < 0. ||
gtol < 0. || maxfev <= 0 || factor <= 0.) {
goto TERMINATE;
}
if (mode == 2) {
for (j = 0; j < n; ++j) {
if (diag[j] <= 0.) {
goto TERMINATE;
}
}
}
/* evaluate the function at the starting point */
/* and calculate its norm. */
iflag = (*fcn)(p, m, n, x, fvec, fjac, ldfjac, 1);
*nfev = 1;
if (iflag < 0) {
goto TERMINATE;
}
fnorm = enorm(m, fvec);
/* initialize levenberg-marquardt parameter and iteration counter. */
par = 0.;
iter = 1;
/* beginning of the outer loop. */
for (;;) {
/* calculate the jacobian matrix. */
iflag = (*fcn)(p, m, n, x, fvec, fjac, ldfjac, 2);
++(*njev);
if (iflag < 0) {
goto TERMINATE;
}
/* if requested, call fcn to enable printing of iterates. */
if (nprint > 0) {
iflag = 0;
if ((iter - 1) % nprint == 0) {
iflag = (*fcn)(p, m, n, x, fvec, fjac, ldfjac, 0);
}
if (iflag < 0) {
goto TERMINATE;
}
}
/* compute the qr factorization of the jacobian. */
qrfac(m, n, fjac, ldfjac, TRUE_, ipvt, n,
wa1, wa2, wa3);
/* on the first iteration and if mode is 1, scale according */
/* to the norms of the columns of the initial jacobian. */
if (iter == 1) {
if (mode != 2) {
for (j = 0; j < n; ++j) {
diag[j] = wa2[j];
if (wa2[j] == 0.) {
diag[j] = 1.;
}
}
}
/* on the first iteration, calculate the norm of the scaled x */
/* and initialize the step bound delta. */
for (j = 0; j < n; ++j) {
wa3[j] = diag[j] * x[j];
}
xnorm = enorm(n, wa3);
delta = factor * xnorm;
if (delta == 0.) {
delta = factor;
}
}
/* form (q transpose)*fvec and store the first n components in */
/* qtf. */
for (i = 0; i < m; ++i) {
wa4[i] = fvec[i];
}
for (j = 0; j < n; ++j) {
if (fjac[j + j * ldfjac] != 0.) {
sum = 0.;
for (i = j; i < m; ++i) {
sum += fjac[i + j * ldfjac] * wa4[i];
}
temp = -sum / fjac[j + j * ldfjac];
for (i = j; i < m; ++i) {
wa4[i] += fjac[i + j * ldfjac] * temp;
}
}
fjac[j + j * ldfjac] = wa1[j];
qtf[j] = wa4[j];
}
/* compute the norm of the scaled gradient. */
gnorm = 0.;
if (fnorm != 0.) {
for (j = 0; j < n; ++j) {
l = ipvt[j]-1;
if (wa2[l] != 0.) {
sum = 0.;
for (i = 0; i <= j; ++i) {
sum += fjac[i + j * ldfjac] * (qtf[i] / fnorm);
}
/* Computing MAX */
d1 = fabs(sum / wa2[l]);
gnorm = max(gnorm,d1);
}
}
}
/* test for convergence of the gradient norm. */
if (gnorm <= gtol) {
info = 4;
}
if (info != 0) {
goto TERMINATE;
}
/* rescale if necessary. */
if (mode != 2) {
for (j = 0; j < n; ++j) {
/* Computing MAX */
d1 = diag[j], d2 = wa2[j];
diag[j] = max(d1,d2);
}
}
/* beginning of the inner loop. */
do {
/* determine the levenberg-marquardt parameter. */
lmpar(n, fjac, ldfjac, ipvt, diag, qtf, delta,
&par, wa1, wa2, wa3, wa4);
/* store the direction p and x + p. calculate the norm of p. */
for (j = 0; j < n; ++j) {
wa1[j] = -wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j] * wa1[j];
}
pnorm = enorm(n, wa3);
/* on the first iteration, adjust the initial step bound. */
if (iter == 1) {
delta = min(delta,pnorm);
}
/* evaluate the function at x + p and calculate its norm. */
iflag = (*fcn)(p, m, n, wa2, wa4, fjac, ldfjac, 1);
++(*nfev);
if (iflag < 0) {
goto TERMINATE;
}
fnorm1 = enorm(m, wa4);
/* compute the scaled actual reduction. */
actred = -1.;
if (p1 * fnorm1 < fnorm) {
/* Computing 2nd power */
d1 = fnorm1 / fnorm;
actred = 1. - d1 * d1;
}
/* compute the scaled predicted reduction and */
/* the scaled directional derivative. */
for (j = 0; j < n; ++j) {
wa3[j] = 0.;
l = ipvt[j]-1;
temp = wa1[l];
for (i = 0; i <= j; ++i) {
wa3[i] += fjac[i + j * ldfjac] * temp;
}
}
temp1 = enorm(n, wa3) / fnorm;
temp2 = (sqrt(par) * pnorm) / fnorm;
prered = temp1 * temp1 + temp2 * temp2 / p5;
dirder = -(temp1 * temp1 + temp2 * temp2);
/* compute the ratio of the actual to the predicted */
/* reduction. */
ratio = 0.;
if (prered != 0.) {
ratio = actred / prered;
}
/* update the step bound. */
if (ratio <= p25) {
if (actred >= 0.) {
temp = p5;
} else {
temp = p5 * dirder / (dirder + p5 * actred);
}
if (p1 * fnorm1 >= fnorm || temp < p1) {
temp = p1;
}
/* Computing MIN */
d1 = pnorm / p1;
delta = temp * min(delta,d1);
par /= temp;
} else {
if (par == 0. || ratio >= p75) {
delta = pnorm / p5;
par = p5 * par;
}
}
/* test for successful iteration. */
if (ratio >= p0001) {
/* successful iteration. update x, fvec, and their norms. */
for (j = 0; j < n; ++j) {
x[j] = wa2[j];
wa2[j] = diag[j] * x[j];
}
for (i = 0; i < m; ++i) {
fvec[i] = wa4[i];
}
xnorm = enorm(n, wa2);
fnorm = fnorm1;
++iter;
}
/* tests for convergence. */
if (fabs(actred) <= ftol && prered <= ftol && p5 * ratio <= 1.) {
info = 1;
}
if (delta <= xtol * xnorm) {
info = 2;
}
if (fabs(actred) <= ftol && prered <= ftol && p5 * ratio <= 1. && info == 2) {
info = 3;
}
if (info != 0) {
goto TERMINATE;
}
/* tests for termination and stringent tolerances. */
if (*nfev >= maxfev) {
info = 5;
}
if (fabs(actred) <= epsmch && prered <= epsmch && p5 * ratio <= 1.) {
info = 6;
}
if (delta <= epsmch * xnorm) {
info = 7;
}
if (gnorm <= epsmch) {
info = 8;
}
if (info != 0) {
goto TERMINATE;
}
/* end of the inner loop. repeat if iteration unsuccessful. */
} while (ratio < p0001);
/* end of the outer loop. */
}
TERMINATE:
/* termination, either normal or user imposed. */
if (iflag < 0) {
info = iflag;
}
if (nprint > 0) {
(*fcn)(p, m, n, x, fvec, fjac, ldfjac, 0);
}
return info;
/* last card of subroutine lmder. */
} /* lmder_ */
static int
iterate (void *vstate, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *qtf = state->qtf;
gsl_vector *x_trial = state->x_trial;
gsl_vector *f_trial = state->f_trial;
gsl_vector *rptdx = state->rptdx;
gsl_vector *newton = state->newton;
gsl_vector *gradient = state->gradient;
gsl_vector *sdiag = state->sdiag;
gsl_vector *w = state->w;
gsl_vector *work1 = state->work1;
gsl_permutation *perm = state->perm;
double prered, actred;
double pnorm, fnorm1, fnorm1p, gnorm;
double ratio;
double dirder;
int iter = 0;
double p1 = 0.1, p25 = 0.25, p5 = 0.5, p75 = 0.75, p0001 = 0.0001;
if (state->fnorm == 0.0)
{
return GSL_SUCCESS;
}
/* Compute qtf = Q^T f */
gsl_vector_memcpy (qtf, f);
gsl_linalg_QR_QTvec (r, tau, qtf);
/* Compute norm of scaled gradient */
compute_gradient_direction (r, perm, qtf, diag, gradient);
{
size_t iamax = gsl_blas_idamax (gradient);
gnorm = fabs(gsl_vector_get (gradient, iamax) / state->fnorm);
}
/* Determine the Levenberg-Marquardt parameter */
lm_iteration:
iter++ ;
{
int status = lmpar (r, perm, qtf, diag, state->delta, &(state->par), newton, gradient, sdiag, dx, w);
if (status)
return status;
}
/* Take a trial step */
gsl_vector_scale (dx, -1.0); /* reverse the step to go downhill */
compute_trial_step (x, dx, state->x_trial);
pnorm = scaled_enorm (diag, dx);
if (state->iter == 1)
{
if (pnorm < state->delta)
{
#ifdef DEBUG
printf("set delta = pnorm = %g\n" , pnorm);
#endif
state->delta = pnorm;
}
}
/* Evaluate function at x + p */
/* return immediately if evaluation raised error */
{
int status = GSL_MULTIFIT_FN_EVAL_F (fdf, x_trial, f_trial);
if (status)
return status;
}
fnorm1 = enorm (f_trial);
/* Compute the scaled actual reduction */
actred = compute_actual_reduction (state->fnorm, fnorm1);
#ifdef DEBUG
printf("lmiterate: fnorm = %g fnorm1 = %g actred = %g\n", state->fnorm, fnorm1, actred);
printf("r = "); gsl_matrix_fprintf(stdout, r, "%g");
printf("perm = "); gsl_permutation_fprintf(stdout, perm, "%d");
printf("dx = "); gsl_vector_fprintf(stdout, dx, "%g");
#endif
/* Compute rptdx = R P^T dx, noting that |J dx| = |R P^T dx| */
compute_rptdx (r, perm, dx, rptdx);
#ifdef DEBUG
printf("rptdx = "); gsl_vector_fprintf(stdout, rptdx, "%g");
#endif
fnorm1p = enorm (rptdx);
/* Compute the scaled predicted reduction = |J dx|^2 + 2 par |D dx|^2 */
{
double t1 = fnorm1p / state->fnorm;
double t2 = (sqrt(state->par) * pnorm) / state->fnorm;
prered = t1 * t1 + t2 * t2 / p5;
dirder = -(t1 * t1 + t2 * t2);
}
/* compute the ratio of the actual to predicted reduction */
if (prered > 0)
{
ratio = actred / prered;
}
else
{
ratio = 0;
}
#ifdef DEBUG
printf("lmiterate: prered = %g dirder = %g ratio = %g\n", prered, dirder,ratio);
#endif
/* update the step bound */
if (ratio > p25)
{
#ifdef DEBUG
printf("ratio > p25\n");
#endif
if (state->par == 0 || ratio >= p75)
{
state->delta = pnorm / p5;
state->par *= p5;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
}
else
{
double temp = (actred >= 0) ? p5 : p5*dirder / (dirder + p5 * actred);
#ifdef DEBUG
printf("ratio < p25\n");
#endif
if (p1 * fnorm1 >= state->fnorm || temp < p1 )
{
temp = p1;
}
state->delta = temp * GSL_MIN_DBL (state->delta, pnorm/p1);
state->par /= temp;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
/* test for successful iteration, termination and stringent tolerances */
if (ratio >= p0001)
{
gsl_vector_memcpy (x, x_trial);
gsl_vector_memcpy (f, f_trial);
/* return immediately if evaluation raised error */
{
int status;
if (fdf->df)
status = GSL_MULTIFIT_FN_EVAL_DF (fdf, x_trial, J);
else
status = gsl_multifit_fdfsolver_dif_df(x_trial, fdf, f_trial, J);
if (status)
return status;
}
/* wa2_j = diag_j * x_j */
state->xnorm = scaled_enorm(diag, x);
state->fnorm = fnorm1;
state->iter++;
/* Rescale if necessary */
if (scale)
{
update_diag (J, diag);
}
{
int signum;
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, work1);
}
return GSL_SUCCESS;
}
else if (fabs(actred) <= GSL_DBL_EPSILON && prered <= GSL_DBL_EPSILON
&& p5 * ratio <= 1.0)
{
return GSL_ETOLF ;
}
else if (state->delta <= GSL_DBL_EPSILON * state->xnorm)
{
return GSL_ETOLX;
}
else if (gnorm <= GSL_DBL_EPSILON)
{
return GSL_ETOLG;
}
else if (iter < 10)
{
/* Repeat inner loop if unsuccessful */
goto lm_iteration;
}
return GSL_ENOPROG;
}
/* Subroutine */ int hybrj(minpack_funcder_nn fcn, void *p, int n, double *x, double *
fvec, double *fjac, int ldfjac, double xtol, int
maxfev, double *diag, int mode, double factor, int
nprint, int *nfev, int *njev, double *r,
int lr, double *qtf, double *wa1, double *wa2,
double *wa3, double *wa4)
{
/* Initialized data */
#define p1 .1
#define p5 .5
#define p001 .001
#define p0001 1e-4
/* System generated locals */
int fjac_dim1, fjac_offset;
double d1, d2;
/* Local variables */
int i, j, l, jm1, iwa[1];
double sum;
int sing;
int iter;
double temp;
int iflag;
double delta;
int jeval;
int ncsuc;
double ratio;
double fnorm;
double pnorm, xnorm, fnorm1;
int nslow1, nslow2;
int ncfail;
double actred, epsmch, prered;
int info;
/* ********** */
/* subroutine hybrj */
/* the purpose of hybrj is to find a zero of a system of */
/* n nonlinear functions in n variables by a modification */
/* of the powell hybrid method. the user must provide a */
/* subroutine which calculates the functions and the jacobian. */
/* the subroutine statement is */
/* subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, */
/* mode,factor,nprint,info,nfev,njev,r,lr,qtf, */
/* wa1,wa2,wa3,wa4) */
/* where */
/* fcn is the name of the user-supplied subroutine which */
/* calculates the functions and the jacobian. fcn must */
/* be declared in an external statement in the user */
/* calling program, and should be written as follows. */
/* subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) */
/* integer n,ldfjac,iflag */
/* double precision x(n),fvec(n),fjac(ldfjac,n) */
/* ---------- */
/* if iflag = 1 calculate the functions at x and */
/* return this vector in fvec. do not alter fjac. */
/* if iflag = 2 calculate the jacobian at x and */
/* return this matrix in fjac. do not alter fvec. */
/* --------- */
/* return */
/* end */
/* the value of iflag should not be changed by fcn unless */
/* the user wants to terminate execution of hybrj. */
/* in this case set iflag to a negative integer. */
/* n is a positive integer input variable set to the number */
/* of functions and variables. */
/* x is an array of length n. on input x must contain */
/* an initial estimate of the solution vector. on output x */
/* contains the final estimate of the solution vector. */
/* fvec is an output array of length n which contains */
/* the functions evaluated at the output x. */
/* fjac is an output n by n array which contains the */
/* orthogonal matrix q produced by the qr factorization */
/* of the final approximate jacobian. */
/* ldfjac is a positive integer input variable not less than n */
/* which specifies the leading dimension of the array fjac. */
/* xtol is a nonnegative input variable. termination */
/* occurs when the relative error between two consecutive */
/* iterates is at most xtol. */
/* maxfev is a positive integer input variable. termination */
/* occurs when the number of calls to fcn with iflag = 1 */
/* has reached maxfev. */
/* diag is an array of length n. if mode = 1 (see */
/* below), diag is internally set. if mode = 2, diag */
/* must contain positive entries that serve as */
/* multiplicative scale factors for the variables. */
/* mode is an integer input variable. if mode = 1, the */
/* variables will be scaled internally. if mode = 2, */
/* the scaling is specified by the input diag. other */
/* values of mode are equivalent to mode = 1. */
/* factor is a positive input variable used in determining the */
/* initial step bound. this bound is set to the product of */
/* factor and the euclidean norm of diag*x if nonzero, or else */
/* to factor itself. in most cases factor should lie in the */
/* interval (.1,100.). 100. is a generally recommended value. */
/* nprint is an integer input variable that enables controlled */
/* printing of iterates if it is positive. in this case, */
/* fcn is called with iflag = 0 at the beginning of the first */
/* iteration and every nprint iterations thereafter and */
/* immediately prior to return, with x and fvec available */
/* for printing. fvec and fjac should not be altered. */
/* if nprint is not positive, no special calls of fcn */
/* with iflag = 0 are made. */
/* info is an integer output variable. if the user has */
/* terminated execution, info is set to the (negative) */
/* value of iflag. see description of fcn. otherwise, */
/* info is set as follows. */
/* info = 0 improper input parameters. */
/* info = 1 relative error between two consecutive iterates */
/* is at most xtol. */
/* info = 2 number of calls to fcn with iflag = 1 has */
/* reached maxfev. */
/* info = 3 xtol is too small. no further improvement in */
/* the approximate solution x is possible. */
/* info = 4 iteration is not making good progress, as */
/* measured by the improvement from the last */
/* five jacobian evaluations. */
/* info = 5 iteration is not making good progress, as */
/* measured by the improvement from the last */
/* ten iterations. */
/* nfev is an integer output variable set to the number of */
/* calls to fcn with iflag = 1. */
/* njev is an integer output variable set to the number of */
/* calls to fcn with iflag = 2. */
/* r is an output array of length lr which contains the */
/* upper triangular matrix produced by the qr factorization */
/* of the final approximate jacobian, stored rowwise. */
/* lr is a positive integer input variable not less than */
/* (n*(n+1))/2. */
/* qtf is an output array of length n which contains */
/* the vector (q transpose)*fvec. */
/* wa1, wa2, wa3, and wa4 are work arrays of length n. */
/* subprograms called */
/* user-supplied ...... fcn */
/* minpack-supplied ... dogleg,dpmpar,enorm, */
/* qform,qrfac,r1mpyq,r1updt */
/* fortran-supplied ... dabs,dmax1,dmin1,mod */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* Parameter adjustments */
--wa4;
--wa3;
--wa2;
--wa1;
--qtf;
--diag;
--fvec;
--x;
fjac_dim1 = ldfjac;
fjac_offset = 1 + fjac_dim1 * 1;
fjac -= fjac_offset;
--r;
/* Function Body */
/* epsmch is the machine precision. */
epsmch = dpmpar(1);
info = 0;
iflag = 0;
*nfev = 0;
*njev = 0;
/* check the input parameters for errors. */
if (n <= 0 || ldfjac < n || xtol < 0. || maxfev <= 0 || factor <=
0. || lr < n * (n + 1) / 2) {
goto TERMINATE;
}
if (mode == 2) {
for (j = 1; j <= n; ++j) {
if (diag[j] <= 0.) {
goto TERMINATE;
}
}
}
/* evaluate the function at the starting point */
/* and calculate its norm. */
iflag = (*fcn)(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 1);
*nfev = 1;
if (iflag < 0) {
goto TERMINATE;
}
fnorm = enorm(n, &fvec[1]);
/* initialize iteration counter and monitors. */
iter = 1;
ncsuc = 0;
ncfail = 0;
nslow1 = 0;
nslow2 = 0;
/* beginning of the outer loop. */
for (;;) {
jeval = TRUE_;
/* calculate the jacobian matrix. */
iflag = (*fcn)(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 2);
++(*njev);
if (iflag < 0) {
goto TERMINATE;
}
/* compute the qr factorization of the jacobian. */
qrfac(n, n, &fjac[fjac_offset], ldfjac, FALSE_, iwa, 1,
&wa1[1], &wa2[1], &wa3[1]);
/* on the first iteration and if mode is 1, scale according */
/* to the norms of the columns of the initial jacobian. */
if (iter == 1) {
if (mode != 2) {
for (j = 1; j <= n; ++j) {
diag[j] = wa2[j];
if (wa2[j] == 0.) {
diag[j] = 1.;
}
}
}
/* on the first iteration, calculate the norm of the scaled x */
/* and initialize the step bound delta. */
for (j = 1; j <= n; ++j) {
wa3[j] = diag[j] * x[j];
}
xnorm = enorm(n, &wa3[1]);
delta = factor * xnorm;
if (delta == 0.) {
delta = factor;
}
}
/* form (q transpose)*fvec and store in qtf. */
for (i = 1; i <= n; ++i) {
qtf[i] = fvec[i];
}
for (j = 1; j <= n; ++j) {
if (fjac[j + j * fjac_dim1] != 0.) {
sum = 0.;
for (i = j; i <= n; ++i) {
sum += fjac[i + j * fjac_dim1] * qtf[i];
}
temp = -sum / fjac[j + j * fjac_dim1];
for (i = j; i <= n; ++i) {
qtf[i] += fjac[i + j * fjac_dim1] * temp;
}
}
}
/* copy the triangular factor of the qr factorization into r. */
sing = FALSE_;
for (j = 1; j <= n; ++j) {
l = j;
jm1 = j - 1;
if (jm1 >= 1) {
for (i = 1; i <= jm1; ++i) {
r[l] = fjac[i + j * fjac_dim1];
l = l + n - i;
}
}
r[l] = wa1[j];
if (wa1[j] == 0.) {
sing = TRUE_;
}
}
/* accumulate the orthogonal factor in fjac. */
qform(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]);
/* rescale if necessary. */
if (mode != 2) {
for (j = 1; j <= n; ++j) {
/* Computing MAX */
d1 = diag[j], d2 = wa2[j];
diag[j] = max(d1,d2);
}
}
/* beginning of the inner loop. */
for (;;) {
/* if requested, call fcn to enable printing of iterates. */
if (nprint > 0) {
iflag = 0;
if ((iter - 1) % nprint == 0) {
iflag = (*fcn)(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 0);
}
if (iflag < 0) {
goto TERMINATE;
}
}
/* determine the direction p. */
dogleg(n, &r[1], lr, &diag[1], &qtf[1], delta, &wa1[1], &wa2[1], &wa3[1]);
/* store the direction p and x + p. calculate the norm of p. */
for (j = 1; j <= n; ++j) {
wa1[j] = -wa1[j];
wa2[j] = x[j] + wa1[j];
wa3[j] = diag[j] * wa1[j];
}
pnorm = enorm(n, &wa3[1]);
/* on the first iteration, adjust the initial step bound. */
if (iter == 1) {
delta = min(delta,pnorm);
}
/* evaluate the function at x + p and calculate its norm. */
iflag = (*fcn)(p, n, &wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, 1);
++(*nfev);
if (iflag < 0) {
goto TERMINATE;
}
fnorm1 = enorm(n, &wa4[1]);
/* compute the scaled actual reduction. */
actred = -1.;
if (fnorm1 < fnorm) {
/* Computing 2nd power */
d1 = fnorm1 / fnorm;
actred = 1. - d1 * d1;
}
/* compute the scaled predicted reduction. */
l = 1;
for (i = 1; i <= n; ++i) {
sum = 0.;
for (j = i; j <= n; ++j) {
sum += r[l] * wa1[j];
++l;
}
wa3[i] = qtf[i] + sum;
}
temp = enorm(n, &wa3[1]);
prered = 0.;
if (temp < fnorm) {
/* Computing 2nd power */
d1 = temp / fnorm;
prered = 1. - d1 * d1;
}
/* compute the ratio of the actual to the predicted */
/* reduction. */
ratio = 0.;
if (prered > 0.) {
ratio = actred / prered;
}
/* update the step bound. */
if (ratio < p1) {
ncsuc = 0;
++ncfail;
delta = p5 * delta;
} else {
ncfail = 0;
++ncsuc;
if (ratio >= p5 || ncsuc > 1) {
/* Computing MAX */
d1 = pnorm / p5;
delta = max(delta,d1);
}
if (fabs(ratio - 1.) <= p1) {
delta = pnorm / p5;
}
}
/* test for successful iteration. */
if (ratio >= p0001) {
/* successful iteration. update x, fvec, and their norms. */
for (j = 1; j <= n; ++j) {
x[j] = wa2[j];
wa2[j] = diag[j] * x[j];
fvec[j] = wa4[j];
}
xnorm = enorm(n, &wa2[1]);
fnorm = fnorm1;
++iter;
}
/* determine the progress of the iteration. */
++nslow1;
if (actred >= p001) {
nslow1 = 0;
}
if (jeval) {
++nslow2;
}
if (actred >= p1) {
nslow2 = 0;
}
/* test for convergence. */
if (delta <= xtol * xnorm || fnorm == 0.) {
info = 1;
}
if (info != 0) {
goto TERMINATE;
}
/* tests for termination and stringent tolerances. */
if (*nfev >= maxfev) {
info = 2;
}
/* Computing MAX */
d1 = p1 * delta;
if (p1 * max(d1,pnorm) <= epsmch * xnorm) {
info = 3;
}
if (nslow2 == 5) {
info = 4;
}
if (nslow1 == 10) {
info = 5;
}
if (info != 0) {
goto TERMINATE;
}
/* criterion for recalculating jacobian. */
if (ncfail == 2) {
goto TERMINATE_INNER_LOOP;
}
/* calculate the rank one modification to the jacobian */
/* and update qtf if necessary. */
for (j = 1; j <= n; ++j) {
sum = 0.;
for (i = 1; i <= n; ++i) {
sum += fjac[i + j * fjac_dim1] * wa4[i];
}
wa2[j] = (sum - wa3[j]) / pnorm;
wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm);
if (ratio >= p0001) {
qtf[j] = sum;
}
}
/* compute the qr factorization of the updated jacobian. */
r1updt(n, n, &r[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing);
r1mpyq(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]);
r1mpyq(1, n, &qtf[1], 1, &wa2[1], &wa3[1]);
/* end of the inner loop. */
jeval = FALSE_;
}
TERMINATE_INNER_LOOP:
;
/* end of the outer loop. */
}
TERMINATE:
/* termination, either normal or user imposed. */
if (iflag < 0) {
info = iflag;
}
if (nprint > 0) {
(*fcn)(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 0);
}
return info;
/* last card of subroutine hybrj. */
} /* hybrj_ */
