GIRAFFE Pipeline Reference Manual

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

This file is part of the GIRAFFE Pipeline Reference Manual 2.16.10.
Documentation copyright © 2002-2006 European Southern Observatory.
Generated on Thu Dec 15 2022 21:18:51 by doxygen 1.9.1 written by Dimitri van Heesch, © 1997-2004