GIRAFFE Pipeline Reference Manual

gilevenberg.c

00001 /* $Id: gilevenberg.c,v 1.6 2009/05/29 12:34:43 rpalsa Exp $
00002  *
00003  * This file is part of the GIRAFFE Pipeline
00004  * Copyright (C) 2002-2006 European Southern Observatory
00005  *
00006  * This program is free software; you can redistribute it and/or modify
00007  * it under the terms of the GNU General Public License as published by
00008  * the Free Software Foundation; either version 2 of the License, or
00009  * (at your option) any later version.
00010  *
00011  * This program is distributed in the hope that it will be useful,
00012  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00013  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00014  * GNU General Public License for more details.
00015  *
00016  * You should have received a copy of the GNU General Public License
00017  * along with this program; if not, write to the Free Software
00018  * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
00019  */
00020 
00021 /*
00022  * $Author: rpalsa $
00023  * $Date: 2009/05/29 12:34:43 $
00024  * $Revision: 1.6 $
00025  * $Name: giraffe-2_9 $
00026  */
00027 
00028 #ifdef HAVE_CONFIG_H
00029 #  include <config.h>
00030 #endif
00031 
00032 #include <math.h>
00033 
00034 #include <cxtypes.h>
00035 #include <cxmemory.h>
00036 
00037 #include "gimath.h"
00038 #include "gilevenberg.h"
00039 
00040 
00049 inline static void
00050 _giraffe_swap(cxdouble *a, cxdouble *b) {
00051 
00052     register cxdouble t = *a;
00053 
00054     *a = *b;
00055     *b = t;
00056 
00057     return;
00058 
00059 }
00060 
00061 
00062 inline static void
00063 _giraffe_covsrt(cpl_matrix *covar, cxint ma, cxint ia[], cxint mfit)
00064 {
00065 
00066     register cxint i, j, k;
00067 
00068     cxint nr = cpl_matrix_get_nrow(covar);
00069 
00070     cxdouble *_covar = cpl_matrix_get_data(covar);
00071 
00072 
00073     for (i = mfit; i < ma; i++) {
00074         for (j = 0; j <= i; j++) {
00075             _covar[i * nr + j] = _covar[j * nr + i] = 0.0;
00076         }
00077     }
00078 
00079     k = mfit - 1;
00080 
00081     for (j = (ma - 1); j >= 0; j--) {
00082         if (ia[j]) {
00083             for (i = 0; i < ma; i++) {
00084                 _giraffe_swap(&_covar[i * nr + k], &_covar[i * nr + j]);
00085             }
00086 
00087             for (i = 0;i < ma; i++) {
00088                 _giraffe_swap(&_covar[k * nr + i], &_covar[j * nr + i]);
00089             }
00090 
00091             k--;
00092         }
00093     }
00094 
00095 }
00096 
00097 
00098 /*
00099  * @brief
00100  *   LMRQ Chi Square Calculation
00101  *
00102  * @param x          -  X abcissa [ndata]
00103  * @param y          -  Y values [ndata]
00104  * @param sig        -  Y sigmas [ndata]
00105  * @param ndata      -  Number of values
00106  * @param a          -  Initial guesses for model parameters [ma]
00107  * @param r          -  Maximum deltat for modelparameters [ma]
00108  * @param ia         -  Flags for model parameters to be fitted [ma]
00109  * @param ma         -  Number of parameters to fit
00110  * @param alpha      -  Working space [ma,ma]
00111  * @param beta       -  Working space [ma,ma]
00112  * @param chisq      -  Chi Square value of fit
00113  * @param funcs      -  Non linear model to fit
00114  *
00115  * @return =0 if succesful, <0 if error an occured
00116  *
00117  * Used by @c giraffe_mrqmin() to evaluate the linearized fitting
00118  * matrix @a alpha and vector @a beta and calculate chi squared @a chisq.
00119  *
00120  * @see giraffe_mrqmin()
00121  */
00122 
00123 inline static cxint
00124 _giraffe_mrqcof(cpl_matrix  *x, cpl_matrix  *y, cpl_matrix  *sig,
00125                 cxint ndata, cpl_matrix  *a, cxdouble r[], cxint ia[],
00126                 cxint ma, cpl_matrix *alpha, cpl_matrix *beta,
00127                 cxdouble *chisq, GiFitFunc funcs)
00128 {
00129 
00130     register cxint i, j, k, l, m;
00131     register cxint mfit = 0;
00132 
00133     cxint nr_alpha = cpl_matrix_get_nrow(alpha);
00134     cxint nc_x = cpl_matrix_get_ncol(x);
00135 
00136     cxdouble ymod;
00137     cxdouble wt;
00138     cxdouble sig2i;
00139     cxdouble dy;
00140     cxdouble *dyda;
00141     cxdouble *pd_x     = cpl_matrix_get_data(x);
00142     cxdouble *pd_y     = cpl_matrix_get_data(y);
00143     cxdouble *pd_sig   = cpl_matrix_get_data(sig);
00144     cxdouble *pd_a     = cpl_matrix_get_data(a);
00145     cxdouble *pd_alpha = cpl_matrix_get_data(alpha);
00146     cxdouble *pd_beta  = cpl_matrix_get_data(beta);
00147 
00148 
00149     for (j = 0; j < ma; j++) {
00150         if (ia[j]) {
00151             mfit++;
00152         }
00153     }
00154 
00155     for (j = 0; j < mfit; j++) {
00156         for (k = 0; k <= j; k++) {
00157             pd_alpha[j * nr_alpha + k] = 0.0;
00158         }
00159 
00160         pd_beta[j] = 0.0;
00161     }
00162 
00163     *chisq = 0.0;
00164 
00165     dyda = cx_calloc(ma, sizeof(cxdouble));
00166 
00167     for (i = 0; i < ndata; i++) {
00168 
00169         (*funcs)(&ymod, &(pd_x[i * nc_x]), pd_a, ma, dyda, r);
00170 
00171         if (pd_sig[i] == 0.0) {
00172             continue;
00173         }
00174 
00175         sig2i = 1.0 / (pd_sig[i] * pd_sig[i]);
00176         dy = pd_y[i] - ymod;
00177 
00178         for (j = -1, l = 0; l < ma; l++) {
00179 
00180            if (ia[l]) {
00181                 wt = dyda[l] * sig2i;
00182                 for (j++, k = -1, m = 0; m <= l; m++) {
00183                     if (ia[m]) {
00184                         ++k;
00185                         pd_alpha[j * nr_alpha + k] += (wt * dyda[m]);
00186                     }
00187                 }
00188 
00189                 pd_beta[j] += (dy * wt);
00190 
00191             }
00192         }
00193 
00194         *chisq += (dy * dy * sig2i);
00195 
00196     }
00197 
00198     for (j = 1; j < mfit; j++) {
00199         for (k = 0; k < j; k++) {
00200             pd_alpha[k * nr_alpha + j] = pd_alpha[j * nr_alpha + k];
00201         }
00202     }
00203 
00204 
00205     cx_free(dyda);
00206 
00207     return 0;
00208 
00209 }
00210 
00211 
00212 /*
00213  * @brief
00214  *   Levenberg-Marquardt non-linear fit routine
00215  *
00216  * @param x          -  X abcissa [ndata]
00217  * @param y          -  Y values [ndata]
00218  * @param sig        -  Y sigmas [ndata]
00219  * @param ndata      -  Number of values
00220  * @param a          -  Initial guesses for model parameters [ma]
00221  * @param r          -  Maximum delta for model parameters [ma]
00222  * @param ia         -  Flags fot model parameters to be fitted [ma]
00223  * @param ma         -  Number of parameters to fit
00224  * @param covar      -  Covariance matrix [ma,ma]
00225  * @param alpha      -  Working space [ma,ma]
00226  * @param chisq      -  Chi Square of fit
00227  * @param funcs      -  Non linear model to fit
00228  * @param alamda     -  Control parameter of fit
00229  *
00230  * @return  0 if succesful, < 0 if an error occured
00231  *
00232  * Levenberg-Marquardt non linear fit method, based upon attempting to
00233  * reduce the value @em CHISQ of a fit between a set of data points
00234  * @a x[1..ndata], @a y[1..ndata] with individual standard deviations
00235  * @a sig[1..ndata], and a nonlinear function @a funcs dependent on
00236  * @a ma coefficients @a a[1..ma].
00237  * @par Fit Control Parameters:
00238  * The input array @a a[1..ma] contains initial guesses for the parameters
00239  * to be fitted.
00240  * The input array @a ia[1..ma] indicates by nonzero entries those components
00241  * of @a a[1..ma] that should be fitted for, and by zero entries those
00242  * components that should be held fixed at their input values.
00243  *
00244  * The program returns current best-fit values for the parameters @a a[1..ma],
00245  * and @em CHISQ=chisq. The arrays @a covar[1..ma][1..ma] and
00246  * @a alpha[1..ma][1..ma] are used as working space during most iterations.
00247  *
00248  * Supply a routine @a funcs(x,a,yfit,dyda,ma) that evaluates the fitting
00249  * function yfit, and its derivatives @em dyda[1..ma] with respect to the
00250  * fitting parameters @a a at @a x. On the first call provide an initial
00251  * guess for the parameters @a a, and set @a alamda<0  for initialization
00252  * (which then sets @a alamda=.001). If a step succeeds @a chisq becomes
00253  * smaller and @a alamda decreases by a factor of 10. If a step fails
00254  * @a alamda grows by a factor of 10.
00255  *
00256  * You @em must call this routine repeatedly until convergence is achieved.
00257  * Then, make one final call with @a alamda=0, so that @a covar[1..ma][1..ma]
00258  * returns the covariance matrix, and @a alpha[1..ma][1..ma] the
00259  * curvature matrix.
00260  *
00261  * Parameters held fixed will return zero covariances.
00262  *
00263  * @see _giraffe_mrqcof()
00264  *
00265  */
00266 
00267 static cxint
00268 _giraffe_mrqmin(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sig, cxint ndata,
00269                 cpl_matrix *a, cxdouble r[], cxint ia[], cxint ma,
00270                 cpl_matrix *covar, cpl_matrix *alpha, cxdouble *chisq,
00271                 GiFitFunc funcs, cxdouble *alamda)
00272 {
00273 
00274     register cxint gj, j, k, l, m;
00275 
00276     static cxint nr_covar, nr_alpha, nr_moneda, mfit;
00277 
00278     static cxdouble *pd_a, *pd_covar, *pd_alpha;
00279     static cxdouble *atry, *beta, *da, *oneda, ochisq;
00280 
00281     static cpl_matrix *matry, *mbeta, *mda, *moneda;
00282 
00283 
00284     pd_a     = cpl_matrix_get_data(a);
00285     pd_covar = cpl_matrix_get_data(covar);
00286     pd_alpha = cpl_matrix_get_data(alpha);
00287     nr_covar = cpl_matrix_get_nrow(covar);
00288     nr_alpha = cpl_matrix_get_nrow(alpha);
00289 
00290     if (*alamda < 0.0) {
00291 
00292         matry = cpl_matrix_new(ma, 1);
00293         atry  = cpl_matrix_get_data(matry);
00294 
00295         mbeta = cpl_matrix_new(ma, 1);
00296         beta  = cpl_matrix_get_data(mbeta);
00297 
00298         mda = cpl_matrix_new(ma, 1);
00299         da  = cpl_matrix_get_data(mda);
00300 
00301         for (mfit = 0, j = 0; j < ma; j++) {
00302             if (ia[j]) {
00303                 mfit++;
00304             }
00305         }
00306 
00307         moneda = cpl_matrix_new(1, mfit);
00308         oneda  = cpl_matrix_get_data(moneda);
00309 
00310         *alamda = 0.001;
00311 
00312         gj = _giraffe_mrqcof(x, y, sig, ndata, a, r, ia, ma, alpha, mbeta,
00313                              chisq, funcs);
00314 
00315         if (gj != 0) {
00316             cpl_matrix_delete(moneda);
00317             moneda = NULL;
00318             oneda = NULL;
00319 
00320             cpl_matrix_delete(mda);
00321             mda = NULL;
00322             da = NULL;
00323 
00324             cpl_matrix_delete(mbeta);
00325             mbeta = NULL;
00326             beta = NULL;
00327 
00328             cpl_matrix_delete(matry);
00329             matry = NULL;
00330             atry = NULL;
00331 
00332             return gj;
00333         }
00334 
00335         ochisq = (*chisq);
00336 
00337         for (j = 0; j < ma; j++) {
00338             atry[j] = pd_a[j];
00339         }
00340 
00341     }
00342 
00343     nr_moneda = cpl_matrix_get_nrow(moneda);
00344 
00345     for (j = -1, l = 0; l < ma; l++) {
00346         if (ia[l]) {
00347             for (j++, k = -1, m = 0; m < ma; m++) {
00348                 if (ia[m]) {
00349                     k++;
00350                     pd_covar[j * nr_covar + k] = pd_alpha[j * nr_alpha + k];
00351                 }
00352             }
00353 
00354             pd_covar[j * nr_covar + j] = pd_alpha[j * nr_alpha + j] *
00355                 (1.0 + (*alamda));
00356 
00357             oneda[j * nr_moneda + 0] = beta[j];
00358         }
00359     }
00360 
00361     gj = giraffe_gauss_jordan(covar, mfit, moneda, 1);
00362 
00363     if (gj != 0) {
00364         cpl_matrix_delete(moneda);
00365         moneda = NULL;
00366         oneda = NULL;
00367 
00368         cpl_matrix_delete(mda);
00369         mda = NULL;
00370         da = NULL;
00371 
00372         cpl_matrix_delete(mbeta);
00373         mbeta = NULL;
00374         beta = NULL;
00375 
00376         cpl_matrix_delete(matry);
00377         matry = NULL;
00378         atry = NULL;
00379 
00380         return gj;
00381     }
00382 
00383     for (j = 0; j < mfit; j++) {
00384         da[j] = oneda[j * nr_moneda + 0];
00385     }
00386 
00387     if (*alamda == 0.0) {
00388         _giraffe_covsrt(covar, ma, ia, mfit);
00389 
00390         cpl_matrix_delete(moneda);
00391         moneda = NULL;
00392         oneda = NULL;
00393 
00394         cpl_matrix_delete(mda);
00395         mda = NULL;
00396         da = NULL;
00397 
00398         cpl_matrix_delete(mbeta);
00399         mbeta = NULL;
00400         beta = NULL;
00401 
00402         cpl_matrix_delete(matry);
00403         matry = NULL;
00404         atry = NULL;
00405 
00406         return 0;
00407     }
00408 
00409     for (j = -1, l = 0; l < ma; l++) {
00410         if (ia[l]) {
00411             atry[l] = pd_a[l] + da[++j];
00412         }
00413     }
00414 
00415     gj = _giraffe_mrqcof(x, y, sig, ndata, matry, r, ia, ma, covar, mda,
00416                          chisq, funcs);
00417 
00418     if (gj != 0) {
00419         cpl_matrix_delete(moneda);
00420         moneda = NULL;
00421         oneda = NULL;
00422 
00423         cpl_matrix_delete(mda);
00424         mda = NULL;
00425         da = NULL;
00426 
00427         cpl_matrix_delete(mbeta);
00428         mbeta = NULL;
00429         beta = NULL;
00430 
00431         cpl_matrix_delete(matry);
00432         matry = NULL;
00433         atry = NULL;
00434 
00435         return gj;
00436     }
00437 
00438     if (*chisq < ochisq) {
00439 
00440         *alamda *= 0.1;
00441         ochisq = *chisq;
00442 
00443         for (j = -1, l = 0; l < ma; l++) {
00444             if (ia[l]) {
00445                 for (j++, k = -1, m = 0; m < ma; m++) {
00446                     if (ia[m]) {
00447                         k++;
00448                         pd_alpha[j * nr_alpha + k] =
00449                             pd_covar[j * nr_covar + k];
00450                     }
00451                 }
00452 
00453                 beta[j] = da[j];
00454                 pd_a[l] = atry[l];
00455             }
00456         }
00457 
00458     }
00459     else {
00460 
00461         *alamda *= 10.0;
00462         *chisq = ochisq;
00463 
00464     }
00465 
00466     return 0;
00467 
00468 }
00469 
00470 
00495 cxint
00496 giraffe_nlfit(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sigma,
00497               cxint ndata, cpl_matrix *a, cpl_matrix *delta, cxint *ia,
00498               cxint ma, cpl_matrix *alpha, cxdouble *chisq, GiFitFunc funcs,
00499               const GiFitParams *setup)
00500 {
00501 
00502     cxint itst;
00503     cxint n;
00504     cxint res;
00505 
00506     cxdouble alamda = -1.;
00507     cxdouble *r = NULL;
00508 
00509     cpl_matrix *beta = cpl_matrix_new(ma, ma);
00510 
00511 
00512     if (delta) {
00513         r = cpl_matrix_get_data(delta);
00514     }
00515 
00516     res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
00517                           chisq, funcs, &alamda);
00518 
00519     if (res != 0) {
00520         cpl_matrix_delete(beta);
00521         beta = NULL;
00522 
00523         return res;
00524     }
00525 
00526     itst=0;
00527 
00528     for (n = 1; n <= setup->iterations; n++) {
00529 
00530         cxdouble ochisq = *chisq;
00531 
00532         res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
00533                               chisq, funcs, &alamda);
00534 
00535         if (res != 0) {
00536             cpl_matrix_delete(beta);
00537             beta = NULL;
00538 
00539             return res;
00540         }
00541 
00542         if (*chisq > ochisq) {
00543             itst = 0;
00544         }
00545         else if (fabs(ochisq - *chisq) < setup->dchisq) {
00546             itst++;
00547         }
00548 
00549         if (itst > setup->tests) {
00550             break;
00551         }
00552 
00553     }
00554 
00555 
00556     /*
00557      * Get covariance matrix
00558      */
00559 
00560     alamda=0.0;
00561 
00562     res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
00563                           chisq, funcs, &alamda);
00564 
00565     if (res != 0) {
00566         cpl_matrix_delete(beta);
00567         beta = NULL;
00568 
00569         return res;
00570     }
00571 
00572     cpl_matrix_delete(beta);
00573     beta = NULL;
00574 
00575     return n;
00576 
00577 }

This file is part of the GIRAFFE Pipeline Reference Manual 2.9.0.
Documentation copyright © 2002-2006 European Southern Observatory.
Generated on Thu Jan 26 14:20:28 2012 by doxygen 1.6.3 written by Dimitri van Heesch, © 1997-2004