/* Subroutine */ void lmstr_(void (*fcn)(const int *m, const int *n, const double *x, double *fvec,
double *fjrow, int *iflag ), const int *m, const int *n, double *x,
double *fvec, double *fjac, const int *ldfjac, const double *ftol,
const double *xtol, const double *gtol, const int *maxfev, double *
diag, const int *mode, const double *factor, const int *nprint, int *
info, int *nfev, int *njev, int *ipvt, double *qtf,
double *wa1, double *wa2, double *wa3, double *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;
double d__1, d__2, d__3;
/* Local variables */
int i__, j, l;
double par, sum;
int sing;
int iter;
double temp, temp1, temp2;
int iflag;
double delta;
double ratio;
double fnorm, gnorm, pnorm, xnorm, 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 = 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;
(*fcn)(m, n, &x[1], &fvec[1], &wa3[1], &iflag);
*nfev = 1;
if (iflag < 0) {
goto L340;
}
fnorm = 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) {
(*fcn)(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__) {
(*fcn)(m, n, &x[1], &fvec[1], &wa3[1], &iflag);
if (iflag < 0) {
goto L340;
}
temp = fvec[i__];
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] = enorm_(&j, &fjac[j * fjac_dim1 + 1]);
/* L80: */
}
if (! sing) {
goto L130;
}
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 = 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. */
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 = 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)(m, n, &wa2[1], &wa4[1], &wa3[1], &iflag);
++(*nfev);
if (iflag < 0) {
goto L340;
}
fnorm1 = 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 = 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 = 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) {
(*fcn)(m, n, &x[1], &fvec[1], &wa3[1], &iflag);
}
return;
/* last card of subroutine lmstr. */
} /* lmstr_ */
/* DECK SCOV */
/* Subroutine */ int scov_(S_fp fcn, integer *iopt, integer *m, integer *n,
real *x, real *fvec, real *r__, integer *ldr, integer *info, real *
wa1, real *wa2, real *wa3, real *wa4)
{
/* Initialized data */
static real zero = 0.f;
static real one = 1.f;
/* System generated locals */
integer r_dim1, r_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, k, kp1, nm1, idum;
static logical sing;
static real temp;
static integer nrow, iflag;
extern /* Subroutine */ int qrfac_(integer *, integer *, real *, integer *
, logical *, integer *, integer *, real *, real *, real *);
static real sigma;
extern doublereal enorm_(integer *, real *);
extern /* Subroutine */ int fdjac3_(S_fp, integer *, integer *, real *,
real *, real *, integer *, integer *, real *, real *), xermsg_(
char *, char *, char *, integer *, integer *, ftnlen, ftnlen,
ftnlen), rwupdt_(integer *, real *, integer *, real *, real *,
real *, real *, real *);
/* ***BEGIN PROLOGUE SCOV */
/* ***PURPOSE Calculate the covariance matrix for a nonlinear data */
/* fitting problem. It is intended to be used after a */
/* successful return from either SNLS1 or SNLS1E. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY K1B1 */
/* ***TYPE SINGLE PRECISION (SCOV-S, DCOV-D) */
/* ***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING, */
/* NONLINEAR LEAST SQUARES */
/* ***AUTHOR Hiebert, K. L., (SNLA) */
/* ***DESCRIPTION */
/* 1. Purpose. */
/* SCOV calculates the covariance matrix for a nonlinear data */
/* fitting problem. It is intended to be used after a */
/* successful return from either SNLS1 or SNLS1E. SCOV */
/* and SNLS1 (and SNLS1E) have compatible parameters. The */
/* required external subroutine, FCN, is the same */
/* for all three codes, SCOV, SNLS1, and SNLS1E. */
/* 2. Subroutine and Type Statements. */
/* SUBROUTINE SCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO, */
/* WA1,WA2,WA3,WA4) */
/* INTEGER IOPT,M,N,LDR,INFO */
/* REAL X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M) */
/* EXTERNAL FCN */
/* 3. Parameters. */
/* FCN is the name of the user-supplied subroutine which calculates */
/* the functions. If the user wants to supply the Jacobian */
/* (IOPT=2 or 3), then FCN must be written to calculate the */
/* Jacobian, as well as the functions. See the explanation */
/* of the IOPT argument below. FCN must be declared in an */
/* EXTERNAL statement in the calling program and should be */
/* written as follows. */
/* SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) */
/* INTEGER IFLAG,LDFJAC,M,N */
/* REAL X(N),FVEC(M) */
/* ---------- */
/* FJAC and LDFJAC may be ignored , if IOPT=1. */
/* REAL FJAC(LDFJAC,N) , if IOPT=2. */
/* REAL FJAC(N) , if IOPT=3. */
/* ---------- */
/* IFLAG will never be zero when FCN is called by SCOV. */
/* RETURN */
/* ---------- */
/* If IFLAG=1, calculate the functions at X and return */
/* this vector in FVEC. */
/* RETURN */
/* ---------- */
/* If IFLAG=2, calculate the full Jacobian at X and return */
/* this matrix in FJAC. Note that IFLAG will never be 2 unless */
/* IOPT=2. FVEC contains the function values at X and must */
/* not be altered. FJAC(I,J) must be set to the derivative */
/* of FVEC(I) with respect to X(J). */
/* RETURN */
/* ---------- */
/* If IFLAG=3, calculate the LDFJAC-th row of the Jacobian */
/* and return this vector in FJAC. Note that IFLAG will */
/* never be 3 unless IOPT=3. FJAC(J) must be set to */
/* the derivative of FVEC(LDFJAC) with respect to X(J). */
/* RETURN */
/* ---------- */
/* END */
/* The value of IFLAG should not be changed by FCN unless the */
/* user wants to terminate execution of SCOV. In this case, set */
/* IFLAG to a negative integer. */
/* IOPT is an input variable which specifies how the Jacobian will */
/* be calculated. If IOPT=2 or 3, then the user must supply the */
/* Jacobian, as well as the function values, through the */
/* subroutine FCN. If IOPT=2, the user supplies the full */
/* Jacobian with one call to FCN. If IOPT=3, the user supplies */
/* one row of the Jacobian with each call. (In this manner, */
/* storage can be saved because the full Jacobian is not stored.) */
/* If IOPT=1, the code will approximate the Jacobian by forward */
/* differencing. */
/* 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 the value */
/* at which the covariance matrix is to be evaluated. This is */
/* usually the value for X returned from a successful run of */
/* SNLS1 (or SNLS1E). The value of X will not be changed. */
/* FVEC is an output array of length M which contains the functions */
/* evaluated at X. */
/* R is an output array. For IOPT=1 and 2, R is an M by N array. */
/* For IOPT=3, R is an N by N array. On output, if INFO=1, */
/* the upper N by N submatrix of R contains the covariance */
/* matrix evaluated at X. */
/* LDR is a positive integer input variable which specifies */
/* the leading dimension of the array R. For IOPT=1 and 2, */
/* LDR must not be less than M. For IOPT=3, LDR must not */
/* be less than N. */
/* 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 (M.LE.0 or N.LE.0). */
/* INFO = 1 Successful return. The covariance matrix has been */
/* calculated and stored in the upper N by N */
/* submatrix of R. */
/* INFO = 2 The Jacobian matrix is singular for the input value */
/* of X. The covariance matrix cannot be calculated. */
/* The upper N by N submatrix of R contains the QR */
/* factorization of the Jacobian (probably not of */
/* interest to the user). */
/* WA1 is a work array of length N. */
/* WA2 is a work array of length N. */
/* WA3 is a work array of length N. */
/* WA4 is a work array of length M. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED ENORM, FDJAC3, QRFAC, RWUPDT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 810522 DATE WRITTEN */
/* 890505 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Fixed an error message. (RWC) */
/* ***END PROLOGUE SCOV */
/* REVISED 820707-1100 */
/* REVISED YYMMDD HHMM */
/* Parameter adjustments */
--x;
--fvec;
r_dim1 = *ldr;
r_offset = 1 + r_dim1;
r__ -= r_offset;
--wa1;
--wa2;
--wa3;
--wa4;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT SCOV */
sing = FALSE_;
iflag = 0;
if (*m <= 0 || *n <= 0) {
goto L300;
}
/* CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N) */
iflag = 1;
(*fcn)(&iflag, m, n, &x[1], &fvec[1], &r__[r_offset], ldr);
if (iflag < 0) {
goto L300;
}
temp = enorm_(m, &fvec[1]);
sigma = one;
if (*m != *n) {
sigma = temp * temp / (*m - *n);
}
/* CALCULATE THE JACOBIAN */
if (*iopt == 3) {
goto L200;
}
/* STORE THE FULL JACOBIAN USING M*N STORAGE */
if (*iopt == 1) {
goto L100;
}
/* USER SUPPLIES THE JACOBIAN */
iflag = 2;
(*fcn)(&iflag, m, n, &x[1], &fvec[1], &r__[r_offset], ldr);
goto L110;
/* CODE APPROXIMATES THE JACOBIAN */
L100:
fdjac3_((S_fp)fcn, m, n, &x[1], &fvec[1], &r__[r_offset], ldr, &iflag, &
zero, &wa4[1]);
L110:
if (iflag < 0) {
goto L300;
}
/* COMPUTE THE QR DECOMPOSITION */
qrfac_(m, n, &r__[r_offset], ldr, &c_false, &idum, &c__1, &wa1[1], &wa1[1]
, &wa1[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L120: */
r__[i__ + i__ * r_dim1] = wa1[i__];
}
goto L225;
/* COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE */
/* ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R. */
/* ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.) */
L200:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
wa2[j] = zero;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
r__[i__ + j * r_dim1] = zero;
/* L205: */
}
/* L210: */
}
iflag = 3;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
nrow = i__;
(*fcn)(&iflag, m, n, &x[1], &fvec[1], &wa1[1], &nrow);
if (iflag < 0) {
goto L300;
}
temp = fvec[i__];
rwupdt_(n, &r__[r_offset], ldr, &wa1[1], &wa2[1], &temp, &wa3[1], &
wa4[1]);
/* L220: */
}
/* CHECK IF R IS SINGULAR. */
L225:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (r__[i__ + i__ * r_dim1] == zero) {
sing = TRUE_;
}
/* L230: */
}
if (sing) {
goto L300;
}
/* R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE */
/* IN THE UPPER TRIANGLE OF R. */
if (*n == 1) {
goto L275;
}
nm1 = *n - 1;
i__1 = nm1;
for (k = 1; k <= i__1; ++k) {
/* INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE */
/* IDENTITY MATRIX. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
wa1[i__] = zero;
/* L240: */
}
wa1[k] = one;
r__[k + k * r_dim1] = wa1[k] / r__[k + k * r_dim1];
kp1 = k + 1;
i__2 = *n;
for (i__ = kp1; i__ <= i__2; ++i__) {
/* SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*). */
i__3 = *n;
for (j = i__; j <= i__3; ++j) {
wa1[j] -= r__[k + (i__ - 1) * r_dim1] * r__[i__ - 1 + j *
r_dim1];
/* L250: */
}
r__[k + i__ * r_dim1] = wa1[i__] / r__[i__ + i__ * r_dim1];
/* L260: */
}
/* L270: */
}
L275:
r__[*n + *n * r_dim1] = one / r__[*n + *n * r_dim1];
/* CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER */
/* TRIANGLE OF R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = i__; j <= i__2; ++j) {
temp = zero;
i__3 = *n;
for (k = j; k <= i__3; ++k) {
temp += r__[i__ + k * r_dim1] * r__[j + k * r_dim1];
/* L280: */
}
r__[i__ + j * r_dim1] = temp * sigma;
/* L290: */
}
}
*info = 1;
L300:
if (*m <= 0 || *n <= 0) {
*info = 0;
}
if (iflag < 0) {
*info = iflag;
}
if (sing) {
*info = 2;
}
if (*info < 0) {
xermsg_("SLATEC", "SCOV", "EXECUTION TERMINATED BECAUSE USER SET IFL"
"AG NEGATIVE.", &c__1, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)53)
;
}
if (*info == 0) {
xermsg_("SLATEC", "SCOV", "INVALID INPUT PARAMETER.", &c__2, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)24);
}
if (*info == 2) {
xermsg_("SLATEC", "SCOV", "SINGULAR JACOBIAN MATRIX, COVARIANCE MATR"
"IX CANNOT BE CALCULATED.", &c__1, &c__1, (ftnlen)6, (ftnlen)4,
(ftnlen)65);
}
return 0;
} /* scov_ */
