ERIS Pipeline Reference Manual 1.8.15
sc_mpfit.c
Go to the documentation of this file.
1/*
2 * This file is part of the SKYCORR software package.
3 * Copyright (C) 2009-2013 European Southern Observatory
4 *
5 * This programme 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 programme 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 programme. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19
37/*****************************************************************************
38 * INCLUDES *
39 ****************************************************************************/
40
41#include <sc_mpfit.h>
42
43
44/*****************************************************************************
45 * GLOBALS *
46 ****************************************************************************/
47
48/* Definition of global variables */
49
50/* Number of fitting function calls */
51int nfev = 0;
52/* Last modsky call? */
53cpl_boolean lastcall = CPL_FALSE;
54
55
56/*****************************************************************************
57 * CODE *
58 ****************************************************************************/
59
60cpl_error_code sc_mpfit(mp_result *result, cpl_table *scispec,
61 cpl_table *skyspec, cpl_table *fitpar,
62 const cpl_parameterlist *parlist)
63{
128 const cpl_parameter *pp;
129 cpl_table *initfitpar = NULL, *tmpfitpar = NULL;
130 cpl_vector *sinc = NULL;
131 mp_config config = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
132 mp_result tmpresult;
133 scpars fitpars;
134 scvars v;
135 char errtxt[SC_MAXLEN], type[SC_LENLINE+1];
136 int m = 0, nmin = 0, nmax = 0, mode = 0, ncoef = 0, nloop = 0, pos = 0;
137 int imin = 0, rebintype = 0, i = 0, status = 0, j = 0, calls = 0;
138 int niter = 0, k = 0, nfit = 0, ibest = 0;
139 double wtol = 0., norm = 0., dev = 0., orignorm = 0./*, ts = 0., te = 0.*/;
140// double runtime = 0.;
141
142 /* Set fit precision */
143 pp = cpl_parameterlist_find_const(parlist, "ftol");
144 config.ftol = cpl_parameter_get_double(pp);
145 pp = cpl_parameterlist_find_const(parlist, "xtol");
146 config.xtol = cpl_parameter_get_double(pp);
147
148 /* Set maximum number of iterations */
149 config.maxiter = 100;
150
151 /* Get number of parameters */
152 fitpars.n = cpl_table_get_nrow(fitpar);
153
154 /* Allocate memory for scpars structure */
155 if ((int) sc_mpfit_allocmempar(&fitpars, fitpars.n) ==
156 (int) SC_ERROR_ISM) {
157 result->status = -99;
158 return (cpl_error_code)SC_ERROR_ISM;
159 }
160
161 /* Get number of data points */
162 m = cpl_table_get_nrow(scispec);
163
164 /* Set return of fit residuals and parameter errors */
165 if ((int) sc_mpfit_allocmemresult(result, m, fitpars.n) ==
166 (int) SC_ERROR_ISM) {
167 result->status = -99;
168 sc_mpfit_freemempar(&fitpars);
169 return (cpl_error_code)SC_ERROR_ISM;
170 }
171
172 /* Initialise results structure */
173 sc_mpfit_initresult(result, m, fitpars.n);
174
175 /* Get minimum and maximum degree of polynomial and fitting mode for
176 wavegrid correction */
177 pp = cpl_parameterlist_find_const(parlist, "cheby_min");
178 nmin = cpl_parameter_get_int(pp);
179 pp = cpl_parameterlist_find_const(parlist, "cheby_max");
180 nmax = cpl_parameter_get_int(pp);
181 if (nmin > nmax) {
182 mode = 1;
183 }
184
185 /* Allocate memory for temporary results structure if mode = 0 */
186 if (mode == 0) {
187 if ((int) sc_mpfit_allocmemresult(&tmpresult, m, fitpars.n) ==
188 (int) SC_ERROR_ISM) {
189 result->status = -99;
190 sc_mpfit_freemempar(&fitpars);
191 return (cpl_error_code)SC_ERROR_ISM;
192 }
193 }
194
195 /* Count coefficients for wavelength correction in fit parameter table and
196 get maximum number of CMPFIT calls */
197 if (nmax >= 0) {
198 cpl_table_unselect_all(fitpar);
199 cpl_table_or_selected_string(fitpar, "type", CPL_EQUAL_TO, "w");
200 ncoef = cpl_table_count_selected(fitpar);
201 nloop = ncoef;
202 pos = fitpars.n - ncoef - 1;
203 cpl_table_select_all(fitpar);
204 } else {
205 nloop = 1;
206 }
207
208 /* Get minimum iteration number */
209 if (nmin < 1) {
210 imin = 1;
211 } else {
212 imin = nmin;
213 }
214
215 /* Factor for chi^2 tolerance for estimate of polynomial degree */
216 pp = cpl_parameterlist_find_const(parlist, "wtol");
217 wtol = 1. + cpl_parameter_get_double(pp);
218
219 /* Get method for rebinning from parameter list */
220 pp = cpl_parameterlist_find_const(parlist, "rebintype");
221 rebintype = cpl_parameter_get_int(pp);
222
223 /* Pre-calculate damped sinc function for rebinning of data */
224 sinc = cpl_vector_new(1);
225 if (rebintype == 1) {
226 sc_basic_calcsinc(sinc);
227 }
228
229 /* Info message */
230// cpl_msg_debug(cpl_func, "Fitting ...");
231
232 /* Start time measurement */
233// ts = cpl_test_get_walltime();
234
235 /* Prepare science and sky spectrum table for first estimate */
236 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
237
238 /* Optimise initial fit parameters for line groups by considering the
239 mean ratios of the science and sky line peak fluxes for each group */
240 sc_mpfit_modinitpar(fitpar, scispec, skyspec, parlist);
241
242 /* Update science and sky spectrum table */
243 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
244
245 for (i = 0; i < nloop; i++) {
246
247 /* Loop info */
248// if (i == 0) {
249// cpl_msg_debug(cpl_func, "Input wavelength grid (no fit)");
250// } else {
251// cpl_msg_debug(cpl_func, "Chebyshev polynomial of degree %d", i);
252// }
253
254 /* Set errors to SC_DEFERRVAL */
255 cpl_table_fill_column_window(fitpar, "err_fit", 0, fitpars.n,
256 SC_DEFERRVAL);
257 cpl_table_fill_column_window(fitpar, "err_est", 0, fitpars.n,
258 SC_DEFERRVAL);
259
260 /* Use CMPFIT to fit wavelength grid by a Chebyshev polynomial */
261
262 if (ncoef == 0 || i == 0) {
263
264 /* CMPFIT status for no fitting */
265 status = 99;
266
267 /* Calculate orignorm */
268 for (norm = 0., j = 0; j < m; j++) {
269 dev = cpl_table_get(scispec, "dev", j, NULL);
270 norm += dev * dev;
271 }
272 result->orignorm = norm;
273
274 } else {
275
276 /* Set parameter vector and parameter constraints structure */
277 sc_mpfit_setpar(&fitpars, fitpar, 'w');
278
279 /* Pack all data and parameters into temporary structure in order
280 to create a void pointer required by the CMPFIT user
281 function */
282 v.scispec = scispec;
283 v.skyspec = skyspec;
284 v.fitpar = fitpar;
285 v.sinc = sinc;
286 v.parlist = parlist;
287
288 /* Call fitting function for m data points and n parameters */
289 status = mpfit(sc_mpfit_calcdev, m, fitpars.n, fitpars.p,
290 fitpars.pars, &config, (void *) &v, result);
291
292 if (status <= 0) {
293 break;
294 }
295
296 /* Count number of CMPFIT calls and iterations */
297 calls += 1;
298 niter += result->niter;
299
300 /* Write fit values to fit parameter table */
301 cpl_table_copy_data_double(fitpar, "value", fitpars.p);
302
303 /* Write fit errors to fit parameter table */
304 for (k = 0; k < fitpars.n; k++) {
305 sprintf(type, "%s", cpl_table_get_string(fitpar, "type", k));
306 if (type[0] == 'w' &&
307 cpl_table_get_int(fitpar, "fit", k, NULL) == 1) {
308 cpl_table_set(fitpar, "err_fit", k, result->xerror[k]);
309 }
310 }
311
312 /* Update science and sky spectrum table */
313 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
314
315 }
316
317 /* Save orignorm */
318 if (i == 0) {
319 orignorm = result->orignorm;
320 }
321
322 /* Optimise fit parameters for line groups by considering the mean
323 ratios of the science and sky line peak fluxes for each group */
324 sc_mpfit_modinitpar(fitpar, scispec, skyspec, parlist);
325
326 /* Update science and sky spectrum table */
327 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
328
329 /* Get number of free line group fit parameters */
330 cpl_table_unselect_all(fitpar);
331 cpl_table_or_selected_string(fitpar, "type", CPL_NOT_EQUAL_TO, "w");
332 cpl_table_and_selected_int(fitpar, "fit", CPL_EQUAL_TO, 1);
333 nfit = cpl_table_count_selected(fitpar);
334 cpl_table_select_all(fitpar);
335
336 /* Fit uncertain line group parameters if present */
337
338 if (nfit == 0) {
339
340 /* CMPFIT status for no fitting */
341 status = 99;
342
343 /* Calculate bestnorm if no CMPFIT call */
344 for (norm = 0., j = 0; j < m; j++) {
345 dev = cpl_table_get(scispec, "dev", j, NULL);
346 norm += dev * dev;
347 }
348 result->bestnorm = norm;
349
350 } else {
351
352 /* Set parameter vector and parameter constraints structure */
353 sc_mpfit_setpar(&fitpars, fitpar, 'l');
354
355 /* Pack all data and parameters into temporary structure in order
356 to create a void pointer required by the CMPFIT user
357 function */
358 v.scispec = scispec;
359 v.skyspec = skyspec;
360 v.fitpar = fitpar;
361 v.sinc = sinc;
362 v.parlist = parlist;
363
364 /* Save initial fit parameter table */
365 initfitpar = cpl_table_duplicate(fitpar);
366
367 /* Call fitting function for m data points and n parameters */
368 status = mpfit(sc_mpfit_calcdev, m, fitpars.n, fitpars.p,
369 fitpars.pars, &config, (void *) &v, result);
370
371 /* Leave loop in the case of bad mpfit status */
372 if (status <= 0) {
373 cpl_table_delete(initfitpar);
374 break;
375 }
376
377 /* Count number of CMPFIT calls and iterations */
378 calls += 1;
379 niter += result->niter;
380
381 /* Write fit values to fit parameter table */
382 cpl_table_copy_data_double(fitpar, "value", fitpars.p);
383
384 /* Write fit errors to fit parameter table */
385 for (k = 0; k < fitpars.n; k++) {
386 sprintf(type, "%s", cpl_table_get_string(fitpar, "type", k));
387 if (type[0] != 'w' &&
388 cpl_table_get_int(fitpar, "fit", k, NULL) == 1) {
389 cpl_table_set(fitpar, "err_fit", k, result->xerror[k]);
390 }
391 }
392
393 /* Substitute uncertain fit parameters by initial estimates */
394 sc_mpfit_substbadfitpar(fitpar, initfitpar, parlist);
395 cpl_table_delete(initfitpar);
396
397 /* Update science and sky spectrum table */
398 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
399
400 }
401
402 /* Message on chi^2 */
403 cpl_msg_debug(cpl_func, "bestnorm: %.3e", result->bestnorm);
404
405 /* Condition for break of loop */
406
407 if (mode == 0 && ncoef > 0) {
408
409 /* If at least minimum degree is reached and results become worse,
410 stop loop */
411
412 if (i >= imin && result->bestnorm * wtol >= tmpresult.bestnorm) {
413 /* Take best results */
414 if (result->bestnorm >= tmpresult.bestnorm) {
415 sc_mpfit_copyresult(result, &tmpresult);
416 sc_basic_copytable_content(fitpar, tmpfitpar);
417 } else {
418 ibest = i;
419 }
420 break;
421 } else if (i == nloop - 1 &&
422 result->bestnorm < tmpresult.bestnorm) {
423 /* Take results of final degree */
424 ibest = i;
425 }
426
427 } else {
428
429 /* Case for run until maximum degree (no break) */
430
431 if (i == nloop - 1) {
432 ibest = i;
433 }
434
435 }
436
437 /* Store fitting data in temporary structures if mode = 0 */
438 if (mode == 0 && i < nloop - 1) {
439 /* Store only better results than obtained by all previous
440 iterations */
441 if (i == 0 || result->bestnorm < tmpresult.bestnorm) {
442 ibest = i;
443 sc_mpfit_copyresult(&tmpresult, result);
444 cpl_table_delete(tmpfitpar);
445 tmpfitpar = cpl_table_duplicate(fitpar);
446 }
447 }
448
449 /* Set relevance and fit flag = 1 for the next 'w' coefficient in the
450 parameter table */
451 if (i < nloop - 1) {
452 if (i == 0) {
453 /* Set constant term together with linear term */
454 pos++;
455 cpl_table_set(fitpar, "relevance", pos, 1);
456 cpl_table_set(fitpar, "fit", pos, 1);
457 }
458 pos++;
459 cpl_table_set(fitpar, "relevance", pos, 1);
460 if (nmax != 0) {
461 /* No fit of linear term if degree of poynomial is 0 */
462 cpl_table_set(fitpar, "fit", pos, 1);
463 }
464 v.fitpar = fitpar;
465 }
466
467 }
468
469 /* Print resulting degree of polynomial */
470 if (ibest == 0) {
471 cpl_msg_debug(cpl_func, "STOP -> No wavegrid correction");
472 } else {
473 cpl_msg_debug(cpl_func, "STOP -> Take results of degree %d", ibest);
474 }
475
476 /* Recover chi^2 before first fit and set final number of iterations */
477 if (status > 0) {
478 result->orignorm = orignorm;
479 result->niter = niter;
480 }
481
482 /* Get CMPFIT run time in s */
483// te = cpl_test_get_walltime();
484// runtime = te - ts;
485
486 /* Fill CPL table scispec with best-fit modified sky line spectrum and
487 deviations */
488 lastcall = CPL_TRUE;
489 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
490
491// /* Write a summary of the CMPFIT results into an ASCII file */
492// if (status > 0) {
493// sc_mpfit_writeresults(result, scispec, fitpar, parlist, calls,
494// runtime);
495// }
496
497 /* Free memory */
498 if (status > 0 && mode == 0) {
499 sc_mpfit_freememresult(&tmpresult);
500 cpl_table_delete(tmpfitpar);
501 }
502 sc_mpfit_freemempar(&fitpars);
503 cpl_vector_delete(sinc);
504
505 /* Error message if CMPFIT fails */
506 if (status <= 0) {
507 result->status = status;
508 sprintf(errtxt, "%s: mpfit (internal error %d)", SC_ERROR_EIS_TXT,
509 status);
510 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_EIS, "%s", errtxt);
511 }
512
513 return CPL_ERROR_NONE;
514}
515
516
517int sc_mpfit_calcdev(int m, int n, double *p, double *dy, double **dvec,
518 void *vars)
519{
543 scvars *v = (scvars *) vars;
544 cpl_table *scispec, *skyspec, *fitpar;
545 cpl_vector *sinc;
546 const cpl_parameterlist *parlist;
547
548 if (n) {};
549 if (dvec) {};
550
551 /* Update number of fitting function call */
552 nfev++;
553
554 /* Unpack observed spectral data and input parameters */
555 scispec = v->scispec;
556 skyspec = v->skyspec;
557 fitpar = v->fitpar;
558 sinc = v->sinc;
559 parlist = v->parlist;
560
561 /* Put fit parameters in CPL table */
562 cpl_table_copy_data_double(fitpar, "value", p);
563
564 /* Modification of sky spectrum */
565 sc_modsky(scispec, skyspec, fitpar, sinc, parlist);
566
567 /* Fill array of residuals */
568 assert(m == cpl_table_get_nrow(scispec));
569 cpl_table_fill_invalid_double(scispec, "dev", 0.);
570 memcpy(dy, cpl_table_get_data_double_const(scispec, "dev"),
571 cpl_table_get_nrow(scispec) * sizeof(double));
572
573 return CPL_ERROR_NONE;
574}
575
576
577cpl_error_code sc_mpfit_modinitpar(cpl_table *fitpar,
578 cpl_table *scispec,
579 cpl_table *skyspec,
580 const cpl_parameterlist *parlist)
581{
628 /* Parameter list */
629 const cpl_parameter *p;
630 double fwhm = 0., siglim = 0., fitlim = 0.;
631
632 /* Science spectrum */
633 cpl_array *ratio, *tmpratio;
634 cpl_boolean ispeak = CPL_FALSE;
635 int nsci = 0, pix = 0, npeak = 0;
636 double lflux = 0., mlflux = 0., rat = 0., initrat = 0., rms = 0.;
637
638 /* Sky spectrum */
639 char dcolname[SC_LENLINE+1];
640 int nsky = 0, i = 0, io = 0, im = 0;
641
642 /* Fit parameters */
643 cpl_table *tmpfitpar;
644 int row = 0;
645
646 /* Line group type */
647 char grouptype[2] = "AB", ngroupid[SC_LENLINE+1];
648 int h = 0;
649
650 /* Line group systems */
651 cpl_array *corrsyst, *corrfac, *meanratio, *groupsum, *maxrms[2];
652 int nsyst = 0, syst = 0, gsum = 0;
653 double ratsum = 0., fac = 0., meanrat = 0.;
654
655 /* Line groups */
656 cpl_array *gratio, *sgratio;
657 int ngroup[2] = {0, 0}, ming = 0, g = 0;
658 double mrat = 0., msig = 0., omrat = 0.;
659 double nmrat = 0.;
660
661 /* Lines */
662 cpl_array *selpeak;
663 int maxpix = 0, d = 0, nlin = 0, n = 0, k = 0;
664
665 /* Pixels */
666 cpl_array *selpix, *linid;
667 int sum = 0, j = 0, nlinpix = 0, nclippix = 0;
668
669 /* Get number of rows in science and sky spectrum */
670 nsci = cpl_table_get_nrow(scispec);
671 nsky = cpl_table_get_nrow(skyspec);
672
673 /* Ratio of science and sky line flux */
674
675 ratio = cpl_array_new(nsci, CPL_TYPE_DOUBLE);
676
677 for (pix = 0, npeak = 0; pix < nsci; pix++) {
678 if (cpl_table_get(scispec, "class", pix, NULL) >= 1 &&
679 cpl_table_get(scispec, "weight", pix, NULL) > 0. &&
680 cpl_table_get(scispec, "mweight", pix, NULL) > 0.) {
681 /* Line pixel with non-zero weight in science spectrum */
682 lflux = cpl_table_get(scispec, "lflux", pix, NULL);
683 mlflux = cpl_table_get(scispec, "mlflux", pix, NULL);
684 if (mlflux == 0) {
685 rat = 1e6;
686 } else {
687 rat = lflux / mlflux;
688 }
689 cpl_array_set_double(ratio, pix, rat);
690 /* Count line peaks */
691 if (cpl_table_get(scispec, "class", pix, NULL) >= 2) {
692 npeak += 1;
693 }
694 } else {
695 /* Set array element invalid if pixel is not suitable */
696 cpl_array_set_invalid(ratio, pix);
697 }
698 }
699
700 /* Do not modify parameter values in the case of no line peaks */
701 if (npeak == 0) {
702 cpl_array_delete(ratio);
703 return CPL_ERROR_NONE;
704 }
705
706 /* FWHM from parameter list */
707 p = cpl_parameterlist_find_const(parlist, "fwhm");
708 fwhm = cpl_parameter_get_double(p);
709
710 /* Number of pixels within FWHM / 2 */
711 maxpix = (int) floor(fwhm / 2. + 0.5);
712
713 /* Use only line pixels within a distance of FWHM / 2 from peak */
714 for (pix = 0; pix < nsci; pix++) {
715 if (cpl_array_is_valid(ratio, pix) == 1 &&
716 cpl_table_get(scispec, "class", pix, NULL) == 1) {
717 ispeak = CPL_FALSE;
718 for (d = -maxpix; d <= maxpix; d++) {
719 if (pix + d >= 0 && pix + d < nsci &&
720 cpl_table_get(scispec, "class", pix + d, NULL) >= 2 &&
721 cpl_array_is_valid(ratio, pix + d) == 1) {
722 ispeak = CPL_TRUE;
723 break;
724 }
725 }
726 if (ispeak == CPL_FALSE) {
727 cpl_array_set_invalid(ratio, pix);
728 }
729 }
730 }
731
732 /* Save input fit parameter table */
733 tmpfitpar = cpl_table_duplicate(fitpar);
734
735 /* Temporary ratio array for sigma-clipping */
736 tmpratio = cpl_array_duplicate(ratio);
737
738 /* Use line peaks for mean ratio calculation only */
739 for (pix = 0; pix < nsci; pix++) {
740 if (cpl_array_is_valid(tmpratio, pix) == 1 &&
741 cpl_table_get(scispec, "class", pix, NULL) == 1) {
742 cpl_array_set_invalid(tmpratio, pix);
743 }
744 }
745
746 /* Perform sigma-clipping for entire spectrum */
747 sc_basic_clipmean(&initrat, &rms, tmpratio, CPL_FALSE);
748
749 /* Get parameter for sigma limit */
750 p = cpl_parameterlist_find_const(parlist, "siglim");
751 siglim = cpl_parameter_get_double(p);
752
753 /* Set elements of ratio array invalid that show deviations greater than
754 siglim sigma from mean */
755 for (pix = 0; pix < nsci; pix++) {
756 rat = cpl_array_get(ratio, pix, NULL);
757 if (rat < initrat - siglim * rms ||
758 rat > initrat + siglim * rms) {
759 cpl_array_set_invalid(ratio, pix);
760 }
761 }
762
763 /* Initialise flux ratio column with invalid elements */
764 cpl_table_set_column_invalid(skyspec, "frat", 0, nsky);
765
766 /* Get ratio of line flux in science and sky spectrum for valid pixels */
767 for (i = 0; i < nsky; i++) {
768 pix = cpl_table_get(skyspec, "mpix", i, NULL);
769 if (pix >= 0 && pix < nsci && cpl_array_is_valid(ratio, pix) == 1) {
770 rat = cpl_array_get(ratio, pix, NULL);
771 cpl_table_set(skyspec, "frat", i, rat);
772 }
773 }
774
775 /* Create array for system B group correction flag */
776 p = cpl_parameterlist_find_const(parlist, "n_system");
777 nsyst = cpl_parameter_get_int(p);
778 corrsyst = cpl_array_new(nsyst, CPL_TYPE_DOUBLE);
779 cpl_array_fill_window(corrsyst, 0, nsyst, 1);
780
781 /* Create array for correction factors of "0" groups */
782 corrfac = cpl_array_new(nsyst, CPL_TYPE_DOUBLE);
783
784 /* Create system-related array for mean factor and number of reliable
785 A groups */
786 meanratio = cpl_array_new(nsyst + 1, CPL_TYPE_DOUBLE);
787 cpl_array_fill_window(meanratio, 0, nsyst + 1, 0.);
788 groupsum = cpl_array_new(nsyst + 1, CPL_TYPE_INT);
789 cpl_array_fill_window(groupsum, 0, nsyst + 1, 0);
790
791 /* Get parameter for relative RMS limit for setup of fit parameters */
792 p = cpl_parameterlist_find_const(parlist, "fitlim");
793 fitlim = cpl_parameter_get_double(p);
794
795 /* Get numbers of dominating A and B groups for each pixel in sky
796 spectrum */
797
798 for (h = 0; h < 2; h++) {
799
800 /* Get number of A or B groups */
801 sprintf(ngroupid, "n_group%c", grouptype[h]);
802 p = cpl_parameterlist_find_const(parlist, ngroupid);
803 ngroup[h] = cpl_parameter_get_int(p);
804
805 /* No data -> skip group type */
806 if (ngroup[h] == 0) {
807 continue;
808 }
809
810 /* Build name for column of dominating group IDs */
811 sprintf(dcolname, "dg%c", grouptype[h]);
812
813 /* Get minimum group number */
814 if (h == 1) {
815 /* n_system negative B group numbers */
816 p = cpl_parameterlist_find_const(parlist, "n_system");
817 ming = -cpl_parameter_get_int(p);
818 } else {
819 ming = 0;
820 }
821
822 /* Create array for maximum RMS of A or B group systems */
823 maxrms[h] = cpl_array_new(nsyst, CPL_TYPE_DOUBLE);
824 cpl_array_fill_window(maxrms[h], 0, nsyst, 0.);
825
826 /* Get mean flux ratio for each group */
827
828 for (g = ming; g <= ngroup[h]; g++) {
829 int * pig;
830 /* Get pixel numbers of group pixels and line peaks */
831 cpl_table_unselect_all(skyspec);
832 cpl_table_or_selected_int(skyspec, dcolname, CPL_EQUAL_TO, g);
833 cpl_table_and_selected_double(skyspec, "frat", CPL_NOT_EQUAL_TO,
834 HUGE_VAL);
835 selpix = cpl_table_where_selected(skyspec);
836 cpl_table_and_selected_int(skyspec, "class",
837 CPL_NOT_LESS_THAN, 2);
838 selpeak = cpl_table_where_selected(skyspec);
839 cpl_table_select_all(skyspec);
840
841 /* Get number of group pixels and lines */
842 sum = cpl_array_get_size(selpix);
843 nlin = cpl_array_get_size(selpeak);
844
845 /* Get mean flux ratio */
846
847 if (nlin == 0) {
848
849 /* No correction for groups without suitable lines */
850 mrat = 1.;
851 msig = SC_DEFERRVAL;
852 n = 0;
853
854 } else {
855
856 /* Assign selected pixels to lines (IDs: increasing numbers
857 from 1 to N_lin) */
858 linid = cpl_array_new(sum, CPL_TYPE_INT);
859 io = cpl_array_get(selpeak, 0, NULL);
860 for (j = 0, k = 1; k <= nlin; k++) {
861 if (k == nlin) {
862 im = nsky;
863 } else {
864 i = cpl_array_get(selpeak, k, NULL);
865 im = (int) ceil(0.5 * (io + i));
866 }
867 while (j < sum) {
868 if (cpl_array_get(selpix, j, NULL) < im) {
869 cpl_array_set(linid, j, k);
870 } else {
871 break;
872 }
873 j++;
874 }
875 io = i;
876 }
877
878 /* Create flux ratio array for line group */
879 gratio = cpl_array_new(sum, CPL_TYPE_DOUBLE);
880 for (j = 0; j < sum; j++) {
881 i = cpl_array_get(selpix, j, NULL);
882 cpl_array_set(gratio, j,
883 cpl_table_get(skyspec, "frat", i, NULL));
884 }
885
886 /* Save flux ratio array */
887 sgratio = cpl_array_duplicate(gratio);
888
889 /* Sigma-clipping procedure for N_pixel >= 3 */
890 if (sum >= 3) {
891 sc_basic_clipmean(&mrat, &msig, gratio, CPL_FALSE);
892 }
893
894 /* Correct clipping of pixels for each line */
895
896 for (n = 0, k = 0; k < nlin; k++) {
897
898 /* Count valid and clipped line pixels */
899 for (nlinpix = 0, nclippix = 0, j = 0; j < sum; j++) {
900 if (cpl_array_get(linid, j, NULL) == k + 1) {
901 if (cpl_array_is_valid(gratio, j) == 1) {
902 nlinpix++;
903 } else {
904 nclippix++;
905 }
906 }
907 }
908
909 /* Avoid complete clipping of one line if only two lines
910 are available */
911 if (nlin == 2 && nlinpix == 0) {
912 for (j = 0; j < sum; j++) {
913 if (cpl_array_get(linid, j, NULL) == k + 1 &&
914 cpl_array_is_valid(gratio, j) != 1) {
915 cpl_array_set(gratio, j,
916 cpl_array_get(sgratio, j,
917 NULL));
918 nlinpix++;
919 nclippix--;
920 }
921 }
922 }
923
924 /* Clip complete line if clipped pixels of a line
925 outnumber valid pixels by a factor of 2 and more */
926 if (nclippix > 2 * nlinpix) {
927 for (nlinpix = 0, j = 0; j < sum; j++) {
928 if (cpl_array_get(linid, j, NULL) == k + 1 &&
929 cpl_array_is_valid(gratio, j) == 1) {
930 cpl_array_set_invalid(gratio, j);
931 nlinpix--;
932 nclippix++;
933 }
934 }
935 }
936
937 /* Count number of unclipped lines of a group */
938 if (nlinpix > 0) {
939 n++;
940 }
941
942 }
943
944 /* Get group-specific mean and RMS */
945 if (sum == 1) {
946 mrat = cpl_array_get(gratio, 0, NULL);
947 msig = 0;
948 } else {
949 mrat = cpl_array_get_mean(gratio);
950 msig = cpl_array_get_stdev(gratio);
951 }
952
953 /* Consider unclipped line pixels for RMS calculation */
954 for (j = 0; j < sum; j++) {
955 if (cpl_array_is_valid(gratio, j) == 1) {
956 i = cpl_array_get(selpix, j, NULL);
957 pix = cpl_table_get(skyspec, "mpix", i, NULL);
958 if (h == 0 && g > 0 && pix >= 0 && pix < nsci) {
959 cpl_table_set(scispec, "sigclip", pix, 0);
960 }
961 }
962 }
963
964 /* Delete temporary array */
965 cpl_array_delete(linid);
966 cpl_array_delete(sgratio);
967 cpl_array_delete(gratio);
968
969 /* Make sure that ratio is not beyond limits */
970 if (mrat < SC_CORRFAC_MIN || mrat > SC_CORRFAC_MAX) {
971 mrat = 1.;
972 }
973
974 }
975
976 /* Delete temporary array */
977 cpl_array_delete(selpix);
978 cpl_array_delete(selpeak);
979
980 /* Divide flux ratios by derived group-specific mean ratios */
981 pig = cpl_table_get_data_int(skyspec, dcolname);
982 for (i = 0; i < nsky; i++) {
983 if (pig[i] == g && cpl_table_is_valid(skyspec, dcolname, i) &&
984 cpl_table_is_valid(skyspec, "frat", i)) {
985 rat = cpl_table_get(skyspec, "frat", i, NULL);
986 cpl_table_set(skyspec, "frat", i, rat / mrat);
987 }
988 }
989
990 /* Row in fit parameter list */
991 if (h == 0) {
992 row = g - 1;
993 } else if (h == 1) {
994 row = ngroup[0] + g - 1;
995 }
996
997 /* Set system correction flag to 0 (no correction) if a B group
998 of a system cannot be fitted */
999 if (h == 1 && g > 0 && nlin == 0) {
1000 syst = cpl_table_get(fitpar, "system", row, NULL);
1001 if (syst > 0) {
1002 cpl_array_set(corrsyst, syst-1, 0);
1003 }
1004 }
1005
1006 /* Get maximum RMS for all A or B groups of a system */
1007 if (g > 0 && n >= 2) {
1008 syst = cpl_table_get(fitpar, "system", row, NULL);
1009 if (syst > 0) {
1010 if (rms > cpl_array_get(maxrms[h], syst-1, NULL)) {
1011 cpl_array_set(maxrms[h], syst-1, rms);
1012 }
1013 }
1014 }
1015
1016 if (g > 0) {
1017 /* Set initial correction factor for group fluxes */
1018 cpl_table_set(fitpar, "value", row, mrat);
1019 /* Put RMS in estimate error column */
1020 cpl_table_set(fitpar, "err_est", row, msig);
1021 /* Put number of valid lines in N_lin column */
1022 cpl_table_set(fitpar, "N_lin", row, n);
1023 } else if (g < 0) {
1024 /* Save correction factors for "0" groups */
1025 cpl_array_set(corrfac, -g-1, mrat);
1026 }
1027
1028 }
1029
1030 }
1031
1032 /* Set RMS of groups with only one valid line to maximum of the system */
1033 for (row = 0; row < ngroup[0] + ngroup[1]; row++) {
1034 syst = cpl_table_get(fitpar, "system", row, NULL);
1035 n = cpl_table_get(fitpar, "N_lin", row, NULL);
1036 if (row >= ngroup[0]) {
1037 h = 1;
1038 } else {
1039 h = 0;
1040 }
1041 if (syst > 0 && n == 1) {
1042 cpl_table_set(fitpar, "err_est", row,
1043 cpl_array_get(maxrms[h], syst-1, NULL));
1044 }
1045 }
1046
1047 /* No correction of B groups of systems with correction flag = 0 */
1048 for (row = ngroup[0]; row < ngroup[0] + ngroup[1]; row++) {
1049 syst = cpl_table_get(fitpar, "system", row, NULL);
1050 if (syst > 0 && cpl_array_get(corrsyst, syst-1, NULL) == 0) {
1051 cpl_table_set(fitpar, "value", row, 1.);
1052 cpl_table_set(fitpar, "err_est", row, SC_DEFERRVAL);
1053 }
1054 }
1055
1056 /* Modify flux correction factors in order to get a B group factor of 1
1057 for the "0" group lines that do not belong to a B group */
1058 for (row = 0; row < ngroup[0] + ngroup[1]; row++) {
1059 syst = cpl_table_get(fitpar, "system", row, NULL);
1060 if (syst == 0) {
1061 continue;
1062 }
1063 mrat = cpl_table_get(fitpar, "value", row, NULL);
1064 msig = cpl_table_get(fitpar, "err_est", row, NULL);
1065 fac = cpl_array_get(corrfac, syst-1, NULL);
1066 if (fac != 0 && msig != SC_DEFERRVAL &&
1067 cpl_array_get(corrsyst, syst-1, NULL) != 0) {
1068 if (row < ngroup[0]) {
1069 cpl_table_set(fitpar, "value", row, mrat * fac);
1070 cpl_table_set(fitpar, "err_est", row, msig * fac);
1071 } else {
1072 cpl_table_set(fitpar, "value", row, mrat / fac);
1073 cpl_table_set(fitpar, "err_est", row, msig / fac);
1074 }
1075 }
1076 }
1077
1078 /* Convert relative correction factors into absolute ones */
1079 for (row = 0; row < ngroup[0] + ngroup[1]; row++) {
1080 n = cpl_table_get(fitpar, "N_lin", row, NULL);
1081 if (n > 0) {
1082 omrat = cpl_table_get(tmpfitpar, "value", row, NULL);
1083 mrat = cpl_table_get(fitpar, "value", row, NULL);
1084 nmrat = omrat * mrat;
1085 if (nmrat < SC_CORRFAC_MIN) {
1086 nmrat = SC_CORRFAC_MIN;
1087 } else if (nmrat > SC_CORRFAC_MAX) {
1088 nmrat = SC_CORRFAC_MAX;
1089 }
1090 cpl_table_set(fitpar, "value", row, nmrat);
1091 msig = cpl_table_get(fitpar, "err_est", row, NULL);
1092 if (msig != SC_DEFERRVAL) {
1093 cpl_table_set(fitpar, "err_est", row, omrat * msig);
1094 }
1095 }
1096 }
1097
1098 /* Calculate mean value of A groups of a system (only consider groups with
1099 at least SC_MINNLIN lines) */
1100 for (row = 0; row < ngroup[0]; row++) {
1101 n = cpl_table_get(fitpar, "N_lin", row, NULL);
1102 if (n >= SC_MINNLIN) {
1103 syst = cpl_table_get(fitpar, "system", row, NULL);
1104 mrat = cpl_table_get(fitpar, "value", row, NULL);
1105 if (syst > 0) {
1106 ratsum = cpl_array_get(meanratio, syst, NULL) + mrat;
1107 cpl_array_set(meanratio, syst, ratsum);
1108 gsum = cpl_array_get(groupsum, syst, NULL) + 1;
1109 cpl_array_set(groupsum, syst, gsum);
1110 }
1111 /* Take mean of all suitable group factors for system = 0 */
1112 ratsum = cpl_array_get(meanratio, 0, NULL) + mrat;
1113 cpl_array_set(meanratio, 0, ratsum);
1114 gsum = cpl_array_get(groupsum, 0, NULL) + 1;
1115 cpl_array_set(groupsum, 0, gsum);
1116 }
1117 }
1118
1119 /* Get mean ratio for A groups of a system */
1120 cpl_array_divide(meanratio, groupsum);
1121
1122 /* For A groups without a valid line take mean factor of the system */
1123 for (row = 0; row < ngroup[0]; row++) {
1124 n = cpl_table_get(fitpar, "N_lin", row, NULL);
1125 if (n == 0) {
1126 syst = cpl_table_get(fitpar, "system", row, NULL);
1127 if (cpl_array_is_valid(meanratio, syst) != 1) {
1128 /* Take global ratio if no system-specific mean */
1129 syst = 0;
1130 }
1131 if (cpl_array_is_valid(meanratio, syst) != 1) {
1132 /* Take initial ratio if no global mean */
1133 cpl_table_set(fitpar, "value", row, 1.);
1134 } else {
1135 cpl_table_set(fitpar, "value", row,
1136 cpl_array_get(meanratio, syst, NULL));
1137 }
1138 }
1139 }
1140
1141 /* No correction of a system A group with less than SC_MINNLIN lines if
1142 deviation of scaling factor from system mean is greater than allowed by
1143 SC_MAXRELFAC */
1144 for (row = 0; row < ngroup[0]; row++) {
1145 n = cpl_table_get(fitpar, "N_lin", row, NULL);
1146 syst = cpl_table_get(fitpar, "system", row, NULL);
1147 if (n > 0 && n < SC_MINNLIN && syst > 0 &&
1148 cpl_array_is_valid(meanratio, syst) == 1) {
1149 mrat = cpl_table_get(fitpar, "value", row, NULL);
1150 meanrat = cpl_array_get(meanratio, syst, NULL);
1151 if (meanrat == 0 || mrat / meanrat < 1. / SC_MAXRELFAC ||
1152 mrat / meanrat > SC_MAXRELFAC) {
1153 cpl_table_set(fitpar, "value", row, meanrat);
1154 cpl_table_set(fitpar, "err_est", row, SC_DEFERRVAL);
1155 }
1156 }
1157 }
1158
1159 /* Set group fit flag to 0 if rel. RMS < fitlim and/or no line peaks can
1160 be fitted */
1161 for (row = 0; row < ngroup[0] + ngroup[1]; row++) {
1162 mrat = cpl_table_get(fitpar, "value", row, NULL);
1163 msig = cpl_table_get(fitpar, "err_est", row, NULL);
1164 if (mrat == 0 || msig == SC_DEFERRVAL || msig / mrat < fitlim) {
1165 cpl_table_set(fitpar, "fit", row, 0);
1166 } else {
1167 cpl_table_set(fitpar, "fit", row, 1);
1168 }
1169 }
1170
1171 /* Free memory */
1172 cpl_array_delete(tmpratio);
1173 cpl_array_delete(ratio);
1174 cpl_array_delete(corrsyst);
1175 cpl_array_delete(corrfac);
1176 cpl_array_delete(meanratio);
1177 cpl_array_delete(groupsum);
1178 cpl_array_delete(maxrms[0]);
1179 cpl_array_delete(maxrms[1]);
1180 cpl_table_delete(tmpfitpar);
1181
1182 return CPL_ERROR_NONE;
1183}
1184
1185
1186cpl_error_code sc_mpfit_setpar(scpars *fitpars, const cpl_table *fitpar,
1187 const char fittype)
1188{
1208 char errtxt[SC_MAXLEN], name[SC_LENLINE+1], type[SC_LENLINE+1];
1209 int npar = 0, i = 0, fit = 0;
1210
1211 /* Get and check number of parameters */
1212 npar = cpl_table_get_nrow(fitpar);
1213 if (fitpars->n != npar) {
1214 sprintf(errtxt, "%s: # of parameters: "
1215 "scpars *fitpars != cpl_table *fitpar", SC_ERROR_IDG_TXT);
1216 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_IDG, "%s", errtxt);
1217 }
1218
1219 /* Set parameter values and constraints for fitting */
1220
1221 for (i = 0; i < npar; i++) {
1222 /* Type of parameter */
1223 sprintf(type, "%s", cpl_table_get_string(fitpar, "type", i));
1224 /* Parameter value */
1225 fitpars->p[i] = cpl_table_get(fitpar, "value", i, NULL);
1226 /* Fit flag */
1227 fit = cpl_table_get(fitpar, "fit", i, NULL);
1228 /* Parameter limits (0 -> no limits) and relative steps */
1229 if (type[0] == 'w') {
1230 /* Coefficients for wavelength correction */
1231 if (fittype == 'w') {
1232 fitpars->pars[i].fixed = 1 - fit;
1233 } else {
1234 fitpars->pars[i].fixed = 1;
1235 }
1236 fitpars->pars[i].limited[0] = 0;
1237 fitpars->pars[i].limited[1] = 0;
1238 fitpars->pars[i].limits[0] = 0.;
1239 fitpars->pars[i].limits[1] = 0.;
1240 fitpars->pars[i].relstep = 0.01;
1241 } else {
1242 /* Line group flux correction factors */
1243 if (fittype == 'l') {
1244 fitpars->pars[i].fixed = 1 - fit;
1245 } else {
1246 fitpars->pars[i].fixed = 1;
1247 }
1248 fitpars->pars[i].limited[0] = 1;
1249 fitpars->pars[i].limited[1] = 1;
1250 fitpars->pars[i].limits[0] = SC_CORRFAC_MIN - SC_TOL;
1251 fitpars->pars[i].limits[1] = SC_CORRFAC_MAX + SC_TOL;
1252 fitpars->pars[i].relstep = 0.01;
1253 }
1254 /* Parameter label */
1255 sprintf(name, "%c%d", type[0],
1256 cpl_table_get_int(fitpar, "N", i, NULL));
1257 strcpy(fitpars->pars[i].parname, name);
1258 }
1259
1260 return CPL_ERROR_NONE;
1261}
1262
1263
1264cpl_error_code sc_mpfit_allocmempar(scpars *fitpars, const int npar)
1265{
1279 cpl_boolean fl_mem = CPL_TRUE;
1280 char errtxt[SC_MAXLEN];
1281 int it = 0, i = 0, nchar = SC_LENLINE+1;
1282
1283 /* Number of fit parameters */
1284 fitpars->n = npar;
1285
1286 /* Allocate memory for parameter vector */
1287 fitpars->p = (double *) calloc(fitpars->n, sizeof(double));
1288 if (fitpars->p == NULL) {
1289 fitpars->n = 0;
1290 sprintf(errtxt, "%s: scpars *fitpars", SC_ERROR_ISM_TXT);
1291 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISM, "%s", errtxt);
1292 }
1293
1294 /* Allocate memory for parameter constraints structure */
1295 fitpars->pars = (mp_par *) calloc(fitpars->n, sizeof(mp_par));
1296 if (fitpars->pars == NULL) {
1297 fitpars->n = 0;
1298 free(fitpars->p);
1299 fitpars->p = NULL;
1300 sprintf(errtxt, "%s: scpars *fitpars", SC_ERROR_ISM_TXT);
1301 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISM, "%s", errtxt);
1302 }
1303
1304 /* Allocate memory for parameter names in parameter constraints
1305 structure */
1306 for (it = 0; it < 2; it++) {
1307 for (i = 0; i < fitpars->n; i++) {
1308 fitpars->pars[i].parname = (char *) calloc(nchar, sizeof(char));
1309 if (it == 0 && fitpars->pars[i].parname == NULL) {
1310 nchar = 0;
1311 fl_mem = CPL_FALSE;
1312 continue;
1313 }
1314 }
1315 if (it == 0 && fl_mem == CPL_TRUE) {
1316 break;
1317 } else if (it == 1 && fl_mem == CPL_FALSE) {
1318 fitpars->n = 0;
1319 free(fitpars->p);
1320 fitpars->p = NULL;
1321 free(fitpars->pars);
1322 fitpars->pars = NULL;
1323 sprintf(errtxt, "%s: scpars *fitpars", SC_ERROR_ISM_TXT);
1324 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISM, "%s",
1325 errtxt);
1326 }
1327 }
1328
1329 return CPL_ERROR_NONE;
1330}
1331
1332
1333cpl_error_code sc_mpfit_freemempar(scpars *fitpars)
1334{
1348 int i;
1349
1350 /* Free memory occupied by parameter vector */
1351 if (fitpars->p != NULL) {
1352 free(fitpars->p);
1353 fitpars->p = NULL;
1354 }
1355
1356 /* Free memory occupied by parameter constraints structure */
1357 if (fitpars->pars != NULL) {
1358 for (i = 0; i < fitpars->n; i++) {
1359 free(fitpars->pars[i].parname);
1360 fitpars->pars[i].parname = NULL;
1361 }
1362 free(fitpars->pars);
1363 fitpars->pars = NULL;
1364 }
1365
1366 /* Set number of parameters to 0 */
1367 fitpars->n = 0;
1368
1369 return CPL_ERROR_NONE;
1370}
1371
1372
1373cpl_error_code sc_mpfit_allocmemresult(mp_result *result, const int m,
1374 const int n)
1375{
1392 char errtxt[SC_MAXLEN];
1393
1394 /* No consideration of the covariance matrix */
1395 result->covar = NULL;
1396
1397 /* Memory allocation for fit residuals */
1398 result->resid = (double *) calloc(m, sizeof(double));
1399 if (result->resid == NULL) {
1400 result->status = -99;
1401 result->xerror = NULL;
1402 sprintf(errtxt, "%s: mp_result *result", SC_ERROR_ISM_TXT);
1403 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISM, "%s", errtxt);
1404 }
1405
1406 /* Memory allocation for parameter errors */
1407 result->xerror = (double *) calloc(n, sizeof(double));
1408 if (result->xerror == NULL) {
1409 result->status = -99;
1410 free(result->resid);
1411 result->resid = NULL;
1412 sprintf(errtxt, "%s: mp_result *result", SC_ERROR_ISM_TXT);
1413 return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISM, "%s", errtxt);
1414 }
1415
1416 return CPL_ERROR_NONE;
1417}
1418
1419
1420cpl_error_code sc_mpfit_initresult(mp_result *result, const int m,
1421 const int n)
1422{
1438 int i = 0, j = 0;
1439
1440 /* Set default values */
1441 result->bestnorm = HUGE_VAL;
1442 result->orignorm = HUGE_VAL;
1443 result->niter = 0;
1444 result->nfev = 0;
1445 result->status = 99;
1446 result->npar = n;
1447 result->nfree = 0;
1448 result->npegged = 0;
1449 result->nfunc = m;
1450 for (i = 0; i < result->nfunc; i++) {
1451 result->resid[i] = 0;
1452 }
1453 for (j = 0; j < result->npar; j++) {
1454 result->xerror[j] = 0;
1455 }
1456
1457 return CPL_ERROR_NONE;
1458}
1459
1460
1461cpl_error_code sc_mpfit_copyresult(mp_result *outresult,
1462 const mp_result *inresult)
1463{
1477 int i = 0, j = 0;
1478
1479 /* Copy data */
1480 outresult->bestnorm = inresult->bestnorm;
1481 outresult->orignorm = inresult->orignorm;
1482 outresult->niter = inresult->niter;
1483 outresult->nfev = inresult->nfev;
1484 outresult->status = inresult->status;
1485 outresult->npar = inresult->npar;
1486 outresult->nfree = inresult->nfree;
1487 outresult->npegged = inresult->npegged;
1488 outresult->nfunc = inresult->nfunc;
1489 for (i = 0; i < outresult->nfunc; i++) {
1490 outresult->resid[i] = inresult->resid[i];
1491 }
1492 for (j = 0; j < outresult->npar; j++) {
1493 outresult->xerror[j] = inresult->xerror[j];
1494 }
1495 outresult->covar = inresult->covar;
1496 strcpy(outresult->version, inresult->version);
1497
1498 return CPL_ERROR_NONE;
1499}
1500
1501
1502cpl_error_code sc_mpfit_freememresult(mp_result *result)
1503{
1521 /* Free memory for residuals */
1522 if (result->resid != NULL) {
1523 free(result->resid);
1524 result->resid = NULL;
1525 }
1526
1527 /* Free memory for parameter errors */
1528 if (result->xerror != NULL) {
1529 free(result->xerror);
1530 result->xerror = NULL;
1531 }
1532
1533 return CPL_ERROR_NONE;
1534}
1535
1536
1537cpl_error_code sc_mpfit_substbadfitpar(cpl_table *fitpar,
1538 const cpl_table *initfitpar,
1539 const cpl_parameterlist *parlist)
1540{
1563 const cpl_parameter *p;
1564 cpl_array *minrat;
1565 int ngroupa = 0, ngroupb = 0, ngroup = 0, i = 0, syst = 0;
1566 double val = 0., err = 0., rat = 0.;
1567
1568 /* Get number of line groups */
1569 p = cpl_parameterlist_find_const(parlist, "n_groupA");
1570 ngroupa = cpl_parameter_get_int(p);
1571 p = cpl_parameterlist_find_const(parlist, "n_groupB");
1572 ngroupb = cpl_parameter_get_int(p);
1573 ngroup = ngroupa + ngroupb;
1574
1575 /* Create array for minimum errors of systems and initialise it */
1576 p = cpl_parameterlist_find_const(parlist, "n_system");
1577 minrat = cpl_array_new(cpl_parameter_get_int(p), CPL_TYPE_DOUBLE);
1578 cpl_array_fill_window(minrat, 0, cpl_parameter_get_int(p), HUGE_VAL);
1579
1580 /* Find bad A group parameter fits and substitute them by initial
1581 estimate */
1582
1583 for (i = 0; i < ngroupa; i++) {
1584
1585 if (cpl_table_get(fitpar, "fit", i, NULL) == 1) {
1586
1587 /* Derive ratio of error and flux */
1588 val = cpl_table_get(fitpar, "value", i, NULL);
1589 err = cpl_table_get(fitpar, "err_fit", i, NULL);
1590 if (val <= 0) {
1591 rat = HUGE_VAL;
1592 } else {
1593 rat = err / val;
1594 }
1595
1596 /* Identify bad parameters and modify parameter values and
1597 errors */
1598 if (rat > SC_MAXPARERR && err != SC_DEFERRVAL) {
1599 cpl_table_set(fitpar, "value", i,
1600 cpl_table_get(initfitpar, "value", i, NULL));
1601 cpl_table_set(fitpar, "err_fit", i, SC_DEFERRVAL);
1602 }
1603
1604 /* Find minimum ratio for each group system */
1605 syst = cpl_table_get(fitpar, "system", i, NULL);
1606 if (syst > 0 && rat < cpl_array_get(minrat, syst - 1, NULL)) {
1607 cpl_array_set(minrat, syst - 1, rat);
1608 }
1609
1610 }
1611
1612 }
1613
1614 /* Substitute B group parameter fits if the minimum ratio of a system is
1615 higher than SC_MAXPARERR */
1616
1617 for (i = ngroupa; i < ngroup; i++) {
1618
1619 if (cpl_table_get(fitpar, "fit", i, NULL) == 1) {
1620
1621 /* Identify parameters of bad systems and modify parameter values
1622 and errors */
1623 syst = cpl_table_get(fitpar, "system", i, NULL);
1624 if (syst > 0 &&
1625 cpl_array_get(minrat, syst - 1, NULL) > SC_MAXPARERR) {
1626 cpl_table_set(fitpar, "value", i,
1627 cpl_table_get(initfitpar, "value", i, NULL));
1628 cpl_table_set(fitpar, "err_fit", i, SC_DEFERRVAL);
1629 }
1630
1631 }
1632
1633 }
1634
1635 /* Free memory */
1636 cpl_array_delete(minrat);
1637
1638 return CPL_ERROR_NONE;
1639}
1640
1641
1642//cpl_error_code sc_mpfit_writeresults(const mp_result *result,
1643// const cpl_table *scispec,
1644// const cpl_table *fitpar,
1645// const cpl_parameterlist *parlist,
1646// const int calls, const double runtime)
1647//{
1648// /*!
1649// * Writes a summary of the CMPFIT results into an ASCII file.
1650// *
1651// * \b INPUT:
1652// * \param result CMPFIT structure for fit results
1653// * \param scispec CPL table with science and best-fit sky spectrum
1654// * \param fitpar CPL table with best fit parameters
1655// * \param parlist general CPL parameter list
1656// * \param calls number of CMPFIT calls
1657// * \param runtime fit run time
1658// *
1659// * \b OUTPUT:
1660// * - none
1661// *
1662// * \b ERRORS:
1663// * - File opening failed
1664// * - Insufficient data points
1665// * - Invalid object value(s)
1666// */
1667
1668// FILE *stream;
1669// cpl_error_code err = CPL_ERROR_NONE;
1670// const cpl_parameter *p;
1671// cpl_table *tmpspec;
1672// cpl_array *ratio;
1673// char basedir[SC_MAXLEN], output_dir[SC_MAXLEN];
1674// char output_name[SC_MAXLEN], outfile[3*SC_MAXLEN];
1675// char errtxt[3*SC_MAXLEN+50], type[SC_LENLINE+1];
1676// int npix = 0, i = 0, nw = 0, npar = 0, j = 0, nrelpar = 0, dof = 0;
1677// int sum = 0;
1678// double chi2red = 0., wf2sum = 0., devf2sum = 0., wsum = 0., wfsum = 0.;
1679// double w2sum = 0., dev2sum = 0., wl2sum = 0., devl2sum = 0., arms = 0.;
1680// double wmean = 0., frms = 0., lrms = 0., rms = 0., lflux = 0.;
1681// double mlflux = 0., rat = 0., mrat = 0., sig = 0., fwhm = 0.;
1682// const double *weight, *flux, *dev;
1683
1684// /* Get output file path and name */
1685// p = cpl_parameterlist_find_const(parlist, "inst_dir");
1686// strcpy(basedir, cpl_parameter_get_string(p));
1687// p = cpl_parameterlist_find_const(parlist, "output_dir");
1688// sc_basic_abspath(output_dir, cpl_parameter_get_string(p), basedir);
1689// p = cpl_parameterlist_find_const(parlist, "output_name");
1690// strcpy(output_name, cpl_parameter_get_string(p));
1691// sprintf(outfile, "%s%s_fit.res", output_dir, output_name);
1692
1693// /* Open output file */
1694// if ((stream = fopen(outfile, "w+")) == NULL) {
1695// sprintf(errtxt, "%s: %s", SC_ERROR_FOF_TXT, outfile);
1696// return cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_FOF, "%s", errtxt);
1697// }
1698
1699// /* Write file names of science and sky spectrum */
1700// fprintf(stream, "INPUT DATA FILES:\n");
1701// p = cpl_parameterlist_find_const(parlist, "scispec");
1702// fprintf(stream, "Science: %s\n", cpl_parameter_get_string(p));
1703// p = cpl_parameterlist_find_const(parlist, "skyspec");
1704// fprintf(stream, "Sky: %s\n\n", cpl_parameter_get_string(p));
1705
1706// /* Write CMPFIT status */
1707// fprintf(stream, "MPFIT RESULTS:\n");
1708// fprintf(stream, "Status: %d\n", result->status);
1709
1710// /* Get number of data points with non-zero weight (= DOF+1) */
1711
1712// npix = cpl_table_get_nrow(scispec);
1713// for (i = 0; i < npix; i++) {
1714// if (cpl_table_get(scispec, "cweight", i, NULL) > 0) {
1715// nw++;
1716// }
1717// }
1718
1719// if (nw == 1) {
1720// sprintf(errtxt, "%s: cpl_table *scispec "
1721// "(only 1 data point with weight > 0)", SC_ERROR_ISD_TXT);
1722// //err = cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_ISD, "%s", errtxt);
1723// cpl_msg_warning(cpl_func, "cpl_table *scispec (only 1 data point "
1724// "with weight > 0)");
1725// }
1726
1727// /* Get number of relevant fit parameters */
1728// npar = cpl_table_get_nrow(fitpar);
1729// for (j = 0; j < npar; j++) {
1730// if (cpl_table_get(fitpar, "relevance", j, NULL) == 1) {
1731// nrelpar++;
1732// }
1733// }
1734
1735// /* Write CMPFIT results */
1736
1737// fprintf(stream, "Fit parameters: %d\n", nrelpar);
1738// fprintf(stream, "Data points: %d\n", npix);
1739// fprintf(stream, "Weight > 0: %d\n", nw);
1740// fprintf(stream, "MPFIT calls: %d\n", calls);
1741// fprintf(stream, "Iterations: %d\n", result->niter);
1742// fprintf(stream, "Function evaluations: %d\n", nfev);
1743// fprintf(stream, "Fit run time in s: %.2f\n", runtime);
1744// fprintf(stream, "Initial chi2: %.3e\n", result->orignorm);
1745// fprintf(stream, "Best chi2: %.3e\n", result->bestnorm);
1746// if (nw - nrelpar <= 1) {
1747// fprintf(stream, "Reduced chi2: UNDEF\n");
1748// fprintf(stream, "RMS rel. to error: UNDEF\n");
1749// } else {
1750// dof = nw - nrelpar - 1;
1751// chi2red = result->bestnorm / (double) dof;
1752// fprintf(stream, "Reduced chi2: %.3e\n", chi2red);
1753// fprintf(stream, "RMS rel. to error: %.3e\n", sqrt(chi2red));
1754// }
1755
1756// /* Save results and set sigclip to 0 to calculate deviations for all
1757// pixels */
1758// tmpspec = cpl_table_duplicate(scispec);
1759// cpl_table_fill_column_window(tmpspec, "sigclip", 0, npix, 0);
1760// sc_modsky_calcdev(tmpspec);
1761
1762// /* Get pointers to table columns */
1763// flux = cpl_table_get_data_double_const(tmpspec, "lflux");
1764// weight = cpl_table_get_data_double_const(tmpspec, "cweight");
1765// dev = cpl_table_get_data_double_const(tmpspec, "dev");
1766
1767// /* Compute weighted deviations for line peaks, lines (peak +- HWHM),
1768// and the full spectrum and weighted line peak flux */
1769// for (i = 0; i < npix; i++) {
1770// wf2sum += weight[i] * weight[i];
1771// devf2sum += dev[i] * dev[i];
1772// if (cpl_table_get(scispec, "sigclip", i, NULL) == 0) {
1773// if (cpl_table_get(scispec, "class", i, NULL) >= 2) {
1774// wsum += weight[i];
1775// wfsum += weight[i] * flux[i];
1776// w2sum += weight[i] * weight[i];
1777// dev2sum += dev[i] * dev[i];
1778// }
1779// wl2sum += weight[i] * weight[i];
1780// devl2sum += dev[i] * dev[i];
1781// }
1782// }
1783
1784// /* Delete temporary table */
1785// cpl_table_delete(tmpspec);
1786
1787// /* Compute RMS of full spectrum and write it to file */
1788// if (wf2sum == 0) {
1789// fprintf(stream, "Full RMS: UNDEF\n");
1790// } else {
1791// arms = sqrt(devf2sum / wf2sum);
1792// fprintf(stream, "Full RMS: %.3e\n", arms);
1793// }
1794
1795// /* Compute three different RMS relative to weighted mean of line peaks and
1796// write them to file */
1797// if (wsum == 0 || wfsum == 0) {
1798// fprintf(stream, "Full RMS rel. to peaks: UNDEF\n");
1799// fprintf(stream, "Line RMS rel. to peaks: UNDEF\n");
1800// fprintf(stream, "Peak RMS rel. to peaks: UNDEF\n");
1801// if (wsum == 0) {
1802// sprintf(errtxt, "%s: cpl_table *scispec (all weights = 0)",
1803// SC_ERROR_IOV_TXT);
1804// //err = cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_IOV, "%s",
1805// //errtxt);
1806// cpl_msg_warning(cpl_func, "cpl_table *scispec (all weights = 0)");
1807// } else {
1808// sprintf(errtxt, "%s: cpl_table *scispec (all fluxes = 0)",
1809// SC_ERROR_IOV_TXT);
1810// err = cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_IOV, "%s", errtxt);
1811// }
1812// } else {
1813// wmean = wfsum / wsum;
1814// frms = arms / wmean;
1815// fprintf(stream, "Full RMS rel. to peaks: %.3e\n", frms);
1816// lrms = sqrt(devl2sum / wl2sum) / wmean;
1817// fprintf(stream, "Line RMS rel. to peaks: %.3e\n", lrms);
1818// rms = sqrt(dev2sum / w2sum) / wmean;
1819// fprintf(stream, "Peak RMS rel. to peaks: %.3e\n", rms);
1820// }
1821
1822// /* Compute sigma-clipped mean of ratio between residual and input line
1823// flux for valid line peaks and write it to file */
1824
1825// ratio = cpl_array_new(npix, CPL_TYPE_DOUBLE);
1826
1827// for (sum = 0, i = 0; i < npix; i++) {
1828// if (cpl_table_get(scispec, "sigclip", i, NULL) == 0 &&
1829// cpl_table_get(scispec, "class", i, NULL) >= 2) {
1830// /* Valid (i.e. unclipped) line peak found in science spectrum */
1831// lflux = cpl_table_get(scispec, "lflux", i, NULL);
1832// mlflux = cpl_table_get(scispec, "mlflux", i, NULL);
1833// if (lflux == 0) {
1834// rat = 1e6;
1835// } else {
1836// rat = fabs((mlflux - lflux) / lflux);
1837// }
1838// cpl_array_set_double(ratio, i, rat);
1839// sum++;
1840// } else {
1841// /* Set array element invalid if pixel is not valid line peak */
1842// cpl_array_set_invalid(ratio, i);
1843// }
1844// }
1845
1846// /* Perform sigma-clipping for entire spectrum */
1847// if (sum > 0) {
1848// sc_basic_clipmean(&mrat, &sig, ratio, CPL_FALSE);
1849// }
1850
1851// cpl_array_delete(ratio);
1852
1853// if (sum == 0) {
1854// fprintf(stream, "Mean rel. residual: UNDEF\n\n");
1855// sprintf(errtxt, "%s: cpl_table *scispec (no valid line peaks)",
1856// SC_ERROR_IOV_TXT);
1857// //err = cpl_error_set_message(cpl_func, (cpl_error_code)SC_ERROR_IOV, "%s", errtxt);
1858// cpl_msg_warning(cpl_func, "cpl_table *scispec (no valid line peaks)");
1859// } else {
1860// fprintf(stream, "Mean rel. residual: %.3e\n\n", mrat);
1861// }
1862
1863// /* FWHM from parameter list */
1864// p = cpl_parameterlist_find_const(parlist, "fwhm");
1865// fwhm = cpl_parameter_get_double(p);
1866
1867// /* Spectral resolution from line width measurements in pixels */
1868// fprintf(stream, "ESTIMATED SPECTRAL RESOLUTION:\n");
1869// fprintf(stream, "FWHM in pixels: %.3f\n\n", fwhm);
1870
1871// /* Write best-fit parameters */
1872// fprintf(stream, "BEST-FIT PARAMETERS:\n\n");
1873
1874// /* Write parameter type, number, and best-fit value with uncertainty */
1875// fprintf(stream,
1876// "Type N Fit Value RMS N_lin\n");
1877
1878// /* Loop over all parameters but write relvant parameters only */
1879// for (j = 0; j < npar; j++) {
1880// if (cpl_table_get_int(fitpar, "relevance", j, NULL) == 1) {
1881// sprintf(type, "%s", cpl_table_get_string(fitpar, "type", j));
1882// fprintf(stream, "%c %.2d %d %10.4g +- %-9.4g %-9.4g %d\n",
1883// type[0], cpl_table_get_int(fitpar, "N", j, NULL),
1884// cpl_table_get_int(fitpar, "fit", j, NULL),
1885// cpl_table_get(fitpar, "value", j, NULL),
1886// cpl_table_get(fitpar, "err_fit", j, NULL),
1887// cpl_table_get(fitpar, "err_est", j, NULL),
1888// cpl_table_get_int(fitpar, "N_lin", j, NULL));
1889// }
1890// }
1891
1892// /* Explanations for printed table */
1893// fprintf(stream, "\nREMARKS:\n");
1894// fprintf(stream, "Type: A/B = line group A/B, w = wavelength fit coef.\n");
1895// fprintf(stream, "Fit: 1 = free MPFIT par., 0 = only initial estimate\n");
1896// fprintf(stream, "RMS: uncertainty of initial estimate\n");
1897// fprintf(stream, "%g: no error available\n", SC_DEFERRVAL);
1898// fprintf(stream, "N_lin: number of lines for fitting \n");
1899
1900// fclose(stream);
1901
1902// return err;
1903//}
1904
SC_MAXLEN
#define SC_MAXLEN
Definition: sc_basic.h:94
sc_basic_clipmean
cpl_error_code sc_basic_clipmean(double *mean, double *rms, cpl_array *arr, const cpl_boolean clip)
Definition: sc_basic.c:1539
sc_basic_copytable_content
cpl_error_code sc_basic_copytable_content(cpl_table *outtab, const cpl_table *intab)
Definition: sc_basic.c:1923
SC_TOL
#define SC_TOL
Definition: sc_basic.h:96
SC_LENLINE
#define SC_LENLINE
Definition: sc_basic.h:92
sc_basic_calcsinc
cpl_error_code sc_basic_calcsinc(cpl_vector *sinc)
Definition: sc_basic.c:2714
sc_modsky
cpl_error_code sc_modsky(cpl_table *scispec, cpl_table *skyspec, cpl_table *fitpar, const cpl_vector *sinc, const cpl_parameterlist *parlist)
Definition: sc_modsky.c:53
sc_mpfit_allocmempar
cpl_error_code sc_mpfit_allocmempar(scpars *fitpars, const int npar)
Definition: sc_mpfit.c:1264
sc_mpfit_substbadfitpar
cpl_error_code sc_mpfit_substbadfitpar(cpl_table *fitpar, const cpl_table *initfitpar, const cpl_parameterlist *parlist)
Definition: sc_mpfit.c:1537
sc_mpfit
cpl_error_code sc_mpfit(mp_result *result, cpl_table *scispec, cpl_table *skyspec, cpl_table *fitpar, const cpl_parameterlist *parlist)
Definition: sc_mpfit.c:60
sc_mpfit_setpar
cpl_error_code sc_mpfit_setpar(scpars *fitpars, const cpl_table *fitpar, const char fittype)
Definition: sc_mpfit.c:1186
nfev
int nfev
Definition: sc_mpfit.c:51
sc_mpfit_allocmemresult
cpl_error_code sc_mpfit_allocmemresult(mp_result *result, const int m, const int n)
Definition: sc_mpfit.c:1373
sc_mpfit_freememresult
cpl_error_code sc_mpfit_freememresult(mp_result *result)
Definition: sc_mpfit.c:1502
sc_mpfit_freemempar
cpl_error_code sc_mpfit_freemempar(scpars *fitpars)
Definition: sc_mpfit.c:1333
sc_mpfit_initresult
cpl_error_code sc_mpfit_initresult(mp_result *result, const int m, const int n)
Definition: sc_mpfit.c:1420
sc_mpfit_modinitpar
cpl_error_code sc_mpfit_modinitpar(cpl_table *fitpar, cpl_table *scispec, cpl_table *skyspec, const cpl_parameterlist *parlist)
Definition: sc_mpfit.c:577
lastcall
cpl_boolean lastcall
Definition: sc_mpfit.c:53
sc_mpfit_calcdev
int sc_mpfit_calcdev(int m, int n, double *p, double *dy, double **dvec, void *vars)
Definition: sc_mpfit.c:517
sc_mpfit_copyresult
cpl_error_code sc_mpfit_copyresult(mp_result *outresult, const mp_result *inresult)
Definition: sc_mpfit.c:1461
sc_mpfit.h
SC_DEFERRVAL
#define SC_DEFERRVAL
Definition: sc_mpfit.h:65
SC_MAXPARERR
#define SC_MAXPARERR
Definition: sc_mpfit.h:77
SC_MINNLIN
#define SC_MINNLIN
Definition: sc_mpfit.h:71
SC_MAXRELFAC
#define SC_MAXRELFAC
Definition: sc_mpfit.h:74
SC_CORRFAC_MIN
#define SC_CORRFAC_MIN
Definition: sc_mpfit.h:67
SC_CORRFAC_MAX
#define SC_CORRFAC_MAX
Definition: sc_mpfit.h:69
_scpars_
Definition: sc_mpfit.h:122
_scvars_
Definition: sc_mpfit.h:106
Generated on Thu Nov 27 2025 10:22:36 for ERIS Pipeline Reference Manual by doxygen 1.9.6