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;
}
/*
* **********
*
* 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_ */
/*
* 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 ;
}
/* ************************************************************
PROCEDURE mexFunction - Entry for Matlab
[beta,U,d,perm] = qrpfacK(x,K)
************************************************************ */
void mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
mxArray *myplhs[NPAROUT];
coneK cK;
mwIndex i,k,nk,nksqr, sdpdim, qsize;
double *q, *r, *betak;
/* ------------------------------------------------------------
Check for proper number of arguments
------------------------------------------------------------ */
mxAssert(nrhs >= NPARIN, "qrK requires more input arguments");
mxAssert(nlhs <= NPAROUT, "qrK produces less output arguments");
/* ------------------------------------------------------------
Disassemble cone K structure
------------------------------------------------------------ */
conepars(K_IN, &cK);
/* ------------------------------------------------------------
Compute statistics: sdpdim = rdim+hdim, qsize = sdpdim + hLen.
------------------------------------------------------------ */
sdpdim = cK.rDim + cK.hDim;
qsize = sdpdim + cK.hLen;
/* ------------------------------------------------------------
Check input vector x.
------------------------------------------------------------ */
mxAssert(mxGetM(X_IN) * mxGetN(X_IN) == sdpdim, "size mismatch x");
/* ------------------------------------------------------------
Allocate output Q(qsize), R(sdpdim)
and let r = x.
------------------------------------------------------------ */
Q_OUT = mxCreateDoubleMatrix(qsize, (mwSize)1, mxREAL);
q = mxGetPr(Q_OUT);
R_OUT = mxCreateDoubleMatrix(sdpdim, (mwSize)1, mxREAL);
r = mxGetPr(R_OUT);
memcpy(r, mxGetPr(X_IN), sdpdim * sizeof(double));
/* ------------------------------------------------------------
The actual job is done here:
------------------------------------------------------------ */
for(k = 0; k < cK.rsdpN; k++){ /* real symmetric */
nk = (mwIndex) cK.sdpNL[k];
nksqr = SQR(nk);
qrfac(q+nksqr-nk,q,r, nk);
r += nksqr;
q += nksqr;
}
for(; k < cK.sdpN; k++){ /* complex Hermitian */
nk = (mwIndex) cK.sdpNL[k];
nksqr = SQR(nk);
betak = q + 2*nksqr;
prpiqrfac(betak,q,q+nksqr, r,r+nksqr, nk);
nksqr += nksqr;
r += nksqr;
q += nksqr + nk; /* nk for betak */
}
/* ------------------------------------------------------------
Copy requested output parameters (at least 1), release others.
------------------------------------------------------------ */
i = MAX(nlhs, 1);
memcpy(plhs,myplhs, i * sizeof(mxArray *));
for(; i < NPAROUT; i++)
mxDestroyArray(myplhs[i]);
}
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 */ 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_ */
