GIRAFFE Pipeline Reference Manual

gilevenberg.c
1 /* $Id$
2  *
3  * This file is part of the GIRAFFE Pipeline
4  * Copyright (C) 2002-2006 European Southern Observatory
5  *
6  * This program is free software; you can redistribute it and/or modify
7  * it under the terms of the GNU General Public License as published by
8  * the Free Software Foundation; either version 2 of the License, or
9  * (at your option) any later version.
10  *
11  * This program is distributed in the hope that it will be useful,
12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14  * GNU General Public License for more details.
15  *
16  * You should have received a copy of the GNU General Public License
17  * along with this program; if not, write to the Free Software
18  * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19  */
20 
21 /*
22  * $Author$
23  * $Date$
24  * $Revision$
25  * $Name$
26  */
27 
28 #ifdef HAVE_CONFIG_H
29 # include <config.h>
30 #endif
31 
32 #include <math.h>
33 
34 #include <cxtypes.h>
35 #include <cxmemory.h>
36 
37 #include "gimath.h"
38 #include "gilevenberg.h"
39 
40 
49 inline static void
50 _giraffe_swap(cxdouble *a, cxdouble *b) {
51 
52  register cxdouble t = *a;
53 
54  *a = *b;
55  *b = t;
56 
57  return;
58 
59 }
60 
61 
62 inline static void
63 _giraffe_covsrt(cpl_matrix *covar, cxint ma, cxint ia[], cxint mfit)
64 {
65 
66  register cxint i, j, k;
67 
68  cxint nr = cpl_matrix_get_nrow(covar);
69 
70  cxdouble *_covar = cpl_matrix_get_data(covar);
71 
72 
73  for (i = mfit; i < ma; i++) {
74  for (j = 0; j <= i; j++) {
75  _covar[i * nr + j] = _covar[j * nr + i] = 0.0;
76  }
77  }
78 
79  k = mfit - 1;
80 
81  for (j = (ma - 1); j >= 0; j--) {
82  if (ia[j]) {
83  for (i = 0; i < ma; i++) {
84  _giraffe_swap(&_covar[i * nr + k], &_covar[i * nr + j]);
85  }
86 
87  for (i = 0;i < ma; i++) {
88  _giraffe_swap(&_covar[k * nr + i], &_covar[j * nr + i]);
89  }
90 
91  k--;
92  }
93  }
94 
95 }
96 
97 
98 /*
99  * @brief
100  * LMRQ Chi Square Calculation
101  *
102  * @param x - X abcissa [ndata]
103  * @param y - Y values [ndata]
104  * @param sig - Y sigmas [ndata]
105  * @param ndata - Number of values
106  * @param a - Initial guesses for model parameters [ma]
107  * @param r - Maximum deltat for modelparameters [ma]
108  * @param ia - Flags for model parameters to be fitted [ma]
109  * @param ma - Number of parameters to fit
110  * @param alpha - Working space [ma,ma]
111  * @param beta - Working space [ma,ma]
112  * @param chisq - Chi Square value of fit
113  * @param funcs - Non linear model to fit
114  *
115  * @return =0 if succesful, <0 if error an occured
116  *
117  * Used by @c giraffe_mrqmin() to evaluate the linearized fitting
118  * matrix @a alpha and vector @a beta and calculate chi squared @a chisq.
119  *
120  * @see giraffe_mrqmin()
121  */
122 
123 inline static cxint
124 _giraffe_mrqcof(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sig,
125  cxint ndata, cpl_matrix *a, cxdouble r[], cxint ia[],
126  cxint ma, cpl_matrix *alpha, cpl_matrix *beta,
127  cxdouble *chisq, GiFitFunc funcs)
128 {
129 
130  register cxint i, j, k, l, m;
131  register cxint mfit = 0;
132 
133  cxint nr_alpha = cpl_matrix_get_nrow(alpha);
134  cxint nc_x = cpl_matrix_get_ncol(x);
135 
136  cxdouble ymod;
137  cxdouble wt;
138  cxdouble sig2i;
139  cxdouble dy;
140  cxdouble *dyda;
141  cxdouble *pd_x = cpl_matrix_get_data(x);
142  cxdouble *pd_y = cpl_matrix_get_data(y);
143  cxdouble *pd_sig = cpl_matrix_get_data(sig);
144  cxdouble *pd_a = cpl_matrix_get_data(a);
145  cxdouble *pd_alpha = cpl_matrix_get_data(alpha);
146  cxdouble *pd_beta = cpl_matrix_get_data(beta);
147 
148 
149  for (j = 0; j < ma; j++) {
150  if (ia[j]) {
151  mfit++;
152  }
153  }
154 
155  for (j = 0; j < mfit; j++) {
156  for (k = 0; k <= j; k++) {
157  pd_alpha[j * nr_alpha + k] = 0.0;
158  }
159 
160  pd_beta[j] = 0.0;
161  }
162 
163  *chisq = 0.0;
164 
165  dyda = cx_calloc(ma, sizeof(cxdouble));
166 
167  for (i = 0; i < ndata; i++) {
168 
169  (*funcs)(&ymod, &(pd_x[i * nc_x]), pd_a, ma, dyda, r);
170 
171  if (pd_sig[i] == 0.0) {
172  continue;
173  }
174 
175  sig2i = 1.0 / (pd_sig[i] * pd_sig[i]);
176  dy = pd_y[i] - ymod;
177 
178  for (j = -1, l = 0; l < ma; l++) {
179 
180  if (ia[l]) {
181  wt = dyda[l] * sig2i;
182  for (j++, k = -1, m = 0; m <= l; m++) {
183  if (ia[m]) {
184  ++k;
185  pd_alpha[j * nr_alpha + k] += (wt * dyda[m]);
186  }
187  }
188 
189  pd_beta[j] += (dy * wt);
190 
191  }
192  }
193 
194  *chisq += (dy * dy * sig2i);
195 
196  }
197 
198  for (j = 1; j < mfit; j++) {
199  for (k = 0; k < j; k++) {
200  pd_alpha[k * nr_alpha + j] = pd_alpha[j * nr_alpha + k];
201  }
202  }
203 
204 
205  cx_free(dyda);
206 
207  return 0;
208 
209 }
210 
211 
212 /*
213  * @brief
214  * Levenberg-Marquardt non-linear fit routine
215  *
216  * @param x - X abcissa [ndata]
217  * @param y - Y values [ndata]
218  * @param sig - Y sigmas [ndata]
219  * @param ndata - Number of values
220  * @param a - Initial guesses for model parameters [ma]
221  * @param r - Maximum delta for model parameters [ma]
222  * @param ia - Flags fot model parameters to be fitted [ma]
223  * @param ma - Number of parameters to fit
224  * @param covar - Covariance matrix [ma,ma]
225  * @param alpha - Working space [ma,ma]
226  * @param chisq - Chi Square of fit
227  * @param funcs - Non linear model to fit
228  * @param alamda - Control parameter of fit
229  *
230  * @return 0 if succesful, < 0 if an error occured
231  *
232  * Levenberg-Marquardt non linear fit method, based upon attempting to
233  * reduce the value @em CHISQ of a fit between a set of data points
234  * @a x[1..ndata], @a y[1..ndata] with individual standard deviations
235  * @a sig[1..ndata], and a nonlinear function @a funcs dependent on
236  * @a ma coefficients @a a[1..ma].
237  * @par Fit Control Parameters:
238  * The input array @a a[1..ma] contains initial guesses for the parameters
239  * to be fitted.
240  * The input array @a ia[1..ma] indicates by nonzero entries those components
241  * of @a a[1..ma] that should be fitted for, and by zero entries those
242  * components that should be held fixed at their input values.
243  *
244  * The program returns current best-fit values for the parameters @a a[1..ma],
245  * and @em CHISQ=chisq. The arrays @a covar[1..ma][1..ma] and
246  * @a alpha[1..ma][1..ma] are used as working space during most iterations.
247  *
248  * Supply a routine @a funcs(x,a,yfit,dyda,ma) that evaluates the fitting
249  * function yfit, and its derivatives @em dyda[1..ma] with respect to the
250  * fitting parameters @a a at @a x. On the first call provide an initial
251  * guess for the parameters @a a, and set @a alamda<0 for initialization
252  * (which then sets @a alamda=.001). If a step succeeds @a chisq becomes
253  * smaller and @a alamda decreases by a factor of 10. If a step fails
254  * @a alamda grows by a factor of 10.
255  *
256  * You @em must call this routine repeatedly until convergence is achieved.
257  * Then, make one final call with @a alamda=0, so that @a covar[1..ma][1..ma]
258  * returns the covariance matrix, and @a alpha[1..ma][1..ma] the
259  * curvature matrix.
260  *
261  * Parameters held fixed will return zero covariances.
262  *
263  * @see _giraffe_mrqcof()
264  *
265  */
266 
267 static cxint
268 _giraffe_mrqmin(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sig, cxint ndata,
269  cpl_matrix *a, cxdouble r[], cxint ia[], cxint ma,
270  cpl_matrix *covar, cpl_matrix *alpha, cxdouble *chisq,
271  GiFitFunc funcs, cxdouble *alamda)
272 {
273 
274  register cxint gj, j, k, l, m;
275 
276  static cxint nr_covar, nr_alpha, nr_moneda, mfit;
277 
278  static cxdouble *pd_a, *pd_covar, *pd_alpha;
279  static cxdouble *atry, *beta, *da, *oneda, ochisq;
280 
281  static cpl_matrix *matry, *mbeta, *mda, *moneda;
282 
283 
284  pd_a = cpl_matrix_get_data(a);
285  pd_covar = cpl_matrix_get_data(covar);
286  pd_alpha = cpl_matrix_get_data(alpha);
287  nr_covar = cpl_matrix_get_nrow(covar);
288  nr_alpha = cpl_matrix_get_nrow(alpha);
289 
290  if (*alamda < 0.0) {
291 
292  matry = cpl_matrix_new(ma, 1);
293  atry = cpl_matrix_get_data(matry);
294 
295  mbeta = cpl_matrix_new(ma, 1);
296  beta = cpl_matrix_get_data(mbeta);
297 
298  mda = cpl_matrix_new(ma, 1);
299  da = cpl_matrix_get_data(mda);
300 
301  for (mfit = 0, j = 0; j < ma; j++) {
302  if (ia[j]) {
303  mfit++;
304  }
305  }
306 
307  moneda = cpl_matrix_new(1, mfit);
308  oneda = cpl_matrix_get_data(moneda);
309 
310  *alamda = 0.001;
311 
312  gj = _giraffe_mrqcof(x, y, sig, ndata, a, r, ia, ma, alpha, mbeta,
313  chisq, funcs);
314 
315  if (gj != 0) {
316  cpl_matrix_delete(moneda);
317  moneda = NULL;
318  oneda = NULL;
319 
320  cpl_matrix_delete(mda);
321  mda = NULL;
322  da = NULL;
323 
324  cpl_matrix_delete(mbeta);
325  mbeta = NULL;
326  beta = NULL;
327 
328  cpl_matrix_delete(matry);
329  matry = NULL;
330  atry = NULL;
331 
332  return gj;
333  }
334 
335  ochisq = (*chisq);
336 
337  for (j = 0; j < ma; j++) {
338  atry[j] = pd_a[j];
339  }
340 
341  }
342 
343  nr_moneda = cpl_matrix_get_nrow(moneda);
344 
345  for (j = -1, l = 0; l < ma; l++) {
346  if (ia[l]) {
347  for (j++, k = -1, m = 0; m < ma; m++) {
348  if (ia[m]) {
349  k++;
350  pd_covar[j * nr_covar + k] = pd_alpha[j * nr_alpha + k];
351  }
352  }
353 
354  pd_covar[j * nr_covar + j] = pd_alpha[j * nr_alpha + j] *
355  (1.0 + (*alamda));
356 
357  oneda[j * nr_moneda + 0] = beta[j];
358  }
359  }
360 
361  gj = giraffe_gauss_jordan(covar, mfit, moneda, 1);
362 
363  if (gj != 0) {
364  cpl_matrix_delete(moneda);
365  moneda = NULL;
366  oneda = NULL;
367 
368  cpl_matrix_delete(mda);
369  mda = NULL;
370  da = NULL;
371 
372  cpl_matrix_delete(mbeta);
373  mbeta = NULL;
374  beta = NULL;
375 
376  cpl_matrix_delete(matry);
377  matry = NULL;
378  atry = NULL;
379 
380  return gj;
381  }
382 
383  for (j = 0; j < mfit; j++) {
384  da[j] = oneda[j * nr_moneda + 0];
385  }
386 
387  if (*alamda == 0.0) {
388  _giraffe_covsrt(covar, ma, ia, mfit);
389 
390  cpl_matrix_delete(moneda);
391  moneda = NULL;
392  oneda = NULL;
393 
394  cpl_matrix_delete(mda);
395  mda = NULL;
396  da = NULL;
397 
398  cpl_matrix_delete(mbeta);
399  mbeta = NULL;
400  beta = NULL;
401 
402  cpl_matrix_delete(matry);
403  matry = NULL;
404  atry = NULL;
405 
406  return 0;
407  }
408 
409  for (j = -1, l = 0; l < ma; l++) {
410  if (ia[l]) {
411  atry[l] = pd_a[l] + da[++j];
412  }
413  }
414 
415  gj = _giraffe_mrqcof(x, y, sig, ndata, matry, r, ia, ma, covar, mda,
416  chisq, funcs);
417 
418  if (gj != 0) {
419  cpl_matrix_delete(moneda);
420  moneda = NULL;
421  oneda = NULL;
422 
423  cpl_matrix_delete(mda);
424  mda = NULL;
425  da = NULL;
426 
427  cpl_matrix_delete(mbeta);
428  mbeta = NULL;
429  beta = NULL;
430 
431  cpl_matrix_delete(matry);
432  matry = NULL;
433  atry = NULL;
434 
435  return gj;
436  }
437 
438  if (*chisq < ochisq) {
439 
440  *alamda *= 0.1;
441  ochisq = *chisq;
442 
443  for (j = -1, l = 0; l < ma; l++) {
444  if (ia[l]) {
445  for (j++, k = -1, m = 0; m < ma; m++) {
446  if (ia[m]) {
447  k++;
448  pd_alpha[j * nr_alpha + k] =
449  pd_covar[j * nr_covar + k];
450  }
451  }
452 
453  beta[j] = da[j];
454  pd_a[l] = atry[l];
455  }
456  }
457 
458  }
459  else {
460 
461  *alamda *= 10.0;
462  *chisq = ochisq;
463 
464  }
465 
466  return 0;
467 
468 }
469 
470 
495 cxint
496 giraffe_nlfit(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sigma,
497  cxint ndata, cpl_matrix *a, cpl_matrix *delta, cxint *ia,
498  cxint ma, cpl_matrix *alpha, cxdouble *chisq, GiFitFunc funcs,
499  const GiFitParams *setup)
500 {
501 
502  cxint itst;
503  cxint n;
504  cxint res;
505 
506  cxdouble alamda = -1.;
507  cxdouble *r = NULL;
508 
509  cpl_matrix *beta = cpl_matrix_new(ma, ma);
510 
511 
512  if (delta) {
513  r = cpl_matrix_get_data(delta);
514  }
515 
516  res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
517  chisq, funcs, &alamda);
518 
519  if (res != 0) {
520  cpl_matrix_delete(beta);
521  beta = NULL;
522 
523  return res;
524  }
525 
526  itst=0;
527 
528  for (n = 1; n <= setup->iterations; n++) {
529 
530  cxdouble ochisq = *chisq;
531 
532  res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
533  chisq, funcs, &alamda);
534 
535  if (res != 0) {
536  cpl_matrix_delete(beta);
537  beta = NULL;
538 
539  return res;
540  }
541 
542  if (*chisq > ochisq) {
543  itst = 0;
544  }
545  else if (fabs(ochisq - *chisq) < setup->dchisq) {
546  itst++;
547  }
548 
549  if (itst > setup->tests) {
550  break;
551  }
552 
553  }
554 
555 
556  /*
557  * Get covariance matrix
558  */
559 
560  alamda=0.0;
561 
562  res = _giraffe_mrqmin(x, y, sigma, ndata, a, r, ia, ma, alpha, beta,
563  chisq, funcs, &alamda);
564 
565  if (res != 0) {
566  cpl_matrix_delete(beta);
567  beta = NULL;
568 
569  return res;
570  }
571 
572  cpl_matrix_delete(beta);
573  beta = NULL;
574 
575  return n;
576 
577 }
cxdouble dchisq
Definition: gilevenberg.h:64
Non-linear fit control parameters.
Definition: gilevenberg.h:47
cxint iterations
Definition: gilevenberg.h:53
cxint giraffe_nlfit(cpl_matrix *x, cpl_matrix *y, cpl_matrix *sigma, cxint ndata, cpl_matrix *a, cpl_matrix *delta, cxint *ia, cxint ma, cpl_matrix *alpha, cxdouble *chisq, GiFitFunc funcs, const GiFitParams *setup)
Levenberg-Marquardt non-linear fit driver.
Definition: gilevenberg.c:496
cxint tests
Definition: gilevenberg.h:59

This file is part of the GIRAFFE Pipeline Reference Manual 2.14.
Documentation copyright © 2002-2006 European Southern Observatory.
Generated on Wed Mar 11 2015 13:19:41 by doxygen 1.8.9.1 written by Dimitri van Heesch, © 1997-2004