int main() { int j, n, info, lwa; real tol, fnorm; real x[9], fvec[9], wa[180]; n = 9; /* the following starting values provide a rough solution. */ for (j=1; j<=9; j++) { x[j-1] = -1.; } lwa = 180; /* set tol to the square root of the machine precision. */ /* unless high solutions are required, */ /* this is the recommended setting. */ tol = sqrt(__cminpack_func__(dpmpar)(1)); info = __cminpack_func__(hybrd1)(fcn, 0, n, x, fvec, tol, wa, lwa); fnorm = __cminpack_func__(enorm)(n, fvec); printf(" final L2 norm of the residuals %15.7g\n", (double)fnorm); printf(" exit parameter %10i\n", info); printf(" final approximates solution\n"); for (j=1; j<=n; j++) printf("%s%15.7g",j%3==1?"\n ":"", (double)x[j-1]); printf("\n"); return 0; }
int main() { int i, ldfjac; real x[3], fvec[15], fjac[15*3], xp[3], fvecp[15], err[15]; const int m = 15; const int n = 3; /* auxiliary data (e.g. measurements) */ real y[15] = {1.4e-1, 1.8e-1, 2.2e-1, 2.5e-1, 2.9e-1, 3.2e-1, 3.5e-1, 3.9e-1, 3.7e-1, 5.8e-1, 7.3e-1, 9.6e-1, 1.34, 2.1, 4.39}; #ifdef BOX_CONSTRAINTS real xmin[3] = {0., 0.1, 0.5}; real xmax[3] = {2., 1.5, 2.3}; #endif fcndata_t data; data.m = m; data.y = y; #ifdef BOX_CONSTRAINTS data.xmin = xmin; data.xmax = xmax; #endif /* the following values should be suitable for */ /* checking the jacobian matrix. */ x[0] = 9.2e-1; x[1] = 1.3e-1; x[2] = 5.4e-1; ldfjac = 15; /* compute xp from x */ __cminpack_func__(chkder)(m, n, x, NULL, NULL, ldfjac, xp, NULL, 1, NULL); /* compute fvec at x (all components of fvec should be != 0).*/ fcn(&data, m, n, x, fvec, NULL, ldfjac, 1); /* compute fjac at x */ fcn(&data, m, n, x, NULL, fjac, ldfjac, 2); /* compute fvecp at xp (all components of fvecp should be != 0)*/ fcn(&data, m, n, xp, fvecp, NULL, ldfjac, 1); /* check Jacobian, put the result in err */ __cminpack_func__(chkder)(m, n, x, fvec, fjac, ldfjac, NULL, fvecp, 2, err); /* Output values: err[i] = 1.: i-th gradient is correct err[i] = 0.: i-th gradient is incorrect err[I] > 0.5: i-th gradient is probably correct */ for (i=0; i<m; ++i) { fvecp[i] = fvecp[i] - fvec[i]; } printf("\n fvec\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)fvec[i]); printf("\n fvecp - fvec\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)fvecp[i]); printf("\n err\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)err[i]); printf("\n"); return 0; }
int main() { int j, n, maxfev, ml, mu, mode, nprint, info, nfev, ldfjac, lr; real xtol, epsfcn, factor, fnorm; real x[9], fvec[9], diag[9], fjac[9*9], r[45], qtf[9], wa1[9], wa2[9], wa3[9], wa4[9]; n = 9; /* the following starting values provide a rough solution. */ for (j=1; j<=9; j++) { x[j-1] = -1.; } ldfjac = 9; lr = 45; /* set xtol to the square root of the machine precision. */ /* unless high solutions are required, */ /* this is the recommended setting. */ xtol = sqrt(__cminpack_func__(dpmpar)(1)); maxfev = 2000; ml = 1; mu = 1; epsfcn = 0.; mode = 2; for (j=1; j<=9; j++) { diag[j-1] = 1.; } factor = 1.e2; nprint = 0; info = __cminpack_func__(hybrd)(fcn, 0, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, factor, nprint, &nfev, fjac, ldfjac, r, lr, qtf, wa1, wa2, wa3, wa4); fnorm = __cminpack_func__(enorm)(n, fvec); printf(" final l2 norm of the residuals %15.7g\n\n", (double)fnorm); printf(" number of function evaluations %10i\n\n", nfev); printf(" exit parameter %10i\n\n", info); printf(" final approximate solution\n"); for (j=1; j<=n; j++) { printf("%s%15.7g", j%3==1?"\n ":"", (double)x[j-1]); } printf("\n"); return 0; }
int main() { int j, ldfjac, info, lwa, ipvt[3]; real tol, fnorm; real x[3], fvec[15], fjac[9], wa[30]; const int m = 15; const int n = 3; /* auxiliary data (e.g. measurements) */ real y[15] = {1.4e-1, 1.8e-1, 2.2e-1, 2.5e-1, 2.9e-1, 3.2e-1, 3.5e-1, 3.9e-1, 3.7e-1, 5.8e-1, 7.3e-1, 9.6e-1, 1.34, 2.1, 4.39}; fcndata_t data; data.m = m; data.y = y; /* the following starting values provide a rough fit. */ x[0] = 1.; x[1] = 1.; x[2] = 1.; ldfjac = 3; lwa = 30; /* set tol to the square root of the machine precision. unless high precision solutions are required, this is the recommended setting. */ tol = sqrt(__cminpack_func__(dpmpar)(1)); info = __cminpack_func__(lmstr1)(fcn, &data, m, n, x, fvec, fjac, ldfjac, tol, ipvt, wa, lwa); fnorm = __cminpack_func__(enorm)(m, fvec); printf(" final l2 norm of the residuals%15.7g\n\n", (double)fnorm); printf(" exit parameter %10i\n\n", info); printf(" final approximate solution\n"); for (j=0; j<n; ++j) { printf("%s%15.7g", j%3==0?"\n ":"", (double)x[j]); } printf("\n"); return 0; }
/* Main program */ int main(int argc, char **argv) { int i,ic,k,n,ntries; struct refnum hybrdtest; int info; int na[60]; int nf[60]; int nj[60]; int np[60]; int nx[60]; real factor,fnorm1,fnorm2,tol; real fnm[60]; real fvec[40]; real x[40]; real wa[2660]; const int lwa = 2660; tol = sqrt(__cminpack_func__(dpmpar)(1)); ic = 0; for (;;) { scanf("%5d%5d%5d\n", &hybrdtest.nprob, &n, &ntries); if (hybrdtest.nprob <= 0.) break; factor = 1.; for (k = 0; k < ntries; ++k, ++ic) { hybipt(n,x,hybrdtest.nprob,factor); vecfcn(n,x,fvec,hybrdtest.nprob); fnorm1 = __cminpack_func__(enorm)(n,fvec); printf("\n\n\n\n problem%5d dimension%5d\n\n", hybrdtest.nprob, n); hybrdtest.nfev = 0; hybrdtest.njev = 0; info = __cminpack_func__(hybrd1)(fcn,&hybrdtest,n,x,fvec,tol,wa,lwa); fnorm2 = __cminpack_func__(enorm)(n,fvec); np[ic] = hybrdtest.nprob; na[ic] = n; nf[ic] = hybrdtest.nfev; hybrdtest.njev /= n; nj[ic] = hybrdtest.njev; nx[ic] = info; fnm[ic] = fnorm2; printf("\n initial l2 norm of the residuals%15.7e\n" "\n final l2 norm of the residuals %15.7e\n" "\n number of function evaluations %10d\n" "\n number of Jacobian evaluations %10d\n" "\n exit parameter %10d\n" "\n final approximate solution\n\n", (double)fnorm1, (double)fnorm2, hybrdtest.nfev, hybrdtest.njev, info); printvec(n, x); factor *= 10.; } } printf("\f summary of %d calls to hybrd1\n", ic); printf("\n nprob n nfev njev info final l2 norm\n\n"); for (i = 0; i < ic; ++i) { printf("%4d%6d%7d%7d%6d%16.7e\n", np[i], na[i], nf[i], nj[i], nx[i], (double)fnm[i]); } exit(0); }
__cminpack_attr__ void __cminpack_func__(dogleg)(int n, const real *r, int lr, const real *diag, const real *qtb, real delta, real *x, real *wa1, real *wa2) { /* System generated locals */ real d1, d2, d3, d4; /* Local variables */ int i, j, k, l, jj, jp1; real sum, temp, alpha, bnorm; real gnorm, qnorm, epsmch; real sgnorm; /* ********** */ /* subroutine dogleg */ /* given an m by n matrix a, an n by n nonsingular diagonal */ /* matrix d, an m-vector b, and a positive number delta, the */ /* problem is to determine the convex combination x of the */ /* gauss-newton and scaled gradient directions that minimizes */ /* (a*x - b) in the least squares sense, subject to the */ /* restriction that the euclidean norm of d*x be at most delta. */ /* this subroutine completes the solution of the problem */ /* if it is provided with the necessary information from the */ /* qr factorization of a. that is, if a = q*r, where q has */ /* orthogonal columns and r is an upper triangular matrix, */ /* then dogleg expects the full upper triangle of r and */ /* the first n components of (q transpose)*b. */ /* the subroutine statement is */ /* subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) */ /* where */ /* n is a positive integer input variable set to the order of r. */ /* r is an input array of length lr which must contain the upper */ /* triangular matrix r stored by rows. */ /* lr is a positive integer input variable not less than */ /* (n*(n+1))/2. */ /* diag is an input array of length n which must contain the */ /* diagonal elements of the matrix d. */ /* qtb is an input array of length n which must contain the first */ /* n elements of the vector (q transpose)*b. */ /* delta is a positive input variable which specifies an upper */ /* bound on the euclidean norm of d*x. */ /* x is an output array of length n which contains the desired */ /* convex combination of the gauss-newton direction and the */ /* scaled gradient direction. */ /* wa1 and wa2 are work arrays of length n. */ /* subprograms called */ /* minpack-supplied ... dpmpar,enorm */ /* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ /* Parameter adjustments */ --wa2; --wa1; --x; --qtb; --diag; --r; (void)lr; /* Function Body */ /* epsmch is the machine precision. */ epsmch = __cminpack_func__(dpmpar)(1); /* first, calculate the gauss-newton direction. */ jj = n * (n + 1) / 2 + 1; for (k = 1; k <= n; ++k) { j = n - k + 1; jp1 = j + 1; jj -= k; l = jj + 1; sum = 0.; if (n >= jp1) { for (i = jp1; i <= n; ++i) { sum += r[l] * x[i]; ++l; } } temp = r[jj]; if (temp == 0.) { l = j; for (i = 1; i <= j; ++i) { /* Computing MAX */ d2 = fabs(r[l]); temp = max(temp,d2); l = l + n - i; } temp = epsmch * temp; if (temp == 0.) { temp = epsmch; } } x[j] = (qtb[j] - sum) / temp; } /* test whether the gauss-newton direction is acceptable. */ for (j = 1; j <= n; ++j) { wa1[j] = 0.; wa2[j] = diag[j] * x[j]; } qnorm = __cminpack_enorm__(n, &wa2[1]); if (qnorm <= delta) { return; } /* the gauss-newton direction is not acceptable. */ /* next, calculate the scaled gradient direction. */ l = 1; for (j = 1; j <= n; ++j) { temp = qtb[j]; for (i = j; i <= n; ++i) { wa1[i] += r[l] * temp; ++l; } wa1[j] /= diag[j]; } /* calculate the norm of the scaled gradient and test for */ /* the special case in which the scaled gradient is zero. */ gnorm = __cminpack_enorm__(n, &wa1[1]); sgnorm = 0.; alpha = delta / qnorm; if (gnorm != 0.) { /* calculate the point along the scaled gradient */ /* at which the quadratic is minimized. */ for (j = 1; j <= n; ++j) { wa1[j] = wa1[j] / gnorm / diag[j]; } l = 1; for (j = 1; j <= n; ++j) { sum = 0.; for (i = j; i <= n; ++i) { sum += r[l] * wa1[i]; ++l; } wa2[j] = sum; } temp = __cminpack_enorm__(n, &wa2[1]); sgnorm = gnorm / temp / temp; /* test whether the scaled gradient direction is acceptable. */ alpha = 0.; if (sgnorm < delta) { /* the scaled gradient direction is not acceptable. */ /* finally, calculate the point along the dogleg */ /* at which the quadratic is minimized. */ bnorm = __cminpack_enorm__(n, &qtb[1]); temp = bnorm / gnorm * (bnorm / qnorm) * (sgnorm / delta); /* Computing 2nd power */ d1 = sgnorm / delta; /* Computing 2nd power */ d2 = temp - delta / qnorm; /* Computing 2nd power */ d3 = delta / qnorm; /* Computing 2nd power */ d4 = sgnorm / delta; temp = temp - delta / qnorm * (d1 * d1) + sqrt(d2 * d2 + (1. - d3 * d3) * (1. - d4 * d4)); /* Computing 2nd power */ d1 = sgnorm / delta; alpha = delta / qnorm * (1. - d1 * d1) / temp; } } /* form appropriate convex combination of the gauss-newton */ /* direction and the scaled gradient direction. */ temp = (1. - alpha) * min(sgnorm,delta); for (j = 1; j <= n; ++j) { x[j] = temp * wa1[j] + alpha * x[j]; } /* last card of subroutine dogleg. */ } /* dogleg_ */
int main() { int i, ldfjac; real epsfcn; real x[3], fvec[15], fjac[15*3], fdjac[15*3], xp[3], fvecp[15], err[15], errd[15], wa[15]; const int m = 15; const int n = 3; /* auxiliary data (e.g. measurements) */ real y[15] = {1.4e-1, 1.8e-1, 2.2e-1, 2.5e-1, 2.9e-1, 3.2e-1, 3.5e-1, 3.9e-1, 3.7e-1, 5.8e-1, 7.3e-1, 9.6e-1, 1.34, 2.1, 4.39}; fcndata_t data; data.m = m; data.y = y; /* the following values should be suitable for */ /* checking the jacobian matrix. */ x[1-1] = 9.2e-1; x[2-1] = 1.3e-1; x[3-1] = 5.4e-1; ldfjac = 15; epsfcn = 0.; /* compute xp from x */ __cminpack_func__(chkder)(m, n, x, NULL, NULL, ldfjac, xp, NULL, 1, NULL); /* compute fvec at x (all components of fvec should be != 0).*/ fcn(&data, m, n, x, fvec, 1); /* compute fdjac (Jacobian using finite differences) at x */ __cminpack_func__(fdjac2)(fcn, &data, m, n, x, fvec, fdjac, ldfjac, epsfcn, wa); /* compute fjac (real Jacobian) at x */ fcnjac(m, n, x, fjac, ldfjac); /* compute fvecp at xp (all components of fvecp should be != 0)*/ fcn(&data, m, n, xp, fvecp, 1); /* check Jacobian fdjac, put the result in errd */ __cminpack_func__(chkder)(m, n, x, fvec, fdjac, ldfjac, NULL, fvecp, 2, errd); /* check Jacobian fjac, put the result in err */ __cminpack_func__(chkder)(m, n, x, fvec, fjac, ldfjac, NULL, fvecp, 2, err); /* Output values: err[i] = 1.: i-th gradient is correct err[i] = 0.: i-th gradient is incorrect err[I] > 0.5: i-th gradient is probably correct */ for (i=0; i<m; ++i) { fvecp[i] = fvecp[i] - fvec[i]; } printf("\n fvec\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)fvec[i]); printf("\n fvecp - fvec\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)fvecp[i]); printf("\n errd\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)errd[i]); printf("\n err\n"); for (i=0; i<m; ++i) printf("%s%15.7g",i%3==0?"\n ":"", (double)err[i]); printf("\n"); return 0; }
/* Main program */ int main(int argc, char **argv) { int i,ic,k,m,n,ntries; struct refnum lmdiftest; int info; int ma[60]; int na[60]; int nf[60]; int nj[60]; int np[60]; int nx[60]; real factor,fnorm1,fnorm2,tol; real fnm[60]; real fvec[65]; real x[40]; int iwa[40]; real wa[65*40+5*40+65]; const int lwa = 65*40+5*40+65; tol = sqrt(__cminpack_func__(dpmpar)(1)); ic = 0; for (;;) { scanf("%5d%5d%5d%5d\n", &lmdiftest.nprob, &n, &m, &ntries); /* read (nread,50) nprob,n,m,ntries 50 format (4i5) */ if (lmdiftest.nprob <= 0.) break; factor = 1.; for (k = 0; k < ntries; ++k, ++ic) { lmdipt(n,x,lmdiftest.nprob,factor); ssqfcn(m,n,x,fvec,lmdiftest.nprob); fnorm1 = __cminpack_func__(enorm)(m,fvec); printf("\n\n\n\n problem%5d dimensions%5d%5d\n\n", lmdiftest.nprob, n, m); /* write (nwrite,60) nprob,n,m 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // * ) */ lmdiftest.nfev = 0; lmdiftest.njev = 0; info = __cminpack_func__(lmdif1)(fcn,&lmdiftest,m,n,x,fvec,tol,iwa,wa,lwa); ssqfcn(m,n,x,fvec,lmdiftest.nprob); fnorm2 = __cminpack_func__(enorm)(m,fvec); np[ic] = lmdiftest.nprob; na[ic] = n; ma[ic] = m; nf[ic] = lmdiftest.nfev; lmdiftest.njev /= n; nj[ic] = lmdiftest.njev; nx[ic] = info; fnm[ic] = fnorm2; printf("\n initial l2 norm of the residuals%15.7e\n" "\n final l2 norm of the residuals %15.7e\n" "\n number of function evaluations %10d\n" "\n number of Jacobian evaluations %10d\n" "\n exit parameter %10d\n" "\n final approximate solution\n\n", (double)fnorm1, (double)fnorm2, lmdiftest.nfev, lmdiftest.njev, info); printvec(n, x); /* write (nwrite,70) * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, * 33h final l2 norm of the residuals , d15.7 // 5x, * 33h number of function evaluations , i10 // 5x, * 33h number of jacobian evaluations , i10 // 5x, * 15h exit parameter, 18x, i10 // 5x, * 27h final approximate solution // (5x, 5d15.7)) */ factor *= 10.; } } printf("\f summary of %d calls to lmdif1: \n\n", ic); /* write (nwrite,80) ic 80 format (12h1summary of , i3, 16h calls to lmdif1 /) */ printf("\n\n nprob n m nfev njev info final L2 norm \n\n"); /* write (nwrite,90) 90 format (49h nprob n m nfev njev info final l2 norm /) */ for (i = 0; i < ic; ++i) { printf("%5d%5d%5d%6d%6d%6d%16.7e\n", np[i], na[i], ma[i], nf[i], nj[i], nx[i], (double)fnm[i]); /* write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) 100 format (3i5, 3i6, 1x, d15.7) */ } exit(0); }
/* Main program */ int main(int argc, char **argv) { /* Initialized data */ const int a[14] = { 0,0,0,1,0,0,0,1,0,0,0,0,1,0 }; real cp = .123; /* Local variables */ int i, n; real x1[10], x2[10]; int na[14], np[14]; real err[10]; int lnp; real fjac[10*10]; const int ldfjac = 10; real diff[10]; real fvec1[10], fvec2[10]; int nprob; real errmin[14], errmax[14]; for (;;) { scanf("%5d%5d\n", &nprob, &n); if (nprob <= 0) { break; } hybipt(n,x1,nprob,1.); for(i=0; i<n; ++i) { x1[i] += cp; cp = -cp; } printf("\n\n\n problem%5d with dimension%5d is %c\n\n", nprob, n, a[nprob-1]?'T':'F'); __cminpack_func__(chkder)(n,n,x1,NULL,NULL,ldfjac,x2,NULL,1,NULL); vecfcn(n,x1,fvec1,nprob); errjac(n,x1,fjac,ldfjac,nprob); vecfcn(n,x2,fvec2,nprob); __cminpack_func__(chkder)(n,n,x1,fvec1,fjac,ldfjac,NULL,fvec2,2,err); errmin[nprob-1] = err[0]; errmax[nprob-1] = err[0]; for(i=0; i<n; ++i) { diff[i] = fvec2[i] - fvec1[i]; if (errmin[nprob-1] > err[i]) errmin[nprob-1] = err[i]; if (errmax[nprob-1] < err[i]) errmax[nprob-1] = err[i]; } np[nprob-1] = nprob; lnp = nprob; na[nprob-1] = n; printf("\n first function vector \n\n"); printvec(n, fvec1); printf("\n\n function difference vector\n\n"); printvec(n, diff); printf("\n\n error vector\n\n"); printvec(n, err); } printf("\f summary of %3d tests of chkder\n", lnp); printf("\n nprob n status errmin errmax\n\n"); for (i = 0; i < lnp; ++i) { printf("%4d%6d %c %15.7e%15.7e\n", np[i], na[i], a[i]?'T':'F', (double)errmin[i], (double)errmax[i]); } exit(0); }
__cminpack_attr__ int __cminpack_func__(lmstr)(__cminpack_decl_fcnderstr_mn__ void *p, int m, int n, real *x, real *fvec, real *fjac, int ldfjac, real ftol, real xtol, real gtol, int maxfev, real * diag, int mode, real factor, int nprint, int *nfev, int *njev, int *ipvt, real *qtf, real *wa1, real *wa2, real *wa3, real *wa4) { /* Initialized data */ #define p1 .1 #define p5 .5 #define p25 .25 #define p75 .75 #define p0001 1e-4 /* System generated locals */ real d1, d2; /* Local variables */ int i, j, l; real par, sum; int sing; int iter; real temp, temp1, temp2; int iflag; real delta = 0.; real ratio; real fnorm, gnorm, pnorm, xnorm = 0., fnorm1, actred, dirder, epsmch, prered; int info; /* ********** */ /* subroutine lmstr */ /* the purpose of lmstr is to minimize the sum of the squares of */ /* m nonlinear functions in n variables by a modification of */ /* the levenberg-marquardt algorithm which uses minimal storage. */ /* the user must provide a subroutine which calculates the */ /* functions and the rows of the jacobian. */ /* the subroutine statement is */ /* subroutine lmstr(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 rows of 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,fjrow,iflag) */ /* integer m,n,iflag */ /* double precision x(n),fvec(m),fjrow(n) */ /* ---------- */ /* if iflag = 1 calculate the functions at x and */ /* return this vector in fvec. */ /* if iflag = i calculate the (i-1)-st row of the */ /* jacobian at x and return this vector in fjrow. */ /* ---------- */ /* return */ /* end */ /* the value of iflag should not be changed by fcn unless */ /* the user wants to terminate execution of lmstr. */ /* 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 n by n array. the upper triangle of fjac */ /* contains an upper triangular matrix r 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 triangular */ /* part of fjac contains information generated during */ /* the computation of r. */ /* ldfjac is a positive integer input variable not less than n */ /* 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 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 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. */ /* 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,rwupdt */ /* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, */ /* jorge j. more */ /* ********** */ /* epsmch is the machine precision. */ epsmch = __cminpack_func__(dpmpar)(1); info = 0; iflag = 0; *nfev = 0; *njev = 0; /* check the input parameters for errors. */ if (n <= 0 || m < n || ldfjac < n || 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 = fcnderstr_mn(p, m, n, x, fvec, wa3, 1); *nfev = 1; if (iflag < 0) { goto TERMINATE; } fnorm = __cminpack_enorm__(m, fvec); /* initialize levenberg-marquardt parameter and iteration counter. */ par = 0.; iter = 1; /* beginning of the outer loop. */ for (;;) { /* if requested, call fcn to enable printing of iterates. */ if (nprint > 0) { iflag = 0; if ((iter - 1) % nprint == 0) { iflag = fcnderstr_mn(p, m, n, x, fvec, wa3, 0); } if (iflag < 0) { goto TERMINATE; } } /* compute the qr factorization of the jacobian matrix */ /* calculated one row at a time, while simultaneously */ /* forming (q transpose)*fvec and storing the first */ /* n components in qtf. */ for (j = 0; j < n; ++j) { qtf[j] = 0.; for (i = 0; i < n; ++i) { fjac[i + j * ldfjac] = 0.; } } iflag = 2; for (i = 0; i < m; ++i) { if (fcnderstr_mn(p, m, n, x, fvec, wa3, iflag) < 0) { goto TERMINATE; } temp = fvec[i]; __cminpack_func__(rwupdt)(n, fjac, ldfjac, wa3, qtf, &temp, wa1, wa2); ++iflag; } ++(*njev); /* if the jacobian is rank deficient, call qrfac to */ /* reorder its columns and update the components of qtf. */ sing = FALSE_; for (j = 0; j < n; ++j) { if (fjac[j + j * ldfjac] == 0.) { sing = TRUE_; } ipvt[j] = j+1; wa2[j] = __cminpack_enorm__(j+1, &fjac[j * ldfjac + 0]); } if (sing) { __cminpack_func__(qrfac)(n, n, fjac, ldfjac, TRUE_, ipvt, n, wa1, wa2, wa3); for (j = 0; j < n; ++j) { if (fjac[j + j * ldfjac] != 0.) { sum = 0.; for (i = j; i < n; ++i) { sum += fjac[i + j * ldfjac] * qtf[i]; } temp = -sum / fjac[j + j * ldfjac]; for (i = j; i < n; ++i) { qtf[i] += fjac[i + j * ldfjac] * temp; } } fjac[j + j * ldfjac] = wa1[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) { 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 = __cminpack_enorm__(n, wa3); delta = factor * xnorm; if (delta == 0.) { delta = factor; } } /* 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. */ __cminpack_func__(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 = __cminpack_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 = fcnderstr_mn(p, m, n, wa2, wa4, wa3, 1); ++(*nfev); if (iflag < 0) { goto TERMINATE; } fnorm1 = __cminpack_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 = __cminpack_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 = __cminpack_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) { fcnderstr_mn(p, m, n, x, fvec, wa3, 0); } return info; /* last card of subroutine lmstr. */ } /* lmstr_ */
__cminpack_attr__ void __cminpack_func__(lmpar)(int n, real *r, int ldr, const int *ipvt, const real *diag, const real *qtb, real delta, real *par, real *x, real *sdiag, real *wa1, real *wa2) { /* Initialized data */ #define p1 .1 #define p001 .001 /* System generated locals */ real d1, d2; /* Local variables */ int j, l; real fp; real parc, parl; int iter; real temp, paru, dwarf; int nsing; real gnorm; real dxnorm; /* ********** */ /* subroutine lmpar */ /* given an m by n matrix a, an n by n nonsingular diagonal */ /* matrix d, an m-vector b, and a positive number delta, */ /* the problem is to determine a value for the parameter */ /* par such that if x solves the system */ /* a*x = b , sqrt(par)*d*x = 0 , */ /* in the least squares sense, and dxnorm is the euclidean */ /* norm of d*x, then either par is zero and */ /* (dxnorm-delta) .le. 0.1*delta , */ /* or par is positive and */ /* abs(dxnorm-delta) .le. 0.1*delta . */ /* this subroutine completes the solution of the problem */ /* if it is provided with the necessary information from the */ /* qr factorization, with column pivoting, of a. that is, if */ /* a*p = q*r, where p is a permutation matrix, q has orthogonal */ /* columns, and r is an upper triangular matrix with diagonal */ /* elements of nonincreasing magnitude, then lmpar expects */ /* the full upper triangle of r, the permutation matrix p, */ /* and the first n components of (q transpose)*b. on output */ /* lmpar also provides an upper triangular matrix s such that */ /* t t t */ /* p *(a *a + par*d*d)*p = s *s . */ /* s is employed within lmpar and may be of separate interest. */ /* only a few iterations are generally needed for convergence */ /* of the algorithm. if, however, the limit of 10 iterations */ /* is reached, then the output par will contain the best */ /* value obtained so far. */ /* the subroutine statement is */ /* subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, */ /* wa1,wa2) */ /* where */ /* n is a positive integer input variable set to the order of r. */ /* r is an n by n array. on input the full upper triangle */ /* must contain the full upper triangle of the matrix r. */ /* on output the full upper triangle is unaltered, and the */ /* strict lower triangle contains the strict upper triangle */ /* (transposed) of the upper triangular matrix s. */ /* ldr is a positive integer input variable not less than n */ /* which specifies the leading dimension of the array r. */ /* ipvt is an integer input array of length n which defines the */ /* permutation matrix p such that a*p = q*r. column j of p */ /* is column ipvt(j) of the identity matrix. */ /* diag is an input array of length n which must contain the */ /* diagonal elements of the matrix d. */ /* qtb is an input array of length n which must contain the first */ /* n elements of the vector (q transpose)*b. */ /* delta is a positive input variable which specifies an upper */ /* bound on the euclidean norm of d*x. */ /* par is a nonnegative variable. on input par contains an */ /* initial estimate of the levenberg-marquardt parameter. */ /* on output par contains the final estimate. */ /* x is an output array of length n which contains the least */ /* squares solution of the system a*x = b, sqrt(par)*d*x = 0, */ /* for the output par. */ /* sdiag is an output array of length n which contains the */ /* diagonal elements of the upper triangular matrix s. */ /* wa1 and wa2 are work arrays of length n. */ /* subprograms called */ /* minpack-supplied ... dpmpar,enorm,qrsolv */ /* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ /* dwarf is the smallest positive magnitude. */ dwarf = __cminpack_func__(dpmpar)(2); /* compute and store in x the gauss-newton direction. if the */ /* jacobian is rank-deficient, obtain a least squares solution. */ nsing = n; for (j = 0; j < n; ++j) { wa1[j] = qtb[j]; if (r[j + j * ldr] == 0. && nsing == n) { nsing = j; } if (nsing < n) { wa1[j] = 0.; } } # ifdef USE_CBLAS cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, nsing, r, ldr, wa1, 1); # else if (nsing >= 1) { int k; for (k = 1; k <= nsing; ++k) { j = nsing - k; wa1[j] /= r[j + j * ldr]; temp = wa1[j]; if (j >= 1) { int i; for (i = 0; i < j; ++i) { wa1[i] -= r[i + j * ldr] * temp; } } } } # endif for (j = 0; j < n; ++j) { l = ipvt[j]-1; x[l] = wa1[j]; } /* initialize the iteration counter. */ /* evaluate the function at the origin, and test */ /* for acceptance of the gauss-newton direction. */ iter = 0; for (j = 0; j < n; ++j) { wa2[j] = diag[j] * x[j]; } dxnorm = __cminpack_enorm__(n, wa2); fp = dxnorm - delta; if (fp <= p1 * delta) { goto TERMINATE; } /* if the jacobian is not rank deficient, the newton */ /* step provides a lower bound, parl, for the zero of */ /* the function. otherwise set this bound to zero. */ parl = 0.; if (nsing >= n) { for (j = 0; j < n; ++j) { l = ipvt[j]-1; wa1[j] = diag[l] * (wa2[l] / dxnorm); } # ifdef USE_CBLAS cblas_dtrsv(CblasColMajor, CblasUpper, CblasTrans, CblasNonUnit, n, r, ldr, wa1, 1); # else for (j = 0; j < n; ++j) { real sum = 0.; if (j >= 1) { int i; for (i = 0; i < j; ++i) { sum += r[i + j * ldr] * wa1[i]; } } wa1[j] = (wa1[j] - sum) / r[j + j * ldr]; } # endif temp = __cminpack_enorm__(n, wa1); parl = fp / delta / temp / temp; } /* calculate an upper bound, paru, for the zero of the function. */ for (j = 0; j < n; ++j) { real sum; # ifdef USE_CBLAS sum = cblas_ddot(j+1, &r[j*ldr], 1, qtb, 1); # else sum = 0.; int i; for (i = 0; i <= j; ++i) { sum += r[i + j * ldr] * qtb[i]; } # endif l = ipvt[j]-1; wa1[j] = sum / diag[l]; } gnorm = __cminpack_enorm__(n, wa1); paru = gnorm / delta; if (paru == 0.) { paru = dwarf / min(delta,(real)p1) /* / p001 ??? */; } /* if the input par lies outside of the interval (parl,paru), */ /* set par to the closer endpoint. */ *par = max(*par,parl); *par = min(*par,paru); if (*par == 0.) { *par = gnorm / dxnorm; } /* beginning of an iteration. */ for (;;) { ++iter; /* evaluate the function at the current value of par. */ if (*par == 0.) { /* Computing MAX */ d1 = dwarf, d2 = p001 * paru; *par = max(d1,d2); } temp = sqrt(*par); for (j = 0; j < n; ++j) { wa1[j] = temp * diag[j]; } __cminpack_func__(qrsolv)(n, r, ldr, ipvt, wa1, qtb, x, sdiag, wa2); for (j = 0; j < n; ++j) { wa2[j] = diag[j] * x[j]; } dxnorm = __cminpack_enorm__(n, wa2); temp = fp; fp = dxnorm - delta; /* if the function is small enough, accept the current value */ /* of par. also test for the exceptional cases where parl */ /* is zero or the number of iterations has reached 10. */ if (fabs(fp) <= p1 * delta || (parl == 0. && fp <= temp && temp < 0.) || iter == 10) { goto TERMINATE; } /* compute the newton correction. */ # ifdef USE_CBLAS for (j = 0; j < nsing; ++j) { l = ipvt[j]-1; wa1[j] = diag[l] * (wa2[l] / dxnorm); } for (j = nsing; j < n; ++j) { wa1[j] = 0.; } /* exchange the diagonal of r with sdiag */ cblas_dswap(n, r, ldr+1, sdiag, 1); /* solve lower(r).x = wa1, result id put in wa1 */ cblas_dtrsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, nsing, r, ldr, wa1, 1); /* exchange the diagonal of r with sdiag */ cblas_dswap( n, r, ldr+1, sdiag, 1); # else /* !USE_CBLAS */ for (j = 0; j < n; ++j) { l = ipvt[j]-1; wa1[j] = diag[l] * (wa2[l] / dxnorm); } for (j = 0; j < n; ++j) { wa1[j] /= sdiag[j]; temp = wa1[j]; if (n > j+1) { int i; for (i = j+1; i < n; ++i) { wa1[i] -= r[i + j * ldr] * temp; } } } # endif /* !USE_CBLAS */ temp = __cminpack_enorm__(n, wa1); parc = fp / delta / temp / temp; /* depending on the sign of the function, update parl or paru. */ if (fp > 0.) { parl = max(parl,*par); } if (fp < 0.) { paru = min(paru,*par); } /* compute an improved estimate for par. */ /* Computing MAX */ d1 = parl, d2 = *par + parc; *par = max(d1,d2); /* end of an iteration. */ } TERMINATE: /* termination. */ if (iter == 0) { *par = 0.; } /* last card of subroutine lmpar. */ } /* lmpar_ */
int main() { int i, j, ldfjac, maxfev, mode, nprint, info, nfev, njev; int ipvt[3]; real ftol, xtol, gtol, factor, fnorm; real x[3], fvec[15], fjac[15*3], diag[3], qtf[3], wa1[3], wa2[3], wa3[3], wa4[15]; int k; const int m = 15; const int n = 3; /* auxiliary data (e.g. measurements) */ real y[15] = {1.4e-1, 1.8e-1, 2.2e-1, 2.5e-1, 2.9e-1, 3.2e-1, 3.5e-1, 3.9e-1, 3.7e-1, 5.8e-1, 7.3e-1, 9.6e-1, 1.34, 2.1, 4.39}; #ifdef TEST_COVAR real covfac; real fjac1[15*3]; #endif #ifdef BOX_CONSTRAINTS /* the minimum and maximum bounds for each variable. */ real xmin[3] = {0., 0.1, 0.5}; real xmax[3] = {2., 1.5, 2.3}; /* the Jacobian factor for each line, used to compute the covariance matrix. */ real jacfac[3]; #endif fcndata_t data; data.m = m; data.y = y; #ifdef BOX_CONSTRAINTS data.xmin = xmin; data.xmax = xmax; #endif /* the following starting values provide a rough fit. */ x[0] = 1.; x[1] = 1.; x[2] = 1.; ldfjac = 15; /* set ftol and xtol to the square root of the machine */ /* and gtol to zero. unless high solutions are */ /* required, these are the recommended settings. */ ftol = sqrt(__cminpack_func__(dpmpar)(1)); xtol = sqrt(__cminpack_func__(dpmpar)(1)); gtol = 0.; maxfev = 400; mode = 1; factor = 1.e2; nprint = 0; info = __cminpack_func__(lmder)(fcn, &data, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, diag, mode, factor, nprint, &nfev, &njev, ipvt, qtf, wa1, wa2, wa3, wa4); #ifdef BOX_CONSTRAINTS /* compute the real x, using the same change of variable as in fcn */ for (j = 0; j < 3; ++j) { real xmiddle = (xmin[j]+xmax[j])/2.; real xwidth = (xmax[j]-xmin[j])/2.; real th = tanh((x[j]-xmiddle)/xwidth); x[j] = xmiddle + th * xwidth; jacfac[j] = 1. - th * th; } #endif fnorm = __cminpack_func__(enorm)(m, fvec); printf(" final l2 norm of the residuals%15.7g\n\n", (double)fnorm); printf(" number of function evaluations%10i\n\n", nfev); printf(" number of Jacobian evaluations%10i\n\n", njev); printf(" exit parameter %10i\n\n", info); printf(" final approximate solution\n"); for (j=0; j<n; ++j) printf("%s%15.7g", j%3==0?"\n ":"", (double)x[j]); printf("\n"); ftol = __cminpack_func__(dpmpar)(1); #ifdef TEST_COVAR /* test the original covar from MINPACK */ covfac = fnorm*fnorm/(m-n); memcpy(fjac1, fjac, sizeof(fjac)); __cminpack_func__(covar)(n, fjac1, ldfjac, ipvt, ftol, wa1); /* printf(" covariance (using covar)\n"); */ for (i=0; i<n; ++i) { for (j=0; j<n; ++j) { # ifdef BOX_CONSTRAINTS fjac1[i*ldfjac+j] *= jacfac[i] * jacfac[j]; # endif /* printf("%s%15.7g", j%3==0?"\n ":"", (double)fjac1[i*ldfjac+j]*covfac); */ } } /* printf("\n"); */ #endif /* test covar1, which also estimates the rank of the Jacobian */ k = __cminpack_func__(covar1)(m, n, fnorm*fnorm, fjac, ldfjac, ipvt, ftol, wa1); printf(" covariance\n"); for (i=0; i<n; ++i) { for (j=0; j<n; ++j) { # ifdef BOX_CONSTRAINTS fjac[i*ldfjac+j] *= jacfac[i] * jacfac[j]; # endif printf("%s%15.7g", j%3==0?"\n ":"", (double)fjac[i*ldfjac+j]); } } printf("\n"); (void)k; #ifdef TEST_COVAR if (k == n) { /* comparison only works if covariance matrix has full rank */ for (i=0; i<n; ++i) { for (j=0; j<n; ++j) { if (fjac[i*ldfjac+j] != fjac1[i*ldfjac+j]*covfac) { printf("component (%d,%d) of covar and covar1 differ: %g != %g\n", i, j, (double)fjac[i*ldfjac+j], (double)fjac1[i*ldfjac+j]*covfac); } } } } #endif /* printf(" rank(J) = %d\n", k != 0 ? k : n); */ return 0; }
__cminpack_attr__ int __cminpack_func__(fdjac2)(__cminpack_decl_fcn_mn__ void *p, int m, int n, real *x, const real *fvec, real *fjac, int ldfjac, real epsfcn, real *wa) { /* Local variables */ real h; int i, j; real eps, temp, epsmch; int iflag; /* ********** */ /* subroutine fdjac2 */ /* this subroutine computes a forward-difference approximation */ /* to the m by n jacobian matrix associated with a specified */ /* problem of m functions in n variables. */ /* the subroutine statement is */ /* subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) */ /* 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 fdjac2. */ /* 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 input array of length n. */ /* fvec is an input array of length m which must contain the */ /* functions evaluated at x. */ /* fjac is an output m by n array which contains the */ /* approximation to the jacobian matrix evaluated at x. */ /* ldfjac is a positive integer input variable not less than m */ /* which specifies the leading dimension of the array fjac. */ /* iflag is an integer variable which can be used to terminate */ /* the execution of fdjac2. see description of fcn. */ /* 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. */ /* wa is a work array of length m. */ /* subprograms called */ /* user-supplied ...... fcn */ /* minpack-supplied ... dpmpar */ /* fortran-supplied ... dabs,dmax1,dsqrt */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ /* epsmch is the machine precision. */ epsmch = __cminpack_func__(dpmpar)(1); eps = sqrt((max(epsfcn,epsmch))); for (j = 0; j < n; ++j) { temp = x[j]; h = eps * fabs(temp); if (h == 0.) { h = eps; } x[j] = temp + h; /* the last parameter of fcn_mn() is set to 2 to tell calls made to compute the function from calls made to compute the Jacobian (see fcn() in tlmfdrv.c) */ iflag = fcn_mn(p, m, n, x, wa, 2); if (iflag < 0) { return iflag; } x[j] = temp; for (i = 0; i < m; ++i) { fjac[i + j * ldfjac] = (wa[i] - fvec[i]) / h; } } return 0; /* last card of subroutine fdjac2. */ } /* fdjac2_ */
int main() { int i, j, ldfjac, maxfev, mode, nprint, info, nfev, njev; int ipvt[3]; real ftol, xtol, gtol, factor, fnorm; real x[3], fvec[15], fjac[3*3], diag[3], qtf[3], wa1[3], wa2[3], wa3[3], wa4[15]; int k; const int m = 15; const int n = 3; /* auxiliary data (e.g. measurements) */ real y[15] = {1.4e-1, 1.8e-1, 2.2e-1, 2.5e-1, 2.9e-1, 3.2e-1, 3.5e-1, 3.9e-1, 3.7e-1, 5.8e-1, 7.3e-1, 9.6e-1, 1.34, 2.1, 4.39}; fcndata_t data; data.m = m; data.y = y; /* the following starting values provide a rough fit. */ x[0] = 1.; x[1] = 1.; x[2] = 1.; ldfjac = 3; /* set ftol and xtol to the square root of the machine */ /* and gtol to zero. unless high solutions are */ /* required, these are the recommended settings. */ ftol = sqrt(__cminpack_func__(dpmpar)(1)); xtol = sqrt(__cminpack_func__(dpmpar)(1)); gtol = 0.; maxfev = 400; mode = 1; factor = 1.e2; nprint = 0; info = __cminpack_func__(lmstr)(fcn, &data, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, diag, mode, factor, nprint, &nfev, &njev, ipvt, qtf, wa1, wa2, wa3, wa4); fnorm = __cminpack_func__(enorm)(m, fvec); printf(" final l2 norm of the residuals%15.7g\n\n", (double)fnorm); printf(" number of function evaluations%10i\n\n", nfev); printf(" number of Jacobian evaluations%10i\n\n", njev); printf(" exit parameter %10i\n\n", info); printf(" final approximate solution\n"); for (j=0; j<n; ++j) { printf("%s%15.7g", j%3==0?"\n ":"", (double)x[j]); } printf("\n"); ftol = __cminpack_func__(dpmpar)(1); #ifdef TEST_COVAR { /* test the original covar from MINPACK */ real covfac = fnorm*fnorm/(m-n); real fjac1[3*3]; memcpy(fjac1, fjac, sizeof(fjac)); __cminpack_func__(covar)(n, fjac1, ldfjac, ipvt, ftol, wa1); printf(" covariance (using covar)\n"); for (i=0; i<n; ++i) { for (j=0; j<n; ++j) { printf("%s%15.7g", j%3==0?"\n ":"", (double)fjac1[i*ldfjac+j]*covfac); } } printf("\n"); } #endif /* test covar1, which also estimates the rank of the Jacobian */ k = __cminpack_func__(covar1)(m, n, fnorm*fnorm, fjac, ldfjac, ipvt, ftol, wa1); printf(" covariance\n"); for (i=0; i<n; ++i) { for (j=0; j<n; ++j) { printf("%s%15.7g", j%3==0?"\n ":"", (double)fjac[i*ldfjac+j]); } } printf("\n"); (void)k; /* printf(" rank(J) = %d\n", k != 0 ? k : n); */ return 0; }
__cminpack_attr__ void __cminpack_func__(qrfac)(int m, int n, real *a, int lda, int pivot, int *ipvt, int lipvt, real *rdiag, real *acnorm, real *wa) { #ifdef USE_LAPACK int i, j, k; double t; double* tau = wa; const int ltau = m > n ? n : m; int lwork = -1; int info = 0; double* work; if (pivot) { assert( lipvt >= n ); /* set all columns free */ memset(ipvt, 0, sizeof(int)*n); } /* query optimal size of work */ lwork = -1; if (pivot) { dgeqp3_(&m,&n,a,&lda,ipvt,tau,tau,&lwork,&info); lwork = (int)tau[0]; assert( lwork >= 3*n+1 ); } else { dgeqrf_(&m,&n,a,&lda,tau,tau,&lwork,&info); lwork = (int)tau[0]; assert( lwork >= 1 && lwork >= n ); } assert( info == 0 ); /* alloc work area */ work = (double *)malloc(sizeof(double)*lwork); assert(work != NULL); /* set acnorm first (from the doc of qrfac, acnorm may point to the same area as rdiag) */ if (acnorm != rdiag) { for (j = 0; j < n; ++j) { acnorm[j] = __cminpack_enorm__(m, &a[j * lda]); } } /* QR decomposition */ if (pivot) { dgeqp3_(&m,&n,a,&lda,ipvt,tau,work,&lwork,&info); } else { dgeqrf_(&m,&n,a,&lda,tau,work,&lwork,&info); } assert(info == 0); /* set rdiag, before the diagonal is replaced */ memset(rdiag, 0, sizeof(double)*n); for(i=0 ; i<n ; ++i) { rdiag[i] = a[i*lda+i]; } /* modify lower trinagular part to look like qrfac's output */ for(i=0 ; i<ltau ; ++i) { k = i*lda+i; t = tau[i]; a[k] = t; for(j=i+1 ; j<m ; j++) { k++; a[k] *= t; } } free(work); #else /* !USE_LAPACK */ /* Initialized data */ #define p05 .05 /* System generated locals */ real d1; /* Local variables */ int i, j, k, jp1; real sum; real temp; int minmn; real epsmch; real ajnorm; /* ********** */ /* subroutine qrfac */ /* this subroutine uses householder transformations with column */ /* pivoting (optional) to compute a qr factorization of the */ /* m by n matrix a. that is, qrfac determines an orthogonal */ /* matrix q, a permutation matrix p, and an upper trapezoidal */ /* matrix r with diagonal elements of nonincreasing magnitude, */ /* such that a*p = q*r. the householder transformation for */ /* column k, k = 1,2,...,min(m,n), is of the form */ /* t */ /* i - (1/u(k))*u*u */ /* where u has zeros in the first k-1 positions. the form of */ /* this transformation and the method of pivoting first */ /* appeared in the corresponding linpack subroutine. */ /* the subroutine statement is */ /* subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) */ /* where */ /* m is a positive integer input variable set to the number */ /* of rows of a. */ /* n is a positive integer input variable set to the number */ /* of columns of a. */ /* a is an m by n array. on input a contains the matrix for */ /* which the qr factorization is to be computed. on output */ /* the strict upper trapezoidal part of a contains the strict */ /* upper trapezoidal part of r, and the lower trapezoidal */ /* part of a contains a factored form of q (the non-trivial */ /* elements of the u vectors described above). */ /* lda is a positive integer input variable not less than m */ /* which specifies the leading dimension of the array a. */ /* pivot is a logical input variable. if pivot is set true, */ /* then column pivoting is enforced. if pivot is set false, */ /* then no column pivoting is done. */ /* ipvt is an integer output array of length lipvt. ipvt */ /* defines the permutation matrix p such that a*p = q*r. */ /* column j of p is column ipvt(j) of the identity matrix. */ /* if pivot is false, ipvt is not referenced. */ /* lipvt is a positive integer input variable. if pivot is false, */ /* then lipvt may be as small as 1. if pivot is true, then */ /* lipvt must be at least n. */ /* rdiag is an output array of length n which contains the */ /* diagonal elements of r. */ /* acnorm is an output array of length n which contains the */ /* norms of the corresponding columns of the input matrix a. */ /* if this information is not needed, then acnorm can coincide */ /* with rdiag. */ /* wa is a work array of length n. if pivot is false, then wa */ /* can coincide with rdiag. */ /* subprograms called */ /* minpack-supplied ... dpmpar,enorm */ /* fortran-supplied ... dmax1,dsqrt,min0 */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ (void)lipvt; /* epsmch is the machine precision. */ epsmch = __cminpack_func__(dpmpar)(1); /* compute the initial column norms and initialize several arrays. */ for (j = 0; j < n; ++j) { acnorm[j] = __cminpack_enorm__(m, &a[j * lda + 0]); rdiag[j] = acnorm[j]; wa[j] = rdiag[j]; if (pivot) { ipvt[j] = j+1; } } /* reduce a to r with householder transformations. */ minmn = min(m,n); for (j = 0; j < minmn; ++j) { if (pivot) { /* bring the column of largest norm into the pivot position. */ int kmax = j; for (k = j; k < n; ++k) { if (rdiag[k] > rdiag[kmax]) { kmax = k; } } if (kmax != j) { for (i = 0; i < m; ++i) { temp = a[i + j * lda]; a[i + j * lda] = a[i + kmax * lda]; a[i + kmax * lda] = temp; } rdiag[kmax] = rdiag[j]; wa[kmax] = wa[j]; k = ipvt[j]; ipvt[j] = ipvt[kmax]; ipvt[kmax] = k; } } /* compute the householder transformation to reduce the */ /* j-th column of a to a multiple of the j-th unit vector. */ ajnorm = __cminpack_enorm__(m - (j+1) + 1, &a[j + j * lda]); if (ajnorm != 0.) { if (a[j + j * lda] < 0.) { ajnorm = -ajnorm; } for (i = j; i < m; ++i) { a[i + j * lda] /= ajnorm; } a[j + j * lda] += 1.; /* apply the transformation to the remaining columns */ /* and update the norms. */ jp1 = j + 1; if (n > jp1) { for (k = jp1; k < n; ++k) { sum = 0.; for (i = j; i < m; ++i) { sum += a[i + j * lda] * a[i + k * lda]; } temp = sum / a[j + j * lda]; for (i = j; i < m; ++i) { a[i + k * lda] -= temp * a[i + j * lda]; } if (pivot && rdiag[k] != 0.) { temp = a[j + k * lda] / rdiag[k]; /* Computing MAX */ d1 = 1. - temp * temp; rdiag[k] *= sqrt((max((real)0.,d1))); /* Computing 2nd power */ d1 = rdiag[k] / wa[k]; if (p05 * (d1 * d1) <= epsmch) { rdiag[k] = __cminpack_enorm__(m - (j+1), &a[jp1 + k * lda]); wa[k] = rdiag[k]; } } } } } rdiag[j] = -ajnorm; } /* last card of subroutine qrfac. */ #endif /* !USE_LAPACK */ } /* qrfac_ */
MAP_ERROR_CODE call_minpack_lmder(Line* line, InnerSolveAttributes* inner_opt, const int line_num, const float time, char* map_msg, MAP_ERROR_CODE* ierr) { MAP_ERROR_CODE success = MAP_SAFE; /* initial guess vector is set in set_line_initial_guess(..); otherwise, the previous solution is used as the initial guess */ inner_opt->x[0] = fabs(*(line->H.value)) > MAP_HORIZONTAL_TOL ? fabs(*(line->H.value)) : MAP_HORIZONTAL_TOL; // inner_opt->x[0] = *(line->H.value); inner_opt->x[1] = *(line->V.value); line->evals = 0; line->njac_evals = 0; inner_opt->info = __cminpack_func__(lmder)(inner_function_evals, line, inner_opt->m, inner_opt->n, inner_opt->x, inner_opt->fvec, inner_opt->fjac, inner_opt->ldfjac, inner_opt->f_tol, inner_opt->x_tol, inner_opt->g_tol, inner_opt->max_its, inner_opt->diag, inner_opt->mode, inner_opt->factor, inner_opt->nprint, &line->evals, &line->njac_evals, inner_opt->ipvt, inner_opt->qtf, inner_opt->wa1 , inner_opt->wa2 , inner_opt->wa3 , inner_opt->wa4); line->residual_norm = (double)__minpack_func__(enorm)(&inner_opt->m, inner_opt->fvec); if (line->options.diagnostics_flag && (double)line->diagnostic_type>time /* || line->residual_norm>inner_opt->f_tol */ ) { printf("\n %4.3f [sec] Line %d\n",time, line_num); printf(" ----------------------------------------------------\n"); printf(" Residual l2 norm at solution: %15.7g\n", line->residual_norm); printf(" Function evaluations: %10i\n", line->evals); printf(" Jacobian evaluations: %10i\n", line->njac_evals); if (line->residual_norm>inner_opt->f_tol) { printf(" WARNING: l2 norm is much larger than f_tol. Premature convergence is likely\n"); } printf(" Exit parameter %10i\n\n", inner_opt->info); }; *(line->H.value) = inner_opt->x[0]; *(line->V.value) = inner_opt->x[1]; line->converge_reason = inner_opt->info; switch (inner_opt->info) { case 0 : success = MAP_FATAL; set_universal_error_with_message(map_msg, ierr, MAP_FATAL_39, "Line segment %d.", line_num); break; case 1 : success = MAP_SAFE; break; case 2 : success = MAP_SAFE; break; case 3 : success = MAP_SAFE; break; case 4 : success = MAP_SAFE; break; case 5 : success = MAP_FATAL; set_universal_error_with_message(map_msg, ierr, MAP_FATAL_40, "Line segment %d.", line_num); break; case 6 : success = MAP_FATAL; set_universal_error_with_message(map_msg, ierr, MAP_ERROR_11, "Line segment %d.", line_num); break; case 7 : success = MAP_FATAL; set_universal_error_with_message(map_msg, ierr, MAP_ERROR_13, "Line segment %d.", line_num); break; case 8 : success = MAP_FATAL; set_universal_error_with_message(map_msg, ierr, MAP_ERROR_12, "Line segment %d.", line_num); break; default : success = MAP_SAFE; break; }; return MAP_SAFE; };
__cminpack_attr__ int __cminpack_func__(hybrj)(__cminpack_decl_fcnder_nn__ void *p, int n, real *x, real * fvec, real *fjac, int ldfjac, real xtol, int maxfev, real *diag, int mode, real factor, int nprint, int *nfev, int *njev, real *r, int lr, real *qtf, real *wa1, real *wa2, real *wa3, real *wa4, void* user_data) { /* Initialized data */ #define p1 .1 #define p5 .5 #define p001 .001 #define p0001 1e-4 /* System generated locals */ int fjac_dim1, fjac_offset; real d1, d2; /* Local variables */ int i, j, l, jm1, iwa[1]; real sum; int sing; int iter; real temp; int iflag; real delta = 0.; int jeval; int ncsuc; real ratio; real fnorm; real pnorm, xnorm = 0., fnorm1; int nslow1, nslow2; int ncfail; real 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 = __cminpack_func__(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 = fcnder_nn(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 1, user_data); *nfev = 1; if (iflag < 0) { goto TERMINATE; } fnorm = __cminpack_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 = fcnder_nn(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 2, user_data); ++(*njev); if (iflag < 0) { goto TERMINATE; } /* compute the qr factorization of the jacobian. */ __cminpack_func__(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 = __cminpack_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. */ __cminpack_func__(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 = fcnder_nn(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 0, user_data); } if (iflag < 0) { goto TERMINATE; } } /* determine the direction p. */ __cminpack_func__(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 = __cminpack_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 = fcnder_nn(p, n, &wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, 1, user_data); ++(*nfev); if (iflag < 0) { goto TERMINATE; } fnorm1 = __cminpack_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 = __cminpack_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 = __cminpack_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. */ __cminpack_func__(r1updt)(n, n, &r[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing); __cminpack_func__(r1mpyq)(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]); __cminpack_func__(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) { fcnder_nn(p, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, 0, user_data); } return info; /* last card of subroutine hybrj. */ } /* hybrj_ */