__minpack_attr__ void __minpack_func__(lmstr)(__minpack_decl_fcnderstr_mn__ const int *m, const int *n, real *x, real *fvec, real *fjac, const int *ldfjac, const real *ftol, const real *xtol, const real *gtol, const int *maxfev, real * diag, const int *mode, const real *factor, const int *nprint, int * info, int *nfev, int *njev, int *ipvt, real *qtf, real *wa1, real *wa2, real *wa3, real *wa4) { /* Table of constant values */ const int c__1 = 1; const int c_true = TRUE_; /* Initialized data */ #define p1 .1 #define p5 .5 #define p25 .25 #define p75 .75 #define p0001 1e-4 /* System generated locals */ int fjac_dim1, fjac_offset, i__1, i__2; real d__1, d__2, d__3; /* Local variables */ int i__, j, l; real par, sum; int sing; int iter; real temp, temp1, temp2; int iflag; real delta; real ratio; real fnorm, gnorm, pnorm, xnorm = 0, fnorm1, actred, dirder, epsmch, prered; /* ********** */ /* 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 */ /* ********** */ /* Parameter adjustments */ --wa4; --fvec; --wa3; --wa2; --wa1; --qtf; --ipvt; --diag; --x; fjac_dim1 = *ldfjac; fjac_offset = 1 + fjac_dim1 * 1; fjac -= fjac_offset; /* Function Body */ /* epsmch is the machine precision. */ epsmch = __minpack_func__(dpmpar)(&c__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 L340; } if (*mode != 2) { goto L20; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (diag[j] <= 0.) { goto L340; } /* L10: */ } L20: /* evaluate the function at the starting point */ /* and calculate its norm. */ iflag = 1; fcnderstr_mn(m, n, &x[1], &fvec[1], &wa3[1], &iflag); *nfev = 1; if (iflag < 0) { goto L340; } fnorm = __minpack_func__(enorm)(m, &fvec[1]); /* initialize levenberg-marquardt parameter and iteration counter. */ par = 0.; iter = 1; /* beginning of the outer loop. */ L30: /* if requested, call fcn to enable printing of iterates. */ if (*nprint <= 0) { goto L40; } iflag = 0; if ((iter - 1) % *nprint == 0) { fcnderstr_mn(m, n, &x[1], &fvec[1], &wa3[1], &iflag); } if (iflag < 0) { goto L340; } L40: /* 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. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { qtf[j] = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { fjac[i__ + j * fjac_dim1] = 0.; /* L50: */ } /* L60: */ } iflag = 2; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { fcnderstr_mn(m, n, &x[1], &fvec[1], &wa3[1], &iflag); if (iflag < 0) { goto L340; } temp = fvec[i__]; __minpack_func__(rwupdt)(n, &fjac[fjac_offset], ldfjac, &wa3[1], &qtf[1], &temp, &wa1[ 1], &wa2[1]); ++iflag; /* L70: */ } ++(*njev); /* if the jacobian is rank deficient, call qrfac to */ /* reorder its columns and update the components of qtf. */ sing = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (fjac[j + j * fjac_dim1] == 0.) { sing = TRUE_; } ipvt[j] = j; wa2[j] = __minpack_func__(enorm)(&j, &fjac[j * fjac_dim1 + 1]); /* L80: */ } if (! sing) { goto L130; } __minpack_func__(qrfac)(n, n, &fjac[fjac_offset], ldfjac, &c_true, &ipvt[1], n, &wa1[1], & wa2[1], &wa3[1]); i__1 = *n; for (j = 1; j <= i__1; ++j) { if (fjac[j + j * fjac_dim1] == 0.) { goto L110; } sum = 0.; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * qtf[i__]; /* L90: */ } temp = -sum / fjac[j + j * fjac_dim1]; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { qtf[i__] += fjac[i__ + j * fjac_dim1] * temp; /* L100: */ } L110: fjac[j + j * fjac_dim1] = wa1[j]; /* L120: */ } L130: /* on the first iteration and if mode is 1, scale according */ /* to the norms of the columns of the initial jacobian. */ if (iter != 1) { goto L170; } if (*mode == 2) { goto L150; } i__1 = *n; for (j = 1; j <= i__1; ++j) { diag[j] = wa2[j]; if (wa2[j] == 0.) { diag[j] = 1.; } /* L140: */ } L150: /* on the first iteration, calculate the norm of the scaled x */ /* and initialize the step bound delta. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { wa3[j] = diag[j] * x[j]; /* L160: */ } xnorm = __minpack_func__(enorm)(n, &wa3[1]); delta = *factor * xnorm; if (delta == 0.) { delta = *factor; } L170: /* compute the norm of the scaled gradient. */ gnorm = 0.; if (fnorm == 0.) { goto L210; } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = ipvt[j]; if (wa2[l] == 0.) { goto L190; } sum = 0.; i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * (qtf[i__] / fnorm); /* L180: */ } /* Computing MAX */ d__2 = gnorm, d__3 = (d__1 = sum / wa2[l], abs(d__1)); gnorm = max(d__2,d__3); L190: /* L200: */ ; } L210: /* test for convergence of the gradient norm. */ if (gnorm <= *gtol) { *info = 4; } if (*info != 0) { goto L340; } /* rescale if necessary. */ if (*mode == 2) { goto L230; } i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = diag[j], d__2 = wa2[j]; diag[j] = max(d__1,d__2); /* L220: */ } L230: /* beginning of the inner loop. */ L240: /* determine the levenberg-marquardt parameter. */ __minpack_func__(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. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = -wa1[j]; wa2[j] = x[j] + wa1[j]; wa3[j] = diag[j] * wa1[j]; /* L250: */ } pnorm = __minpack_func__(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 = 1; fcnderstr_mn(m, n, &wa2[1], &wa4[1], &wa3[1], &iflag); ++(*nfev); if (iflag < 0) { goto L340; } fnorm1 = __minpack_func__(enorm)(m, &wa4[1]); /* compute the scaled actual reduction. */ actred = -1.; if (p1 * fnorm1 < fnorm) { /* Computing 2nd power */ d__1 = fnorm1 / fnorm; actred = 1. - d__1 * d__1; } /* compute the scaled predicted reduction and */ /* the scaled directional derivative. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { wa3[j] = 0.; l = ipvt[j]; temp = wa1[l]; i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { wa3[i__] += fjac[i__ + j * fjac_dim1] * temp; /* L260: */ } /* L270: */ } temp1 = __minpack_func__(enorm)(n, &wa3[1]) / fnorm; temp2 = sqrt(par) * pnorm / fnorm; /* Computing 2nd power */ d__1 = temp1; /* Computing 2nd power */ d__2 = temp2; prered = d__1 * d__1 + d__2 * d__2 / p5; /* Computing 2nd power */ d__1 = temp1; /* Computing 2nd power */ d__2 = temp2; dirder = -(d__1 * d__1 + d__2 * d__2); /* 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) { goto L280; } if (actred >= 0.) { temp = p5; } if (actred < 0.) { temp = p5 * dirder / (dirder + p5 * actred); } if (p1 * fnorm1 >= fnorm || temp < p1) { temp = p1; } /* Computing MIN */ d__1 = delta, d__2 = pnorm / p1; delta = temp * min(d__1,d__2); par /= temp; goto L300; L280: if (par != 0. && ratio < p75) { goto L290; } delta = pnorm / p5; par = p5 * par; L290: L300: /* test for successful iteration. */ if (ratio < p0001) { goto L330; } /* successful iteration. update x, fvec, and their norms. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { x[j] = wa2[j]; wa2[j] = diag[j] * x[j]; /* L310: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { fvec[i__] = wa4[i__]; /* L320: */ } xnorm = __minpack_func__(enorm)(n, &wa2[1]); fnorm = fnorm1; ++iter; L330: /* tests for convergence. */ if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= 1.) { *info = 1; } if (delta <= *xtol * xnorm) { *info = 2; } if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= 1. && *info == 2) { *info = 3; } if (*info != 0) { goto L340; } /* tests for termination and stringent tolerances. */ if (*nfev >= *maxfev) { *info = 5; } if (abs(actred) <= epsmch && prered <= epsmch && p5 * ratio <= 1.) { *info = 6; } if (delta <= epsmch * xnorm) { *info = 7; } if (gnorm <= epsmch) { *info = 8; } if (*info != 0) { goto L340; } /* end of the inner loop. repeat if iteration unsuccessful. */ if (ratio < p0001) { goto L240; } /* end of the outer loop. */ goto L30; L340: /* termination, either normal or user imposed. */ if (iflag < 0) { *info = iflag; } iflag = 0; if (*nprint > 0) { fcnderstr_mn(m, n, &x[1], &fvec[1], &wa3[1], &iflag); } return; /* last card of subroutine lmstr. */ } /* lmstr_ */
__minpack_attr__ void __minpack_func__(hybrj1)(__minpack_decl_fcnder_nn__ const int *n, real *x, real * fvec, real *fjac, const int *ldfjac, const real *tol, int * info, real *wa, const int *lwa, void* user_data) { /* Initialized data */ const real factor = 100.; /* System generated locals */ int fjac_dim1, fjac_offset, i__1; /* Local variables */ int j, lr, mode, nfev, njev; real xtol; int maxfev, nprint; /* ********** */ /* subroutine hybrj1 */ /* the purpose of hybrj1 is to find a zero of a system of */ /* n nonlinear functions in n variables by a modification */ /* of the powell hybrid method. this is done by using the */ /* more general nonlinear equation solver hybrj. the user */ /* must provide a subroutine which calculates the functions */ /* and the jacobian. */ /* the subroutine statement is */ /* subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) */ /* 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 hybrj1. */ /* 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. */ /* tol is a nonnegative input variable. termination occurs */ /* when the algorithm estimates that the relative error */ /* between x and the solution is at most tol. */ /* 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 algorithm estimates that the relative error */ /* between x and the solution is at most tol. */ /* info = 2 number of calls to fcn with iflag = 1 has */ /* reached 100*(n+1). */ /* info = 3 tol is too small. no further improvement in */ /* the approximate solution x is possible. */ /* info = 4 iteration is not making good progress. */ /* wa is a work array of length lwa. */ /* lwa is a positive integer input variable not less than */ /* (n*(n+13))/2. */ /* subprograms called */ /* user-supplied ...... fcn */ /* minpack-supplied ... hybrj */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ /* Parameter adjustments */ --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = 1 + fjac_dim1 * 1; fjac -= fjac_offset; --wa; /* Function Body */ *info = 0; /* check the input parameters for errors. */ if (*n <= 0 || *ldfjac < *n || *tol < 0. || *lwa < *n * (*n + 13) / 2) { /* goto L20; */ return; } /* call hybrj. */ maxfev = (*n + 1) * 100; xtol = *tol; mode = 2; i__1 = *n; for (j = 1; j <= i__1; ++j) { wa[j] = 1.; /* L10: */ } nprint = 0; lr = *n * (*n + 1) / 2; __minpack_func__(hybrj)(__minpack_param_fcnder_nn__ n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &xtol, & maxfev, &wa[1], &mode, &factor, &nprint, info, &nfev, &njev, &wa[* n * 6 + 1], &lr, &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1], &wa[(*n << 2) + 1], &wa[*n * 5 + 1], user_data); if (*info == 5) { *info = 4; } /* L20: */ return; /* last card of subroutine hybrj1. */ } /* hybrj1_ */
__minpack_attr__ void __minpack_func__(lmdif1)(__minpack_decl_fcn_mn__ const int *m, const int *n, real *x, real *fvec, const real *tol, int *info, int *iwa, real *wa, const int *lwa) { /* Initialized data */ const real factor = 100.; int mp5n, mode, nfev; real ftol, gtol, xtol; real epsfcn; int maxfev, nprint; /* ********** */ /* subroutine lmdif1 */ /* the purpose of lmdif1 is to minimize the sum of the squares of */ /* m nonlinear functions in n variables by a modification of the */ /* levenberg-marquardt algorithm. this is done by using the more */ /* general least-squares solver lmdif. 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 lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) */ /* 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 lmdif1. */ /* 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. */ /* tol is a nonnegative input variable. termination occurs */ /* when the algorithm estimates either that the relative */ /* error in the sum of squares is at most tol or that */ /* the relative error between x and the solution is at */ /* most tol. */ /* 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 algorithm estimates that the relative error */ /* in the sum of squares is at most tol. */ /* info = 2 algorithm estimates that the relative error */ /* between x and the solution is at most tol. */ /* info = 3 conditions for info = 1 and info = 2 both hold. */ /* info = 4 fvec is orthogonal to the columns of the */ /* jacobian to machine precision. */ /* info = 5 number of calls to fcn has reached or */ /* exceeded 200*(n+1). */ /* info = 6 tol is too small. no further reduction in */ /* the sum of squares is possible. */ /* info = 7 tol is too small. no further improvement in */ /* the approximate solution x is possible. */ /* iwa is an integer work array of length n. */ /* wa is a work array of length lwa. */ /* lwa is a positive integer input variable not less than */ /* m*n+5*n+m. */ /* subprograms called */ /* user-supplied ...... fcn */ /* minpack-supplied ... lmdif */ /* argonne national laboratory. minpack project. march 1980. */ /* burton s. garbow, kenneth e. hillstrom, jorge j. more */ /* ********** */ /* Parameter adjustments */ --fvec; --iwa; --x; --wa; /* Function Body */ *info = 0; /* check the input parameters for errors. */ if (*n <= 0 || *m < *n || *tol < 0. || *lwa < *m * *n + *n * 5 + *m) { /* goto L10; */ return; } /* call lmdif. */ maxfev = (*n + 1) * 200; ftol = *tol; xtol = *tol; gtol = 0.; epsfcn = 0.; mode = 1; nprint = 0; mp5n = *m + *n * 5; __minpack_func__(lmdif)(__minpack_param_fcn_mn__ m, n, &x[1], &fvec[1], &ftol, &xtol, >ol, &maxfev, & epsfcn, &wa[1], &mode, &factor, &nprint, info, &nfev, &wa[mp5n + 1], m, &iwa[1], &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1], &wa[(*n << 2) + 1], &wa[*n * 5 + 1]); if (*info == 8) { *info = 4; } /* L10: */ return; /* last card of subroutine lmdif1. */ } /* lmdif1_ */
/* 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]; const int i1 = 1, i2 = 2; 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'); __minpack_func__(chkder)(&n,&n,x1,NULL,NULL,&ldfjac,x2,NULL,&i1,NULL); vecfcn(n,x1,fvec1,nprob); errjac(n,x1,fjac,ldfjac,nprob); vecfcn(n,x2,fvec2,nprob); __minpack_func__(chkder)(&n,&n,x1,fvec1,fjac,&ldfjac,NULL,fvec2,&i2,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); }
__minpack_attr__ void __minpack_func__(hybrd)(__minpack_decl_fcn_nn__ const int *n, real *x, real * fvec, const real *xtol, const int *maxfev, const int *ml, const int *mu, const real *epsfcn, real *diag, const int *mode, const real * factor, const int *nprint, int *info, int *nfev, real * fjac, const int *ldfjac, real *r__, const int *lr, real *qtf, real *wa1, real *wa2, real *wa3, real *wa4) { /* Table of constant values */ const int c__1 = 1; const int c_false = FALSE_; /* Initialized data */ #define p1 .1 #define p5 .5 #define p001 .001 #define p0001 1e-4 /* System generated locals */ int fjac_dim1, fjac_offset, i__1, i__2; real d__1, d__2; /* Local variables */ int i__, j, l, jm1, iwa[1]; real sum; int sing; int iter; real temp; int msum, iflag; real delta; int jeval; int ncsuc; real ratio; real fnorm; real pnorm, xnorm = 0, fnorm1; int nslow1, nslow2; int ncfail; real actred, epsmch, prered; /* ********** */ /* subroutine hybrd */ /* the purpose of hybrd 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. the jacobian is */ /* then calculated by a forward-difference approximation. */ /* the subroutine statement is */ /* subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, */ /* diag,mode,factor,nprint,info,nfev,fjac, */ /* ldfjac,r,lr,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(n,x,fvec,iflag) */ /* integer n,iflag */ /* double precision x(n),fvec(n) */ /* ---------- */ /* 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 hybrd. */ /* 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. */ /* 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 is at least maxfev */ /* by the end of an iteration. */ /* ml is a nonnegative integer input variable which specifies */ /* the number of subdiagonals within the band of the */ /* jacobian matrix. if the jacobian is not banded, set */ /* ml to at least n - 1. */ /* mu is a nonnegative integer input variable which specifies */ /* the number of superdiagonals within the band of the */ /* jacobian matrix. if the jacobian is not banded, set */ /* mu to at least n - 1. */ /* 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 relative error between two consecutive iterates */ /* is at most xtol. */ /* info = 2 number of calls to fcn has reached or exceeded */ /* 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. */ /* 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. */ /* 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,fdjac1, */ /* qform,qrfac,r1mpyq,r1updt */ /* fortran-supplied ... dabs,dmax1,dmin1,min0,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 = __minpack_func__(dpmpar)(&c__1); *info = 0; iflag = 0; *nfev = 0; /* check the input parameters for errors. */ if (*n <= 0 || *xtol < 0. || *maxfev <= 0 || *ml < 0 || *mu < 0 || * factor <= 0. || *ldfjac < *n || *lr < *n * (*n + 1) / 2) { goto L300; } if (*mode != 2) { goto L20; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (diag[j] <= 0.) { goto L300; } /* L10: */ } L20: /* evaluate the function at the starting point */ /* and calculate its norm. */ iflag = 1; fcn_nn(n, &x[1], &fvec[1], &iflag); *nfev = 1; if (iflag < 0) { goto L300; } fnorm = __minpack_func__(enorm)(n, &fvec[1]); /* determine the number of calls to fcn needed to compute */ /* the jacobian matrix. */ /* Computing MIN */ i__1 = *ml + *mu + 1; msum = min(i__1,*n); /* initialize iteration counter and monitors. */ iter = 1; ncsuc = 0; ncfail = 0; nslow1 = 0; nslow2 = 0; /* beginning of the outer loop. */ L30: jeval = TRUE_; /* calculate the jacobian matrix. */ iflag = 2; __minpack_func__(fdjac1)(__minpack_param_fcn_nn__ n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, ml, mu, epsfcn, &wa1[1], &wa2[1]); *nfev += msum; if (iflag < 0) { goto L300; } /* compute the qr factorization of the jacobian. */ __minpack_func__(qrfac)(n, n, &fjac[fjac_offset], ldfjac, &c_false, iwa, &c__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) { goto L70; } if (*mode == 2) { goto L50; } i__1 = *n; for (j = 1; j <= i__1; ++j) { diag[j] = wa2[j]; if (wa2[j] == 0.) { diag[j] = 1.; } /* L40: */ } L50: /* on the first iteration, calculate the norm of the scaled x */ /* and initialize the step bound delta. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { wa3[j] = diag[j] * x[j]; /* L60: */ } xnorm = __minpack_func__(enorm)(n, &wa3[1]); delta = *factor * xnorm; if (delta == 0.) { delta = *factor; } L70: /* form (q transpose)*fvec and store in qtf. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { qtf[i__] = fvec[i__]; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (fjac[j + j * fjac_dim1] == 0.) { goto L110; } sum = 0.; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * qtf[i__]; /* L90: */ } temp = -sum / fjac[j + j * fjac_dim1]; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { qtf[i__] += fjac[i__ + j * fjac_dim1] * temp; /* L100: */ } L110: /* L120: */ ; } /* copy the triangular factor of the qr factorization into r. */ sing = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { l = j; jm1 = j - 1; if (jm1 < 1) { goto L140; } i__2 = jm1; for (i__ = 1; i__ <= i__2; ++i__) { r__[l] = fjac[i__ + j * fjac_dim1]; l = l + *n - i__; /* L130: */ } L140: r__[l] = wa1[j]; if (wa1[j] == 0.) { sing = TRUE_; } /* L150: */ } /* accumulate the orthogonal factor in fjac. */ __minpack_func__(qform)(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]); /* rescale if necessary. */ if (*mode == 2) { goto L170; } i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = diag[j], d__2 = wa2[j]; diag[j] = max(d__1,d__2); /* L160: */ } L170: /* beginning of the inner loop. */ L180: /* if requested, call fcn to enable printing of iterates. */ if (*nprint <= 0) { goto L190; } iflag = 0; if ((iter - 1) % *nprint == 0) { fcn_nn(n, &x[1], &fvec[1], &iflag); } if (iflag < 0) { goto L300; } L190: /* determine the direction p. */ __minpack_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. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = -wa1[j]; wa2[j] = x[j] + wa1[j]; wa3[j] = diag[j] * wa1[j]; /* L200: */ } pnorm = __minpack_func__(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 = 1; fcn_nn(n, &wa2[1], &wa4[1], &iflag); ++(*nfev); if (iflag < 0) { goto L300; } fnorm1 = __minpack_func__(enorm)(n, &wa4[1]); /* compute the scaled actual reduction. */ actred = -1.; if (fnorm1 < fnorm) { /* Computing 2nd power */ d__1 = fnorm1 / fnorm; actred = 1. - d__1 * d__1; } /* compute the scaled predicted reduction. */ l = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = 0.; i__2 = *n; for (j = i__; j <= i__2; ++j) { sum += r__[l] * wa1[j]; ++l; /* L210: */ } wa3[i__] = qtf[i__] + sum; /* L220: */ } temp = __minpack_func__(enorm)(n, &wa3[1]); prered = 0.; if (temp < fnorm) { /* Computing 2nd power */ d__1 = temp / fnorm; prered = 1. - d__1 * d__1; } /* 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) { goto L230; } ncsuc = 0; ++ncfail; delta = p5 * delta; goto L240; L230: ncfail = 0; ++ncsuc; if (ratio >= p5 || ncsuc > 1) { /* Computing MAX */ d__1 = delta, d__2 = pnorm / p5; delta = max(d__1,d__2); } if (fabs(ratio - 1.) <= p1) { delta = pnorm / p5; } L240: /* test for successful iteration. */ if (ratio < p0001) { goto L260; } /* successful iteration. update x, fvec, and their norms. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { x[j] = wa2[j]; wa2[j] = diag[j] * x[j]; fvec[j] = wa4[j]; /* L250: */ } xnorm = __minpack_func__(enorm)(n, &wa2[1]); fnorm = fnorm1; ++iter; L260: /* 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 L300; } /* tests for termination and stringent tolerances. */ if (*nfev >= *maxfev) { *info = 2; } /* Computing MAX */ d__1 = p1 * delta; if (p1 * max(d__1,pnorm) <= epsmch * xnorm) { *info = 3; } if (nslow2 == 5) { *info = 4; } if (nslow1 == 10) { *info = 5; } if (*info != 0) { goto L300; } /* criterion for recalculating jacobian approximation */ /* by forward differences. */ if (ncfail == 2) { goto L290; } /* calculate the rank one modification to the jacobian */ /* and update qtf if necessary. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * wa4[i__]; /* L270: */ } wa2[j] = (sum - wa3[j]) / pnorm; wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm); if (ratio >= p0001) { qtf[j] = sum; } /* L280: */ } /* compute the qr factorization of the updated jacobian. */ __minpack_func__(r1updt)(n, n, &r__[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing); __minpack_func__(r1mpyq)(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]); __minpack_func__(r1mpyq)(&c__1, n, &qtf[1], &c__1, &wa2[1], &wa3[1]); /* end of the inner loop. */ jeval = FALSE_; goto L180; L290: /* 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_nn(n, &x[1], &fvec[1], &iflag); } return; /* last card of subroutine hybrd. */ } /* hybrd_ */
int main() { int i, j, m, n, maxfev, mode, nprint, info, nfev, ldfjac; int ipvt[3]; real ftol, xtol, gtol, epsfcn, factor, fnorm; real x[3], fvec[15], diag[3], fjac[15*3], qtf[3], wa1[3], wa2[3], wa3[3], wa4[15]; int one=1; real covfac; m = 15; n = 3; /* the following starting values provide a rough fit. */ x[1-1] = 1.; x[2-1] = 1.; x[3-1] = 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(__minpack_func__(dpmpar)(&one)); xtol = sqrt(__minpack_func__(dpmpar)(&one)); gtol = 0.; maxfev = 800; epsfcn = 0.; mode = 1; factor = 1.e2; nprint = 0; __minpack_func__(lmdif)(&fcn, &m, &n, x, fvec, &ftol, &xtol, >ol, &maxfev, &epsfcn, diag, &mode, &factor, &nprint, &info, &nfev, fjac, &ldfjac, ipvt, qtf, wa1, wa2, wa3, wa4); fnorm = __minpack_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(" 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"); ftol = __minpack_func__(dpmpar)(&one); covfac = fnorm*fnorm/(m-n); __minpack_func__(covar)(&n, fjac, &ldfjac, ipvt, &ftol, wa1); printf(" covariance\n"); for (i=1; i<=n; i++) { for (j=1; j<=n; j++) { printf("%s%15.7g", j%3==1?"\n ":"", (double)fjac[(i-1)*ldfjac+j-1]*covfac); } } printf("\n"); return 0; }