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
41inline 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
54inline 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
115inline 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
259static 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
487cxint
488giraffe_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.17.1.
Documentation copyright © 2002-2006 European Southern Observatory.
Generated on Wed Jun 11 2025 18:00:33 by doxygen 1.9.6 written by Dimitri van Heesch, © 1997-2004