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 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); }
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 */ 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 ; }
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 */