Matrix<T> Matrix<T>::get(int rw, int cl, int nr, int nc) const
{
Matrix<T> getmat(nr,nc) ;
if ( (rw+nr) > this->rows() || (cl+nc) > this->cols()) {
#ifdef USE_EXCEPTION
throw MatrixErr();
#else
Error error("Matrix<T>::get") ;
error << "Matrix of size "<< nr << ", " << nc << " not available at " << rw << ", " << cl << endl ;
error.fatal() ;
#endif
}
int i, j;
#ifdef COLUMN_ORDER
for(i=0;i<nr;++i)
for(j=0;j<nc;++j)
getmat(i,j) = this->elem(i+rw,j+cl) ;
#else
T *pptr,*aptr ;
aptr = getmat.m-1;
for (i = 0; i < nr; ++i) {
pptr = &m[(i+rw)*cols()+cl]-1 ;
for ( j = 0; j < nc; ++j)
*(++aptr) = *(++pptr) ;
}
#endif
return getmat ;
}
fint lsqfitd_c( double *xdat ,
fint *xdim ,
double *ydat ,
double *wdat ,
fint *ndat ,
double *fpar ,
double *epar ,
fint *mpar ,
fint *npar ,
double *tol ,
fint *its ,
double *lab ,
fint *fopt )
/*
* lsqfitd is exported, and callable from C as well as Fortran.
*/
{
fint i;
fint n;
fint r;
itc = 0; /* fate of fit */
found = 0; /* reset */
nfree = 0; /* number of free parameters */
nuse = 0; /* number of legal data points */
if (*tol < (DBL_EPSILON * 10.0)) {
tolerance = DBL_EPSILON * 10.0; /* default tolerance */
} else {
tolerance = *tol; /* tolerance */
}
labda = fabs( *lab ) * LABFAC; /* start value for mixing parameter */
for (i = 0; i < (*npar); i++) {
if (mpar[i]) {
if (nfree > MAXPAR) return( -1 ); /* too many free parameters */
parptr[nfree++] = i; /* a free parameter */
}
}
if (nfree == 0) return( -2 ); /* no free parameters */
for (n = 0; n < (*ndat); n++) {
if (wdat[n] > 0.0) nuse++; /* legal weight */
}
if (nfree >= nuse) return( -3 ); /* no degrees of freedom */
if (labda == 0.0) { /* linear fit */
for (i = 0; i < nfree; fpar[parptr[i++]] = 0.0);
getmat( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
r = getvec( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
if (r) return( r ); /* error */
for (i = 0; i < (*npar); i++) {
fpar[i] = epar[i]; /* save new parameters */
epar[i] = 0.0; /* and set errors to zero */
}
chi1 = sqrt( chi1 / (double) (nuse - nfree) );
for (i = 0; i < nfree; i++) {
if ((matrix1[i][i] <= 0.0) || (matrix2[i][i] <= 0.0)) return( -7 );
epar[parptr[i]] = chi1 * sqrt( matrix2[i][i] ) / sqrt( matrix1[i][i] );
}
} else { /* Non-linear fit */
/*
* The non-linear fit uses the steepest descent method in combination
* with the Taylor method. The mixing of these methods is controlled
* by labda. In the outer loop (called the iteration loop) we build
* the matrix and calculate the correction vector. In the inner loop
* (called the interpolation loop) we check whether we have obtained
* a better solution than the previous one. If so, we leave the
* inner loop, else we increase labda (give more weight to the
* steepest descent method), calculate the correction vector and check
* again. After the inner loop we do a final check on the goodness of
* the fit and if this satisfies the tolerance we calculate the
* errors of the fitted parameters.
*/
while (!found) { /* iteration loop */
if (itc++ == (*its)) return( -4 ); /* increase iteration counter */
getmat( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
/*
* here we decrease labda since we may assume that each iteration
* brings us closer to the answer.
*/
if (labda > LABMIN) labda /= LABFAC; /* decrease labda */
r = getvec( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
if (r) return( r ); /* error */
while (chi1 >= chi2) { /* interpolation loop */
/*
* The next statement is based on experience, not on the
* mathematics of the problem although I (KGB) think that it
* is correct to assume that we have reached convergence
* when the pure steepest descent method does not produce
* a better solution. Think about this somewhat more, anyway,
* as already stated, the next statement is based on experience.
*/
if (labda > LABMAX) break; /* assume solution found */
labda *= LABFAC; /* Increase mixing parameter */
r = getvec( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
if (r) return( r ); /* error */
}
if (labda <= LABMAX) { /* save old parameters */
for (i = 0; i < (*npar); i++) fpar[i] = epar[i];
}
if (fabs( chi2 - chi1 ) <= (tolerance * chi1) || (labda > LABMAX)) {
/*
* We have a satisfying solution, so now we need to calculate
* the correct errors of the fitted parameters. This we do
* by using the pure Taylor method because we are very close
* to the real solution.
*/
labda = 0.0; /* for Taylor solution */
getmat( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
r = getvec( xdat, xdim, ydat, wdat, ndat, fpar, epar, npar, fopt );
if (r) return( r ); /* error */
for (i = 0; i < (*npar); i++) {
epar[i] = 0.0; /* and set error to zero */
}
chi2 = sqrt( chi2 / (double) (nuse - nfree) );
for (i = 0; i < nfree; i++) {
if ((matrix1[i][i] <= 0.0) || (matrix2[i][i] <= 0.0)) return( -7);
epar[parptr[i]] = chi2 * sqrt( matrix2[i][i] ) / sqrt( matrix1[i][i] );
}
found = 1; /* we found a solution */
}
}
}
return( itc ); /* return number of iterations */
}
