Data Fitting and Uncertainty

Data Fitting and Uncertainty 

A practical Introduction to Weighted Least Squares and beyond 

1. Edition 

July 2010 

by 

Tilo Strutz 

Appendix S - The Source Code

Appendix S 

The Source Code 

S.1 Licence and Disclaimer 

The source code was written, assembled and tested carefully by the author. Nevertheless 

the code might contain minor errors. It is not guaranteed that this 

software will work under arbitrary conditions and especially using odd data as 

input. Theauthorandthepublishertakenoresponsibilityandoffernowarranties 

on this software. In case that you recognise bugs or unexpected behaviour of the 

fitting procedure using this software, please report to the author directly or via 

the publisher. 

Copyright c○ 2010 

Tilo Strutz (the author). All rights reserved. 

1. The usage of the source code for academic use is free. 

2. The redistribution of source code either in original form, modified form, 

binary form, or part of other software is not allowed without explicit permission 

given by the author. 

3. All advertising materials or publications mentioning features or use of this 

software must cite the source properly as 

”Strutz, T.: Data fitting and Uncertainty. Vieweg+Teubner, 2010”. 

4. Ifcommercialusageisplanned, pleasecontactthe authortoget information 

about details of a corresponding commercial licence. 

THIS SOFTWARE IS PROVIDED BY THE AUTHOR “AS IS” AND ANY 

EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 

TO,THEIMPLIEDWARRANTIESOFMERCHANTABILITYANDFITNESS 

FORAPARTICULARPURPOSEAREDISCLAIMED.INNOEVENTSHALL 

THE AUTHOR OR THE PUBLISHER BE LIABLE FOR ANY DIRECT, IN- 

DIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 

DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 

SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 

OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THE- 

ORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 

TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY 

WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 

THE POSSIBILITY OF SUCH DAMAGE. 

1

2 S The Source Code 

S.2 Main functions 

0: /***************************************************************** 

1: * 

2: * File........: fitting.c 

3: * Function....: data fitting with least squares 

4: * Author......: Tilo Strutz 

5: * last changes: 28.09.2009, 08.01.2010, 10.03.2010 

6: * 

7: * LICENCE DETAILS: see software manual 

8: * free academic use 

9: * cite source as 

10: * "Strutz, T.: Data Fitting and Uncertainty. Vieweg+Teubner, 2010" 

11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 

17: #ifndef WIN32 

18: #include 

19: #endif 

20: #include "get_option.h" 

21: #include "errmsg.h" 

22: #include "matrix_utils.h" 

23: #include "functions.h" 

24: #include "functions_NIST.h" 

25: #include "macros.h" 

26: #include "prototypes.h" 

27: #include "defines.h" 

28: 

29: /* #define OUTPUT_DEVIATES */ 

30: 

31: /* model functions */ 

32: #define CONSTANT 0 /* constant value */ 

33: #define LINEAR 1 /* f(x|a) = a1 + SUM_j a_j * x_(j-1) */ 

34: #define COSINE_LIN 2 /* cosine linear */ 

35: #define COSINE 5 /* cosine nonlinear */ 

36: #define EXPONENTIAL 6 /* exponential */ 

37: #define LOGARITHM 7 /* */ 

38: #define GAUSSIAN_2 8 /* superposition of two Gaussians */ 

39: #define EXPONENTIAL2 9 /* exponential 2 */ 

40: #define EXPONENTIAL2_LIN 10 /* exponential 2, linearised */ 

41: #define GEN_LAPLACE 11 /* generalised Laplacian distribution */ 

42: #define COSINE_TREND 12 /* cosine with linear trend */ 

43: #define GAUSSIAN_1 13 /* Gaussian */ 

44: #define POLYNOM_2NDORD 16 /* 2nd order polynomial */ 

45: #define POLYNOM_3RDORD 17 /* 3rd order polynomial */ 

46: #define POLYNOMIAL 18 /* multi-order polynomial */ 

47: #define POLYNOMIAL_REG 19 /* regularised */ 

48: #define QUAD_SURFACE 20 /* parabolic 2D surface */ 

49: #define COORD_TRANSF 21 /* rotation + translation */ 

50: #define TRIGONOMETRIC1 22 /* trigonometric polynom, 1st order */ 

51: #define TRIGONOMETRIC2 23 /* trigonometric polynom, 2st order */ 

52: #define CIRCLE 24 /* circle */ 

53: #define CIRCLE_LIN 25 /* circle, linearised */ 

54: #define CIRCLE_TLS 26 /* circle, total least squares */ 

55: #define NN_3x3x1 30 /* NeuralNet 3x3x1 */ 





60: #define NIST_THURBER 40 /* NIST data set */ 

61: #define NIST_MGH09 41 /* NIST data set */ 

62: #define NIST_RAT42 42 /* NIST data set */ 

63: #define NIST_RAT43 43 /* NIST data set */ 

64: #define NIST_ECKERLE4 44 /* NIST data set */ 

65: #define NIST_MGH10 45 /* NIST data set */ 

66: #define NIST_BENNETT5 46 /* NIST data set */ 

67: #define NIST_BOXBOD 47 /* NIST data set */ 

68: 

69: /* defined in singvaldec.c */ 

70: double euclid_dist( double a, double b); 

71: 

72: /*--------------------------------------------------------------- 

73: * main() 

74: *--------------------------------------------------------------*/ 

75: int 

76: main( int argc, char *argv[]) 

77: { 

78: char *rtn = "main"; 

79: char *field; /* used for reading text files */ 

80: char *inname = NULL; /* filename of input data */ 

81: char *outname = NULL; /* filename of results */ 

82: /* string with list of columns containing conditions */ 

83: char *column_cond_str=NULL; 

84: /* used for reading text files */ 

85: char line[MAXLINELENGTH+1], *ptr; 

86: /* pointer to model function */ 

87: double (*funct) (int, double*, double*) = NULL; 

88: /* pointer to its derivative */ 

89: double (*funct_deriv) (double(*)(int,double*,double*), 

90: int,int,int,double*,double*) = NULL; 

91: double (*funct_deriv2) (double(*)(int,double*,double*), 

92: int,int,int,int,double*,double*) = NULL; 

93: /* pointer to initialisation function */ 

94: int (*init) (int, double*,double*,double*, 

95: unsigned char*,FILE*) = NULL; 

96: int err = 0, i, j, o; 

97: int cnt; /* counter for observations */ 

98: int column_cond[MAX_CONDITIONS], col, ch; 

99: int column_obs = 0; /* column containing the observations */ 

100: int cond_dim = 1; /* dimensionality of conditions */ 

101: int obs_dim = 1; /* dimensionality of observations */ 

102: int type = 0; /* type of model function */ 

103: int N; /* number of observations */ 

104: int M; /* number of model parameters */ 

105: int M_flag=0; /* flag for model LINEAR, POLYNOMIAL_REG */ 

106: int numerical_flag = 0; /* force numerical derivation */ 

107: int scale_flag = 0; /* enable scaling of conditions */ 

108: int forget_flag = 0; /* enables reset of weights after 

109: * outlier removal */ 

110: int num_outlier = 0; /* number of outliers */ 

111: int out_mode = 0; /* 

112: * 0 .. no outlier removal 

113: * 1 .. enable Chauvenet’s outlier detection 

114: * 2 .. enable distance outlier detection 

115: */ 

116: int weight_mode = 0;/* 

117: * 0 .. use equal weights (no weighting) 

118: * 1 .. enable deviates based weighting 

119: * 2 .. weighting by binning 

120: */ 

121: int obs_per_bin = 50; /* observations per bin for 

122: * weight_mode = 2 

123: */ 

124: int algo_mode = 1; /* 

125: * 0 .. use simple matrix inversion, M linear = 1; 

174: ls_flag->svd = 1; /* use SVD for linear systema as default */ 

175: ls_flag->LM = 1; /* use Levenberg-Marquardt as default */ 

176: ls_flag->chisq_target = 0; 

177: ls_flag->trueH = 0; 

178: ITERAT_MAX = 2000; /* declared in ls.c */ 

179: 

180: #ifdef TESTT 

181: { 

182: double **a, **b; 

183: double det; 

184: a = matrix( 5, 5); /* matrix */ 

185: b = matrix( 5, 5); /* matrix */ 

186: 

187: a[0][0] = 2.; a[0][1] = 2.; a[0][2] = 3.; a[0][3] = 4.; a[0][4] = 5.; 

188: a[1][0] = 2.; a[1][1] = 3.; a[1][2] = 5.; a[1][3] = 5.; a[1][4] = 5.; 

189: a[2][0] = 1.; a[2][1] = 4.; a[2][2] = 4.; a[2][3] = 4.; a[2][4] = 2.;

S.2 Main functions 3 

190: a[3][0] = 1.; a[3][1] = 2.; a[3][2] = 1.; a[3][3] = 5.; a[3][4] = 3.; 286: ls_flag->chisq_target = 1; 

191: a[4][0] = 3.; a[4][1] = 3.; a[4][2] = 3.; a[4][3] = 2.; a[4][4] = 6.; 287: break; 

192: 

288: case ’x’: 

193: det = inverse_5x5( a, b); 

289: out_mode = atoi( OptArg); 

194: fprintf( stderr, "\n det = %f\n", det); 

290: /* 0 ... no removal; 1 ... Chauvenet’s; 

195: for ( i = 0; i < 5; i++) 

291: * 2 ... distance based; 

196: { 

292: */ 

197: for ( j = 0; j < 5; j++) 

293: break; 

198: { 

294: case ’s’: 

199: fprintf( stderr, " %6.2f", b[i][j]); 

295: ls_flag->svd = 0; 

200: } 

296: /* disable special SVD function for solving linear model 

201: fprintf( stderr, "\n "); 

297: */ 

202: } 

298: break; 

203: 

299: case ’f’: 

204: free_matrix( &a); 

300: forget_flag = 1; 

205: free_matrix( &b); 

301: /* forget weights after outlier removal 

206: exit( 1); 

302: */ 

207: } 

303: break; 

208: #endif 

304: case ’?’: 

209: /* check command-line parameters */ 

305: default: 

210: while (( optstr = 

306: usage( argv[0]); /* provides help */ 

211: ( char*)get_option( argc, (const char **)argv)) != NULL) 307: err = 11; 

212: { 

308: goto endfunc; 

213: switch (optstr[1]) 

309: } 

214: { 

310: } 

215: case ’a’: 

311: 

216: switch (optstr[2]) 

312: /* check, whether all mandatory options were given */ 

217: { 

313: err = check_opt( argv[0]); 

218: case ’\0’: 

314: if (err) 

219: algo_mode = atoi( OptArg); 


220: /* 0 .. use simple matrix inversion, M trueH = 1; 

356: /* loop until all columns are read or 

261: break; 

357: * maximal number of columns is reached 

262: case ’I’: /* maximum number of iterations */ 

358: */ 

263: ITERAT_MAX = atoi( OptArg); 

359: ptr = &(column_cond_str[i]); 

264: break; 

360: sscanf( ptr, "%d", &(column_cond[col])); 

265: case ’M’: /* number of parameters (type == LINEAR) */ 361: do 

266: M = atoi( OptArg); 

362: { /* go to next number */ 

267: M_flag = 1; 

363: i++; 

268: break; 

364: ch = column_cond_str[i]; 

269: case ’L’: /* use plain Gauss-Newton */ 

365: } while( ch != ’\0’ && ch != ’,’); 

270: ls_flag->LM = 0; 

366: i++; 

271: break; 

367: col++; 

272: case ’w’: 

368: } while ( ch != ’\0’ && col < MAX_CONDITIONS); 

273: weight_mode = atoi( OptArg); 

369: for ( i = col; i < MAX_CONDITIONS; i++) 

274: /* 0 ... equal weights; 1 ... deviates based; 370: { 

275: * 2 ... Bin-wise 

371: column_cond[i] = column_cond[i-1]+1; 

276: */ 

372: } 

277: break; 

373: } 

278: case ’i’: 

374: 

279: inname = OptArg; 

375: /* 

280: break; 

376: * open the input file 

281: case ’o’: 

377: * determine the number of data sets 

282: outname = OptArg; 

378: */ 

283: break; 

379: in = fopen( inname, "rt"); 

284: case ’t’: 

380: if (in == NULL) 

285: chisq_target = atof( OptArg); 

381: {


382: err = errmsg( ERR_OPEN_READ, rtn, inname, 0); 


384: } 

385: /* open out file */ 

386: out = fopen( outname, "wt"); 

387: if (out == NULL) 

388: { 

389: err = errmsg( ERR_OPEN_WRITE, rtn, outname, 0); 


391: } 

392: 

393: fprintf( out, "# %s ===============================", rtn); 

394: fprintf( out, "\n# use data file: %s", inname); 

395: 

396: /* determine number of observations by counting of valid lines */ 

397: N = 0; 

398: while (( ptr = fgets( line, MAXLINELENGTH, in)) != NULL) 

399: { 

400: /* skip comment lines (starting with ’#’) and empty ones */ 

401: if ( is_data_line( line, MAXLINELENGTH) ) 

402: { 

403: N++; 

404: if (strlen( line) == MAXLINELENGTH-1) 

405: { 

406: fprintf( stderr, 

407: "\n lines of input file are too long (>%d)", 

408: MAXLINELENGTH); 

409: fprintf( stderr, ", increase MAXLINELENGTH"); 

410: } 

411: } 

412: } 

413: fclose( in); 

414: 

415: fprintf( stderr, "\n datafile contains %d data points\n", N); 

416: 

417: /* 

418: * set number of parameters and redirect pointer to functions 

419: */ 

420: switch (type) 

421: { 

422: case CONSTANT: 

423: /* y = a1 */ 

424: fprintf( out, "\n# constant function"); 

425: printf( "\n constant function"); 

426: if (numerical_flag) 

427: funct_deriv = f_deriv;/* use numerical differentiation */ 

428: else 

429: funct_deriv = fconstant_deriv; 

430: M = 1; 

431: break; 

432: 

433: case LINEAR: 

434: /* f(x|a) = a1 + Sum_j(a_j*x_j) */ 

435: fprintf( out, "\n# linear in x, order %d", M-1); 

436: printf( "\n linear in x, order %d", M-1); 



439: else 

440: funct_deriv = flin_deriv; 

441: /* M is set via program parameter */ 

442: cond_dim = M - 1; /* first parameter a1 is just an offset 

443: * w/o corresponding condition 

444: */ 

445: break; 

446: case COSINE_LIN: 

447: /* 

448: * f(x|b) = b1 + b2 * cos( x - b3) 

449: * f(x|a) = a1 + a2 * cos( x) + a3 * sin( x) 

450: * a2 = b2 * cos(b3), a3 = b2 * sin(b3) 

451: * a1 = b1 

452: */ 

453: fprintf( out, "\n# cosine (linear)"); 

454: printf( "\n cosine (linear)"); 



457: else 

458: funct_deriv = fcosine_deriv; 

459: M = 3; 

460: break; 

461: case COSINE: 

462: /* 

463: * f(x|a) = a1 + a2 * cos( x - a3) 

464: */ 

465: fprintf( out, "\n# cosine nonlinear"); 

466: printf( "\n cosine nonlinear"); 



469: else 

470: funct_deriv = fcosine_nonlin_deriv; 

471: funct = fcosine_nonlin; 

472: init = init_cosine_nonlin; 

473: M = 3; 

474: ls_flag->linear = 0; /* nonlinear */ 

475: break; 

476: case COSINE_TREND: 

477: /* 

478: * f(x|a) = a1 + a2 * x + a3 * cos( x - a4) 

479: */ 

480: fprintf( out, "\n# cosine with trend"); 

481: printf( "\n cosine with trend"); 



484: else 

485: funct_deriv = fcosine_trend_deriv; 

486: funct = fcosine_trend; 

487: init = init_cosine_trend; 

488: M = 4; 


490: break; 

491: case LOGARITHM: 

492: /* f(x|a) = a1 + a2 * exp( a3 * x) */ 

493: fprintf( out, "\n# log( a1 * x)"); 

494: printf( "\n log( a1 * x)"); 



497: else 

498: funct_deriv = flogarithmic_deriv; /* */ 

499: funct_deriv2 = flogarithmic_deriv2; /* */ 

500: funct = flogarithmic; 

501: init = init_logarithmic; 

502: M = 1; 


504: break; 

505: case EXPONENTIAL: 

506: /* f(x|a) = a1 + a2 * exp( a3 * x) */ 

507: fprintf( out, "\n# exponential"); 

508: printf( "\n exponential"); 

509: funct_deriv = f_deriv; /* use numerical differentiation */ 

510: funct = fexponential; 

511: init = init_exponential; 

512: M = 3; 


514: break; 

515: case GEN_LAPLACE: 

516: /* f(x|a) = a1 * exp( -|x|â2 * a3) */ 

517: fprintf( out, "\n# gen. Laplacian"); 

518: printf( "\n gen. Laplacian"); 



521: else 

522: funct_deriv = fgen_laplace_deriv; 

523: funct_deriv = f_deriv; 

524: funct_deriv2 = NULL; 

525: funct = fgen_laplace; 

526: init = init_gen_laplace; 

527: M = 3; 


529: break; 

530: case GAUSSIAN_1: 

531: /* 

532: * f(x|a) = a1 * exp( a2 * (x-a3)^2) + 

533: */ 

534: fprintf( out, "\n# single Gaussian"); 

535: printf( "\n single Gaussian"); 



538: else 

539: funct_deriv = fgauss_deriv; 

540: funct_deriv2 = fgauss_deriv2; 

541: funct = fgauss1; 

542: init = init_gauss; 

543: M = 3; 


545: break; 

546: case GAUSSIAN_2: 

547: /* 

548: * f(x|a) = a1 * exp( a2 * (x-a3)^2) + 

549: * a4 * exp( a5 * (x-a6)^2) 

550: */ 

551: fprintf( out, "\n# two Gaussians"); 

552: printf( "\n two Gaussians"); 


554: funct = fgauss2; 

555: init = init_gauss2; 

556: M = 6; 


558: break; 

559: case EXPONENTIAL2: 

560: /* f(x|a) = a2 * exp( a3 * x) */ 

561: fprintf( out, "\n# exponential 2"); 

562: printf( "\n exponential 2"); 



565: else 

566: funct_deriv = fexpon2_deriv; 

567: funct = fexpon2; 

568: init = init_expon2; 

569: M = 2; 


571: break; 

572: case EXPONENTIAL2_LIN: 

573: /* ln(f(x|a)) = ln(a2) + a3 * x */


574: fprintf( out, "\n# exponential 2, linearised"); 

575: printf( "\n exponential 2, linearised"); 



578: else 

579: funct_deriv = flin_deriv; 

580: M = 2; 

581: break; 

582: case POLYNOM_2NDORD: 

583: /* 

584: * f(x|a) = a1 + a2 * x + a3 * x^2 

585: */ 

586: fprintf( out, "\n# polynomial of 2nd order"); 

587: printf( "\n polynomial of 2nd order"); 



590: else 

591: funct_deriv = fpolynom2_deriv; 

592: M = 3; 

593: break; 

594: case POLYNOM_3RDORD: 

595: /* 

596: * f(x|a) = a1 + a2 * x + a3 * x^2 + a4 * x^3 

597: */ 

598: fprintf( out, "\n# polynomial of 3rd order"); 

599: printf( "\n polynomial of 3rd order"); 



602: else 

603: funct_deriv = fpolynom3_deriv; 

604: M = 4; 

605: break; 

606: case POLYNOMIAL: 

607: /* 

608: * f(x|a) = a1 + a2 * x + a3 * x^2 + ... 

609: */ 

610: fprintf( out, "\n# polynomial of %dth order", M-1); 

611: printf( "\n polynomial of %dth order", M-1); 



614: else 

615: funct_deriv = fpolynomial_deriv; 


617: break; 

618: case POLYNOMIAL_REG: 

619: /* 

620: * f(x|a) = a1 + a2 * x + a3 * x^2 + ... 

621: */ 

622: if (M == 2) 

623: { 

624: fprintf( out, "\n# polynomial of 1st order"); 

625: printf( "\n polynomial of 1st order"); 

626: } 

627: else if (M==3) 

628: { 

629: fprintf( out, "\n# polynomial of 2nd order"); 

630: printf( "\n polynomial of 2nd order"); 

631: } 

632: else if (M==3) 

633: { 

634: fprintf( out, "\n# polynomial of 3rd order"); 

635: printf( "\n polynomial of 3rd order"); 

636: } 

637: else 

638: { 

639: fprintf( out, "\n# polynomial of %dth order", M-1); 

640: printf( "\n polynomial of %dth order", M-1); 

641: } 

642: fprintf( out, ", regularised (nonlinear)"); 

643: printf( ", regularised (nonlinear)"); 

644: 



647: else 

648: funct_deriv = fpolynomial_deriv; 

649: funct = fpolynomial; 

650: init = init_polynomial; 



653: break; 

654: case QUAD_SURFACE: 

655: /* 

656: * f(x|a) = a1 + a2*x1 + a3*x1^2 + a4*x2 +a5*x2^2 

657: */ 

658: fprintf( out, "\n# quadratic surface"); 

659: printf( "\n quadratic surface"); 



662: else 

663: funct_deriv = fquadsurface_deriv; 

664: cond_dim = 2; 

665: M = 5; 

666: break; 

667: case COORD_TRANSF: 

668: /* 

669: * f1(x|a) = a1 + cos(a3) * x1 - sin(a3) * x2 

670: * f2(x|a) = a2 + sin(a3) * x1 + cos(a3) * x2 

671: */ 

672: fprintf( out, "\n# rotation"); 

673: printf( "\n rotation"); 


675: funct = frotation; 

676: init = init_rotation; 

677: M = 3; 

678: cond_dim = 2; 

679: obs_dim = 2; 


681: break; 

682: case TRIGONOMETRIC1: 

683: /* 

684: * f(x|a) = a1 + a2*cos(a3*x-a4) 

685: */ 

686: fprintf( out, "\n# trigonometric 1st order"); 

687: printf( "\n trigonometric 1st order"); 


689: funct = ftrigonometric1; 

690: init = init_trigonometric1; 

691: M = 4; 

692: cond_dim = 1; 

693: obs_dim = 1; 


695: break; 

696: case TRIGONOMETRIC2: 

697: /* 

698: * f(x|a) = a1 + a2*cos(a3*x-a4) + a5*cos(2*a3*x-a6) 

699: */ 

700: fprintf( out, "\n# trigonometric 2nd order"); 

701: printf( "\n trigonometric 2nd order"); 


703: funct = ftrigonometric2; 

704: init = init_trigonometric2; 

705: M = 6; 

706: cond_dim = 1; 

707: obs_dim = 1; 


709: break; 

710: case CIRCLE: 

711: /* 

712: * f(x|a) = 0 = (x1 - a1)^2 + (x2 - a2)^2 - a3*a3 

713: */ 

714: fprintf( out, "\n# circle"); 

715: printf( "\n circle"); 



718: else 

719: funct_deriv = fcircle_deriv; 

720: funct = fcircle; 

721: init = init_circle; 

722: M = 3; 

723: cond_dim = 2; 

724: obs_dim = 1; 


726: break; 

727: case CIRCLE_TLS: 

728: /* 

729: * f(x|a) = 0 = (sqrt[(x1 - a1)^2 + (x2 - a2)^2] - a3)^2 

730: */ 

731: fprintf( out, "\n# circle, TLS"); 

732: printf( "\n circle, TLS"); 



735: else 

736: funct_deriv = fcircleTLS_deriv; 

737: funct = fcircleTLS; 

738: init = init_circle; 

739: M = 3; 

740: cond_dim = 2; 

741: obs_dim = 1; 


743: break; 

744: case CIRCLE_LIN: 

745: /* 

746: * f(x|a) = 0 = (x1 - a1)^2 + (x2 - a2)^2 - a3*a3 

747: * f(x|b) = x1^2 + x2^2 = b1*x1 + b2*x2 - b3 

748: * b1 = 2*a1, b2 = 2*a2, b3 = a1^2 + a2^2 - a3^2 

749: */ 

750: fprintf( out, "\n# circle, linearised"); 

751: printf( "\n circle, linearised"); 



754: else 

755: funct_deriv = fcirclelin_deriv; 

756: init = init_circlelin; 

757: M = 3; 

758: cond_dim = 2; 

759: obs_dim = 1; 

760: ls_flag->linear = 1; /* linear */ 

761: break; 

762: case NN_3x3x1: 

763: /* 

764: * f(x|a) = neural network 3x3x1 

765: */


766: fprintf( out, "\n# NN 3x3x1"); 

767: printf( "\n NN 3x3x1"); 


769: funct = fNN_3_3; 

770: init = init_NN3x3x1; 

771: M = 16; 

772: cond_dim = 3; 

773: obs_dim = 1; 


775: break; 


777: /* 


779: */ 


781: printf( "\n NN 3x2x1"); 


783: funct = fNN_3_2; 

784: init = init_NN; 

785: M = 11; 

786: cond_dim = 3; 

787: obs_dim = 1; 


789: break; 


791: /* 


793: */ 


795: printf( "\n NN 1x2x1"); 


797: funct = fNN_1_2; 


799: M = 7; 

800: cond_dim = 1; 

801: obs_dim = 1; 


803: break; 


805: /* 


807: */ 


809: printf( "\n NN 2x2x1"); 


811: funct = fNN_2_2; 


813: M = 9; 

814: cond_dim = 2; 

815: obs_dim = 1; 


817: break; 


819: /* 


821: */ 


823: printf( "\n NN 1x3x1"); 


825: funct = fNN_1_3; 

826: init = init_NN1x3x1; 

827: M = 10; 

828: cond_dim = 1; 

829: obs_dim = 1; 


831: break; 

832: case NIST_THURBER: 

833: /* 

834: * f(x|a) =(a1 + a2*x + a3*x**2 + a4*x**3) / 

835: * (1 + a5*x + a6*x**2 + a7*x**3) 

836: */ 

837: fprintf( out, "\n# NIST_THURBER"); 

838: printf( "\n NIST_THURBER"); 



841: else 

842: funct_deriv = fNIST_thurber_deriv; 

843: funct = fNIST_thurber; 

844: init = init_NIST_thurber; 

845: M = 7; 

846: cond_dim = 1; 

847: obs_dim = 1; 


849: break; 

850: case NIST_MGH09: 

851: /* 

852: * f(x|a) =a1 * (x**2 + a2*x) / (x*x + a3*x + a4) 

853: */ 

854: fprintf( out, "\n# NIST_MGH09"); 

855: printf( "\n NIST_MGH09"); 



858: else 

859: funct_deriv = fNIST_MGH09_deriv; 

860: funct = fNIST_MGH09; 

861: init = init_NIST_MGH09; 

862: M = 4; 

863: cond_dim = 1; 

864: obs_dim = 1; 


866: break; 

867: case NIST_RAT42: 

868: /* 

869: * f(x|a) = a1 / (1 + exp(a2 - a3*x)) 

870: */ 

871: fprintf( out, "\n# NIST_Rat42"); 

872: printf( "\n NIST_Rat42"); 



875: else 

876: funct_deriv = fNIST_Rat42_deriv; 

877: funct = fNIST_Rat42; 

878: init = init_NIST_Rat42; 

879: M = 3; 

880: cond_dim = 1; 

881: obs_dim = 1; 


883: break; 


885: /* 

886: * f(x|a) = a1 / [1 + exp(a2 - a3*x)]^(1/a4) 

887: */ 

888: fprintf( out, "\n# NIST_Rat43"); 

889: printf( "\n NIST_Rat43"); 



892: else 

893: funct_deriv = fNIST_Rat43_deriv; 

894: funct = fNIST_Rat43; 

895: init = init_NIST_Rat43; 

896: M = 4; 

897: cond_dim = 1; 

898: obs_dim = 1; 


900: break; 

901: case NIST_ECKERLE4: 

902: /* 

903: * f(x|a) = a1 / a2 * exp(-0.5*((x -a3)/ a2)^2) 

904: */ 

905: fprintf( out, "\n# NIST_ECKERLE4"); 

906: printf( "\n NIST_ECKERLE4"); 



909: else 

910: funct_deriv = fNIST_Eckerle4_deriv; 

911: funct = fNIST_Eckerle4; 

912: init = init_NIST_Eckerle4; 

913: M = 3; 

914: cond_dim = 1; 

915: obs_dim = 1; 


917: break; 


919: /* 

920: * f(x|a) = a1 * exp( a2 / (x+a3)) 

921: */ 

922: fprintf( out, "\n# NIST_MGH10"); 

923: printf( "\n NIST_MGH10"); 



926: else 

927: funct_deriv = fNIST_MGH10_deriv; 

928: funct_deriv2 = fNIST_MGH10_deriv2; 

929: funct = fNIST_MGH10; 

930: init = init_NIST_MGH10; 

931: M = 3; 

932: cond_dim = 1; 

933: obs_dim = 1; 


935: break; 

936: case NIST_BENNETT5: 

937: /* 

938: * f(x|a) = a1 * (x+a2)^(-1/a3) 

939: */ 

940: fprintf( out, "\n# NIST_BENNETT5"); 

941: printf( "\n NIST_BENNETT5"); 



944: else 

945: funct_deriv = fNIST_Bennett5_deriv; /* */ 

946: funct = fNIST_Bennett5; 

947: init = init_NIST_Bennett5; 

948: M = 3; 

949: cond_dim = 1; 

950: obs_dim = 1; 


952: break; 

953: case NIST_BOXBOD: 

954: /* f(x|a) = a1 *(1 - exp( -a2 * x) */ 

955: fprintf( out, "\n# NIST_BOXBOD"); 

956: printf( "\n NIST_BOXBOD"); 

957: if (numerical_flag)



959: else 

960: funct_deriv = fNIST_BoxBOD_deriv; 

961: funct = fNIST_BoxBOD; 

962: init = init_NIST_BoxBOD; 

963: M = 2; 


965: break; 

966: default: 

967: err = errmsg( ERR_NOT_DEFINED, rtn, "-m ", type); 

968: usage( argv[0]); 


970: } 

971: /* if column for observation is not given explicitely by a 

972: * command-line parameter, then assume the column following 

973: * the conditions 

974: */ 

975: if (column_obs == 0) column_obs = cond_dim + 1; 

976: printf( "\n"); 

977: fflush( stdout); 

978: 

979: if (M > 5 && algo_mode == 0) 

980: { 

981: fprintf( stderr, "\n too much parameters (%d) ", M); 

982: fprintf( stderr, "for standard matrix inversion"); 

983: usage( argv[0]); 

984: err = 42; 


986: } 

987: 

988: if (M > M_MAX) 

989: { 


991: fprintf( stderr, "maximum is %d", M_MAX); 

992: err = 43; 


994: } 

995: 

996: if (N < M) 

997: { 

998: fprintf( stderr, "\nToo less observations (%d) compared ", N); 

999: fprintf( stderr, "to number of model parameters (%d)\n", M); 

1000: err = 44; 


1002: } 

1003: fprintf( out, "\n# Number of observations: %d", N); 

1004: fprintf( out, "\n# Number of parameters : %d", M); 

1005: 

1006: if (ls_flag->linear && ls_flag->svd && algo_mode != 1) 

1007: { 

1008: fprintf( stderr, "\n# option ’-a %d’ is ignored, ", algo_mode); 

1009: fprintf( stderr, "since special SVD approach is used!"); 

1010: algo_mode = 1; 

1011: } 

1012: if (ls_flag->trueH && funct_deriv2 == NULL) 

1013: { 


1015: "\n### function for 2nd derivativ was not initialised!"); 

1016: err = 45; 


1018: } 

1019: 

1020: /* 

1021: * allocate memory 

1022: */ 

1023: jacob = matrix( N * obs_dim, M); /* Jacobian */ 

1024: covar = matrix( M, M); /* covariance matrix */ 

1025: 

1026: obs = vector( N * obs_dim); /* observations */ 

1027: datac = vector( N * obs_dim); /* calculated data using 

1028: f(x|a) */ 

1029: cond = vector( N * cond_dim); /* conditions x */ 

1030: weights = vector( N * obs_dim); /* weights */ 

1031: weights_old = vector( N * obs_dim); /* weights one step back 

1032: */ 

1033: deviate = vector( N * obs_dim); /* remaining differences */ 

1034: /* remaining absolute differences */ 

1035: deviates_abs = vector( N * obs_dim); 

1036: deltasq = vector( N * obs_dim); /* remaining squared 

1037: differences */ 

1038: 

1039: /* open input file again */ 

1040: in = fopen( inname, "rt"); 

1041: if (in == NULL) 

1042: { 

1043: err = errmsg( ERR_OPEN_READ, rtn, inname, 0); 

1044: perror( "\nReason"); 


1046: } 

1047: 

1048: fprintf( out, "\n# condition columns: "); 

1049: for (j = 0; j < cond_dim; j++) 

1050: { 

1051: fprintf( out, "%d ", column_cond[j]); 

1052: } 

1053: 

1054: fprintf( out, "\n# observations column: "); 

1055: for (o = 0; o < obs_dim; o++) 

1056: { 

1057: fprintf( out, "%d ", column_obs + o); 

1058: } 

1059: fprintf( out, "\n#"); 

1060: if (!ls_flag->linear || (ls_flag->linear && !ls_flag->svd) ) 

1061: { 

1062: fprintf( out, "\n# algorithm for inversion: "); 

1063: if (algo_mode == 0) 

1064: fprintf( out, "Cofactor"); 

1065: else if (algo_mode == 1) 

1066: fprintf( out, "SVD"); 

1067: else if (algo_mode == 2) 

1068: fprintf( out, "LU decomposition"); 

1069: if (forget_flag) 

1070: fprintf( out, "\n# reset weights after outlier removal"); 

1071: } 

1072: if (ls_flag->linear) 

1073: { 

1074: fprintf( out, "\n# fitting a linear system"); 

1075: if (ls_flag->svd) 

1076: fprintf( out, "\n# use special SVD based algorithm"); 

1077: } 

1078: else 

1079: { 

1080: fprintf( out, "\n# fitting a nonlinear system"); 

1081: if (ls_flag->LM) 

1082: fprintf( out, "\n# use Levenberg-Marquardt method"); 

1083: else 

1084: fprintf( out, "\n# use Gauss-Newton method"); 

1085: if (ls_flag->chisq_target) 

1086: fprintf( out, "\n# chisq must be lower than %f", chisq_target); 

1087: } 

1088: /* write LS flags in output */ 

1089: 

1090: /* read the conditions and observations */ 

1091: for (i = 0; i < N; i++) 

1092: { 

1093: /* jump over comments and empty lines */ 

1094: do 

1095: { 

1096: ptr = fgets( line, MAXLINELENGTH, in); 

1097: } while ( !is_data_line( line, MAXLINELENGTH) ); 

1098: 

1099: /* loop over all conditions */ 


1101: { 

1102: /* if 0 was given, then assume that conditions are just 

1103: * serial numbers 1,2,3,... 

1104: */ 

1105: if (column_cond[j] == 0) 

1106: { 

1107: if (cond_dim > 1) 

1108: { 


1110: "\n There is more than one condition (%d)!", cond_dim); 


1112: "\n Columns of conditions must be given via ’-cc’!\n"); 


1114: } 

1115: cond[cond_dim * i + j] = i+1; 

1116: } 

1117: else 

1118: { 

1119: /* get string starting from desired column */ 

1120: field = get_nth_field( line, column_cond[j]); 

1121: if (field != NULL) 

1122: { 

1123: /* multidimensional conditions are stored one after each 

1124: other */ 

1125: sscanf( field, "%lf", &( cond[cond_dim * i + j])); 

1126: } 

1127: else 

1128: { 

1129: fprintf( stderr, "\n\n === %d th column does not exist", 

1130: column_cond[j]); 

1131: err = 13; 


1133: } 

1134: } 

1135: } 

1136: /* loop over all observations */ 

1137: for (o = 0; o < obs_dim; o++) 

1138: { 

1139: /* get string starting from desired column */ 

1140: field = get_nth_field( line, column_obs + o); 

1141: if (field != NULL) 

1142: { 

1143: sscanf( field, "%lf", &( obs[obs_dim * i + o])); 

1144: } 

1145: else 

1146: { 

1147: fprintf( stderr, "\n\n === %d th column does not exist", 

1148: column_obs); 

1149: err = 13;



1151: } 

1152: } 

1153: } 


1155: 

1156: /*--------------------------------------------- 

1157: * scaling of conditions, if enabled 

1158: */ 

1159: if (scale_flag) 

1160: { 

1161: /* get maximum absolute value */ 

1162: double max_cond, abs_cond; 


1164: { 


1166: max_cond = fabs( cond[0]); 

1167: for (i = 1; i < N*cond_dim; i++) 

1168: { 

1169: abs_cond = fabs( cond[i]); 

1170: if ( max_cond < abs_cond) max_cond = abs_cond; 

1171: } 

1172: scale_fac = 1./max_cond; 

1173: 

1174: /* do scaling */ 


1176: { 

1177: cond[i] *= scale_fac; 

1178: } 

1179: fprintf( out, "\n# scaling activated"); 

1180: fprintf( out, ", scale_fac = %f", scale_fac); 

1181: /* For cond_dim > 1 it would be even better to scale each 

1182: * condition separately. This would require cond_dim 

1183: * different scaling factors 

1184: */ 

1185: break; 


1187: /* scaling has no positive effect for these nonlinear 

1188: * model functions */ 





1193: for (i = 1; i < N; i++) 

1194: { 


1196: if ( max_cond < abs_cond) max_cond = abs_cond; 

1197: } 

1198: scale_fac = 1./max_cond; 

1199: 

1200: /* do scaling */ 

1201: for (i = 0; i < N; i++) 

1202: { 

1203: cond[i] *= scale_fac; 

1204: } 

1205: fprintf( out, "\n# scaling activated"); 

1206: fprintf( out, ", scale_fac = %f", scale_fac); 

1207: break; 

1208: default: 

1246: for (i = 0; i < N * obs_dim; i++) 

1247: { 

1248: /* sum of all weights must be equal to N minus number of 

1249: * outliers 

1250: */ 

1251: weights[i] = 1.0; 

1252: 

1253: } 

weights_old[i] = 1.0; 

1254: mean_weights = 1; 

1255: 

1256: /* 

1257: * pre-processing if necessary 

1258: 

1259: 

*/ 

1260: /* linearisation */ 

1261: if (type == EXPONENTIAL2_LIN) 

1262: { 

1263: /* ln(f(x|a)) = ln(a1) + (a2 * x) */ 

1264: /* estimates for parameters */ 

1265: for (i = 0; i < N; i++) 

1266: { 

1267: if (obs[i] linear) 

1283: { 

1284: 

1285: 

init( N, obs, cond, a, a_flag, out); 

1286: fprintf( out, "\n# initial Parameters\n# "); 

1287: /* write initial parameters to output */ 

1288: for (i = 0; i < M; i++) 

1289: { 

1290: fprintf( out, "a%d=%.9f, ", i+1, a[i]); 

1291: } 

1292: for (i = M; i < M_MAX; i++) 

1293: { 

1294: /* zero out unnecessary parameters 

1295: * required for POLYNOMIAL_REG 

1296: */ 

1297: a[i] = 0.; 

1298: } 

1299: /* If scaling is enabled, all initial parameters, which are set 

1300: * independently on the condition values, must be corrected 

1301: */ 


1303: { 

1304: switch ( type) 

1209: fprintf( out, "\n# scaling not supported for ’-m %d’", type); 1305: { 


1306: /* scaling has no positive effect for these nonlinear 

1211: "\n#### scaling not supported for ’-m %d’###\n", type); 1307: * model functions */ 

1212: } 


1213: } 

1309: a[2] /= scale_fac; 

1214: 

1310: break; 

1215: /* check input data */ 


1216: if (type == COSINE_LIN || type == COSINE) 

1312: a[0] *= scale_fac; 

1217: { 

1313: a[1] *= scale_fac; 

1218: /* conditions in degree ? */ 

1314: a[2] *= scale_fac; 

1219: double max_cond, abs_cond; 

1315: break; 



1221: for (i = 1; i < N; i++) 

1317: a[1] *= scale_fac; 

1222: { 

1318: a[2] *= scale_fac; 


1319: break; 

1224: if ( max_cond < abs_cond) max_cond = abs_cond; 1320: } 

1225: } 

1321: fprintf( out, "\n# scaled\n# "); 

1226: if ( max_cond < 2*M_PI) 

1322: /* write initial parameters to output */ 

1227: { 

1323: for (i = 0; i < M; i++) 

1228: fprintf( stderr, "\n======================================"); 1324: { 

1229: fprintf( stderr, "\n== range of degrees is very small!! =="); 1325: fprintf( out, "a%d=%.9f, ", i+1, a[i]); 

1230: fprintf( stderr, "\n== Mismatch with radians?? =="); 1326: } 

1231: fprintf( stderr, "\n== Please check.\n =="); 1327: } 

1232: fprintf( stderr, "\n======================================"); 1328: } 

1233: } 

1329: 

1234: } 

1330: /* 

1235: 

1331: * prepare Jacobian matrix containing 

1236: /* prepare input data */ 

1332: * first derivatives of target function 

1237: if (type == CIRCLE_LIN) 

1333: */ 

1238: { 


1239: for ( i = 0; i < N; i++) 

1335: { 

1240: { 

1336: for (j = 0; j < M; j++) 

1241: obs[i] = cond[2*i] * cond[2*i] + cond[2*i+1] * cond[2*i+1]; 1337: { 

1242: } 

1338: jacob[i][j] = funct_deriv( funct, i, j, M, cond, a); 

1243: } 

1339: } 

1244: 

1340: } 

1245: /* initialize weights */ 

1341:


1342: /* debugging output, because of interleaved observations */ 

1343: if (type == COORD_TRANSF) 

1344: { 

1345: fprintf( out, "\n#\n#== Obs ===== Jacobian ================="); 

1346: for (i = 0; i < MIN(10,N); i++) 

1347: { 

1348: fprintf( out, "\n# %8.1f", obs[i]); 

1349: for (j = 0; j < M; j++) 

1350: { 

1351: fprintf( out, " %8.1f", jacob[i][j]); 

1352: } 

1353: } 

1354: } 

1355: 

1356: /* 

1357: * estimation of weights if required 

1358: */ 

1359: iter_stop = 0; 

1360: if (weight_mode == 0) 

1361: { 

1362: iter_stop = 1; /* only one run */ 

1363: iter_final = 1; /* only one run for ls and outlier removal */ 

1364: } 

1365: else if (weight_mode == 2) 

1366: { 

1367: /* weights can be estimated beforehand via binning */ 

1368: est_weights2( N * obs_dim, cond, obs, weights, 

1369: obs_per_bin, out); 

1370: iter_stop = 1; /* only one run */ 

1371: iter_final = 1; /* only one run of least squares */ 

1372: } 

1373: else 

1374: iter_final = 0; 

1375: 

1376: /* outlier detection has not be performed yet */ 

1377: out_detect_flag = 0; 

1378: 

1379: 

1380: /* ----------------------------------------------------- */ 

1381: /* loop for weights estimation */ 

1382: for (iter = 0; 

1383: (iter linear) 

1413: { 

1414: /* separate for linear and nonlinear, because funct() is 

1415: not defined for linear models */ 


1417: { 

1418: /* get calculated data points dependent on current 

1419: parameters */ 

1420: datac[i] = 0.0; 

1421: for (j = 0; j < M; j++) 

1422: { 

1423: datac[i] += a[j] * jacob[i][j]; 

1424: } 

1425: deviate[i] = obs[i] - datac[i]; 

1426: deviates_abs[i] = fabs( deviate[i]); 

1427: /* weighted and squared differences */ 

1428: deltasq[i] = deviate[i] * deviate[i]; 

1429: if (weights[i] > 0.) 

1430: { 

1431: /* exclude outliers, i.e. weigths == 0 */ 

1432: chisq += weights[i] * deltasq[i]; 

1433: energy += deltasq[i]; 

1434: mean += deviates_abs[i]; 

1435: cnt++; 

1436: } 

1437: } 

1438: } 

1439: else /* if not linear */ 

1440: { 


1442: { 



1445: datac[i] = funct( i, cond, a); 

1446: 

1447: deviate[i] = obs[i] - datac[i]; 

1448: deviates_abs[i] = fabs( deviate[i]); 


1450: deltasq[i] = deviate[i] * deviate[i]; 

1451: if (weights[i] > 0.) 

1452: { 

1453: /* exclude outliers in final iteration*/ 


1455: energy += deltasq[i]; 

1456: mean += deviates_abs[i]; 

1457: cnt++; 

1458: } 

1459: } 

1460: } 

1461: num_outliers = N * obs_dim - cnt; 

1462: 

1463: /* estimate of k, w_i= k/sigma^2_i */ 

1464: gfit = chisq / (double)( cnt - M); /* goodness of fit */ 

1465: mean = mean / (double)( cnt); 

1466: variance = energy / (double)cnt - mean * mean; 

1467: 

1468: fprintf( out, "\n#\n# %s\n# Parameters: ", rtn); 

1469: for (i = 0; i < M; i++) 

1470: { 

1471: fprintf( out, "a%d=%.6f, ", i+1, a[i]); 

1472: } 

1473: 

1474: fprintf( out, "\n#\n# | chisq: %f", chisq); 

1475: fprintf( out, "\n# | mean of |deviates|: %f", mean); 

1476: fprintf( out, "\n# | variance of |deviates|: %f", variance); 

1477: fprintf( out, "\n# | goodnes of fit: %f", gfit); 

1478: fprintf( out, "\n# | number of outliers: %d", num_outliers); 

1479: 

1480: 

1481: /* estimate weights, but not in last iteration */ 

1482: if (!iter_stop && weight_mode) 

1483: { 

1484: fprintf( out, "\n#\n# enter weight estimation"); 

1485: /* estimation of weights based on absolute deviates */ 

1486: if (weight_mode == 1) 

1487: { 

1488: est_weights1( N * obs_dim, deviates_abs, weights, out); 

1489: } 

1490: /* no iterative weighting in weight_mode == 2 */ 

1491: 

1492: fprintf( out, "\n#\n# %s\n# i observ ", rtn); 

1493: fprintf( out, "calc deviates weights"); 

1494: 

1495: /* get mean of weights and output current values */ 

1496: mean_weights = 0; 

1497: cnt = 0; 


1499: { 

1500: mean_weights += weights[i]; /* compute sum of all weights */ 

1501: if (i < MAX_LINES) /* limits the number of output lines */ 

1502: { 

1503: fprintf( out, "\n# %2d %12.5f %12.5f %12.5f %14f", i, 

1504: obs[i], datac[i], deviates_abs[i], weights[i]); 

1505: } 

1506: if (weights[i] > 0.0) 

1507: { 

1508: cnt++; /* count used observations */ 

1509: } 

1510: } 

1511: /* mean of all weights > 0.; it is used later on */ 

1512: mean_weights /= (double)cnt; 

1513: 

1514: /* compare new and old weights */ 

1515: sum = 0; 


1517: { 

1518: /* watch changes of weights */ 

1519: sum += fabs( weights[i] - weights_old[i]); 

1520: weights_old[i] = weights[i]; /* remember for next 

1521: iteration */ 

1522: } 

1523: sum /= (double)N *obs_dim; /* mean difference in 

1524: weights */ 

1525: /* criterion of convergence */ 

1526: if (sum < 0.0001) 

1527: { 

1528: if (!iter_stop) 

1529: { 

1530: iter_final = 1; /* go to last iteration */ 

1531: } 

1532: iter_stop = 1; /* last iteration has been performed */ 

1533:


1534: fprintf( out, "\n#\n# convergence of weights"); 

1535: } /* if (sum < 0.0001)*/ 

1536: 

1537: if (iter == iter_wmax && !iter_stop) 

1538: { 

1539: fprintf( out, 

1540: "\n#\n# maximum number of iterations reached"); 

1541: fprintf( out, "\n# no convergence of weights"); 

1542: iter_final = 1; /* go to last iteration */ 

1543: } /* if (iter == iter_wmax && !iter_stop)*/ 

1544: } /* if (!iter_stop && weight_mode) */ 

1545: 

1546: #ifdef OUTPUT_DEVIATES 

1547: /* write deviates in separate file */ 

1548: if (iter_stop == 1) 

1549: { 

1550: char dev_name[500]; 

1551: int i, len; 

1552: FILE *out_dev; 

1553: 

1554: len = strlen(outname); 

1555: /* copy filename w/o extension */ 

1556: for (i = 0; i 0) 

1627: { 

1628: iter_final = 1; 

1629: if (forget_flag == 1) 

1630: { 

1631: fprintf( out, "\n#forget weights"); 

1632: /* set all weights to 1. */ 


1634: { 

1635: if (weights[i] > 0.0) 

1636: weights[i] = (float)1.0; 

1637: } 

1638: mean_weights = 1.0; 

1639: } 

1640: } 

1641: } /* if out_mode */ 

1642: } /* for iter */ 

1643: /* ----------------------------------------------------- */ 

1644: 

1645: /* 

1646: * evaluation of results 

1647: */ 

1648: 

1649: /* 

1650: * since the weights are already normalised to their 

1651: * mean value (w = k/sigma^2), gfit is also equal to 

1652: * the variance of observations 

1653: */ 

1654: 

1655: /* uncertainty in observations */ 

1656: uncertainty = sqrt( gfit/ mean_weights); 

1657: 

1658: fprintf( out, "\n#\n# evaluation of results"); 

1659: fprintf( out, "\n# number of outliers: %d", num_outliers); 

1660: fprintf( out, "\n# parameters:"); 

1661: for (j = 0; j < M; j++) 

1662: { 

1663: fprintf( out, " a%d=%f", j+1, a[j]); 

1664: } 

1665: fprintf( out, "\n# chi square.................: %.12G", chisq); 

1666: fprintf( out, "\n# goodness of fit............: %.12G", gfit); 

1667: fprintf( out, "\n# uncertainty in observations: %.12G", 

1668: uncertainty); 

1669: fprintf( out, "\n#\n# (co)variance of parameters:"); 

1670: { 

1671: int flag = 0; 

1672: for (i = 0; i < M; i++) 

1673: { 

1674: fprintf( out, "\n#"); 

1675: for (j = 0; j < M; j++) 

1676: { 

1677: fprintf( out, " %15.9G", covar[i][j]); 

1678: if ( (i == j) && (covar[i][j] < 0.) ) flag = 1; 

1679: } 

1680: } 

1681: if (flag) 

1682: { 

1683: printf( "\n# negative parameter variance"); 

1684: printf( "\n# probably ill-conditioned problem"); 

1685: if (!ls_flag->svd) 

1686: { 

1687: printf( "\n# solution is probably wrong"); 

1688: printf( "\n# disable option ’-s’"); 

1689: fprintf( out, "\n#### solution is probably wrong #"); 

1690: fprintf( out, "\n#### disable option ’-s’"); 

1691: } 

1692: fprintf( out, "\n#### negative parameter variance #"); 

1693: fprintf( out, "\n#### probably ill-conditioned problem #"); 

1694: } 

1695: } 

1696: fprintf( out, "\n\n# (co)variance of parameters multiplied"); 

1697: fprintf( out, " with goodness of fit"); 

1698: for (i = 0; i < M; i++) 

1699: { 

1700: fprintf( out, "\n#"); 

1701: for (j = 0; j < M; j++) 

1702: { 

1703: covar[i][j] *= gfit; 

1704: fprintf( out, " %12.6G", covar[i][j]); 

1705: } 

1706: } 

1707: fprintf( out, "\n\n# resulting uncertainty of parameters \n#"); 

1708: for (j = 0; j < M; j++) 

1709: { 

1710: if (covar[j][j] >= 0) 

1711: fprintf( out, " %15.9G", sqrt( covar[j][j] )); 

1712: else 

1713: fprintf( out, " ?? "); 

1714: } 

1715: 

1716: 

1717: /*------------------------------------------------------- 

1718: * post-processing 

1719: */ 

1720: 

1721: /* correction of parameters, before determination of relative 

1722: * uncertainty, because of phase shift 

1723: */ 

1724: if (type == COSINE) /* nonlinear cosine model */ 

1725: {


1726: if (a[1] < 0 ) /* avoid negative amplitude/radius */ 1822: fprintf( stderr, 

1727: { 

1823: "\n#### scaling not supported for ’-m %d’###\n", type); 

1728: a[1] = -a[1]; 

1824: } 

1729: a[2] = a[2] - 180; /* phase shift of 180 degrees */ 1825: /* unscale conditions for output */ 

1730: } 


1731: fprintf( out, "\n#\n# corrected Parameters\n# "); 1827: { 

1732: for (j = 0; j < M; j++) 

1828: cond[i] /= scale_fac; 

1733: { 

1829: } 

1734: fprintf( out, "a%d=%16.12G, ", j + 1, a[j]); 1830: } 

1735: } 

1831: 

1736: fprintf( out, "\n#"); 

1832: fprintf( out, "\n#\n# Final_Parameters "); 

1737: } 

1833: for (i = 0; i < M; i++) 

1738: else if (type == TRIGONOMETRIC2) 

1834: { 

1739: { 

1835: fprintf( out, "a%d= %.12G ", i+1, a[i]); 

1740: if (a[3] > 2*M_PI) a[3] -= 2*M_PI; 

1836: } 

1741: else if (a[3] < 0) a[3] += 2*M_PI; 

1837: if (type == POLYNOMIAL) 

1742: if (a[5] > 2*M_PI) a[6] -= 2*M_PI; 

1838: { 

1743: else if (a[5] < 0) a[6] += 2*M_PI; 

1839: fprintf( out, "\n# f%d(x) = %.14G", M, a[0]); 

1744: fprintf( out, "\n#\n# corrected Parameters\n# "); 1840: if (M > 1) 

1745: for (j = 0; j < M; j++) 

1841: { 

1746: { 

1842: fprintf( out, " + %.14G*x", a[1]); 

1747: fprintf( out, "a%d=%16.12G, ", j + 1, a[j]); 1843: } 

1748: } 

1844: for ( j = 2; j < M; j++) 

1749: fprintf( out, "\n#"); 

1845: { 

1750: } 

1846: fprintf( out, " + %.14G * x**%d", a[j], j); 

1751: 

1847: } 

1752: /* check the uncertainty in parameters */ 

1848: } 

1753: { 

1849: 

1754: int flag = 0; 

1850: /* map parameters to original model function */ 

1755: double val; 

1851: if (type == COSINE_LIN) 

1756: fprintf( out, "\n#"); 

1852: { 

1757: 

1853: double r0, phi0; 

1758: for (j = 0; j < M; j++) 

1854: 

1759: { 

1855: /* f(x|b) = b1 + r0 * cos( x - phi0) * f(x|a) = a1 + a2 * 

1760: if (covar[j][j] >= 0) 

1856: cos( x) + a3 * sin( x) */ 

1761: { 

1857: r0 = sqrt( a[1] * a[1] + a[2] * a[2]); /* radius a2 */ 

1762: val = sqrt( covar[j][j]) * 100. / fabs(a[j]); 1858: phi0 = 0; 

1763: fprintf( out, "%15.5G%%", val); 

1859: if (r0 > 0.) 

1764: if (val > 10) flag++; 

1860: { 

1765: } 

1861: double pc1, pc2, ps1, ps2; 

1766: else 

1862: double d11, d12, d21, d22; 

1767: { 

1863: 

1768: fprintf( out, " ?? %%"); 

1864: /* solve ambiguity of angles */ 

1769: } 

1865: pc1 = acos( a[1] / r0); /* 1st solution */ 

1770: } 

1866: pc2 = -pc1; /* 2nd solution */ 

1771: 

1867: ps1 = asin( a[2] / r0); /* 3rd solution */ 

1772: if (flag) 

1868: if (ps1 < 0) /* 4th solution */ 

1773: { 

1869: ps2 = -M_PI - ps1; 


1870: else 

1775: "\n# %d parameter(s) have relative high uncertainty !", 1871: ps2 = M_PI - ps1; 

1776: flag); 

1872: 

1777: fprintf( stdout, 

1873: d11 = fabs( pc1 - ps1); /* two of four must be equal */ 

1778: "\n# %d parameter(s) have relative high uncertainty !", 1874: d12 = fabs( pc1 - ps2); /* take differences */ 

1779: flag); 

1875: d21 = fabs( pc2 - ps1); 

1780: fprintf( stdout, "\n# Please inspect file %s !", outname); 1876: d22 = fabs( pc2 - ps2); 

1781: } 

1877: /* look for smallest difference */ 

1782: } 

1878: if (d11 < d12 && d11 < d21 && d11 < d22) 

1783: 

1879: { 

1784: if (num_outliers) 

1880: phi0 = 0.5 * (pc1 + ps1); 

1785: { 

1881: } 

1786: fprintf( stdout, "\n# detection of %d outliers!", num_outliers); 1882: if (d12 < d11 && d12 < d21 && d12 < d22) 

1787: } 

1883: { 

1788: 

1884: phi0 = 0.5 * (pc1 + ps2); 

1789: /* unscale the parameters */ 

1885: } 


1886: if (d21 < d11 && d21 < d12 && d21 < d22) 

1791: { 

1887: { 

1792: /* correction of parameters */ 

1888: phi0 = 0.5 * (pc2 + ps1); 

1793: fprintf( out, "\n# undo the scaling"); 

1889: } 


1890: if (d22 < d11 && d22 < d12 && d22 < d21) 

1795: { 

1891: { 


1892: phi0 = 0.5 * (pc2 + ps2); 

1797: for ( j = 1; j < M; j++) 

1893: } 

1798: { 

1894: a[1] = r0; 

1799: a[j] *= scale_fac; 

1895: a[2] = phi0 * 180 / M_PI; 

1800: } 

1896: } 

1801: break; 

1897: fprintf( out, "\n#\n# corrected Parameters "); 


1898: fprintf( out, "according to f(x)=b1+b2*cos(x-b3)\n# "); 

1803: for ( j = 1; j < M; j++) 

1899: for (j = 0; j < M; j++) 

1804: { 

1900: { 

1805: a[j] *= pow( scale_fac, (double)j); 

1901: fprintf( out, "b%d=%.9f, ", j + 1, a[j]); 

1806: } 

1902: } 

1807: break; 

1903: fprintf( out, "\n#"); 


1904: } 

1809: a[2] *= scale_fac; 

1905: else if (type == EXPONENTIAL2_LIN) 

1810: break; 

1906: { 


1907: /* convert observations back */ 

1812: a[0] /= scale_fac; 

1908: for (i = 0; i < N; i++) 

1813: a[1] /= scale_fac; 

1909: { 

1814: a[2] /= scale_fac; 

1910: obs[i] = exp( obs[i]); 

1815: break; 

1911: } 


1912: a[0] = exp( a[0]); 

1817: a[1] /= scale_fac; 

1913: 

1818: a[2] /= scale_fac; 

1914: fprintf( out, "\n#\n# corrected Parameters\n# "); 

1819: break; 

1915: for (j = 0; j < M; j++) 

1820: default: 

1916: { 

1821: fprintf( out, "\n# scaling not supported for ’-m %d’", type); 1917: fprintf( out, "a%d=%.9f, ", j + 1, a[j]);


1918: } 

1919: fprintf( out, "\n#\n# uncertainties of corrected Parameters "); 

1920: fprintf( out, "are not available yet\n# "); 

1921: 

1922: for (i = 0; i < N; i++) 

1923: { 

1924: /* get calculated data points dependent on corrected 


1926: datac[i] = fexpon2( i, cond, a); 

1927: } 

1928: } 

1929: else if (type == COORD_TRANSF) 

1930: { 

1931: /* print angle in degrees */ 

1932: 

1933: fprintf( out, " (%.4f degrees)", a[2] * 180. / M_PI); 

1934: } 

1935: else if (type == CIRCLE || type == CIRCLE_TLS) 

1936: { 

1937: /* evaluate result in terms of mean squared distance 

1938: * of points to circle 

1939: */ 

1940: double eval = 0, d, delta; 

1941: 

1942: cnt = 0; 

1943: for ( i = 0; i < N; i++) 

1944: { 

1945: if (weights[i] > 0.) 

1946: { 

1947: d = euclid_dist( (cond[2*i]-a[0]), (cond[2*i+1]-a[1])); 

1948: /* orthogonal distance to curve of circle */ 

1949: delta = d - a[2]; 

1950: eval += delta * delta; /* sum up squared distances */ 

1951: cnt++; 

1952: } 

1953: } 

1954: fprintf( out, "\n# mean squared distance to circle: %.6f\n#", 

1955: eval/cnt); 

1956: } 

1957: else if (type == CIRCLE_LIN) 

1958: { 

1959: double a1, a2, a3; 

1960: double eval = 0, d, delta; 

1961: /* convert parameters back */ 

1962: a1 = 0.5 * a[0]; 

1963: a2 = 0.5 * a[1]; 

1964: a3 = sqrt( a1*a1 + a2*a2 - a[2]); 

1965: 

1966: fprintf( out, "\n#\n# corrected Parameters\n# "); 

1967: fprintf( out, "a1=%.9f, ", a1); 

1968: fprintf( out, "a2=%.9f, ", a2); 

1969: fprintf( out, "a3=%.9f", a3); 

1970: fprintf( out, "\n#"); 

1971: 

1972: /* evaluate result in terms of mean squared distance 

1973: * of points to circle 

1974: */ 

1975: cnt = 0; 

1976: for ( i = 0; i < N; i++) 

1977: { 

1978: if (weights[i] > 0.) 

1979: { 

1980: d = euclid_dist( (cond[2*i]-a1), (cond[2*i+1]-a2)); 

1981: /* orthogonal distance to curve of circle */ 

1982: delta = d - a3; 

1983: eval += delta * delta; /* sum up squared distances */ 

1984: cnt++; 

1985: } 

1986: } 

1987: fprintf( out, "\n# mean squared distance to circle: %.6f\n#", 

1988: eval/cnt); 

1989: } 

1990: 

1991: /* ----------------------------------------- */ 

1992: fprintf( out, "\n# "); 


1994: { 

1995: fprintf( out, "cond%d ", j + 1); 

1996: } 

1997: fprintf( out, "observed fitted weight uncertainty "); 

1998: fprintf( out, "glob.uncertainty difference"); 

1999: 

2000: /* 

2001: * estimated weight should be w = 1/sigma^2 

2002: * thus estimated uncertainty is sigma = 1/ sqrt(weight) 

2003: * make nice output 

2004: */ 

2005: if (type == COORD_TRANSF) 

2006: { 

2007: fprintf( out, " observed2 fitted2 weight2 "); 

2008: fprintf( out, "uncertainty2 glob.uncertainty2 difference2"); 

2009: } 

2010: 

2011: /* 

2012: * output of final results 

2013: */ 

2014: for (i = 0; i < (int)N * obs_dim; i += obs_dim) 

2015: { 

2016: double uncert; 

2017: 

2018: fprintf( out, "\n"); 


2020: { 

2021: fprintf( out, "%12.6f ", 

2022: cond[cond_dim * (i / obs_dim) + j]); 

2023: } 

2024: /* put both fitting results for fixed conditions in same row 

2025: */ 

2026: for (o = 0; o < (int)obs_dim; o++) 

2027: { 

2028: int k; 

2029: k = i + o; 

2030: if (weights[k] > 0) 

2031: uncert = 1. / sqrt( weights[k]); 

2032: else 

2033: uncert = 9999.; 

2034: fprintf( out, "%12.6f ", obs[k]); 

2035: fprintf( out, "%12.6f %11.6f %12.6f %.6f", 

2036: datac[k], weights[k], uncert, uncertainty); 

2037: fprintf( out, "%+12.6f ", (obs[k] - datac[k])); 

2038: } 

2039: /* make a empty line to enforce plotting a mesh */ 

2040: if (type == LINEAR && M == 3 && 

2041: ( cond[cond_dim * i] != cond[cond_dim * (i + 1)])) 

2042: { 

2043: /* plane approximation */ 


2045: } 

2046: if (type == QUAD_SURFACE && 

2047: ( cond[cond_dim * i+1] != cond[cond_dim * (i + 1)+1])) 

2048: { 

2049: /* surface approximation */ 


2051: } 

2052: } 


2054: 

2055: endfunc: 

2056: printf( "\n"); 

2057: fflush( stdout); 

2058: 

2059: free_vector( &weights); 

2060: free_vector( &weights_old); 

2061: free_vector( &obs); 

2062: free_vector( &datac); 

2063: free_vector( &cond); 

2064: free_vector( &deviate); 

2065: free_vector( &deviates_abs); 

2066: free_vector( &deltasq); 

2067: free_matrix( &jacob); 

2068: free_matrix( &covar); 

2069: 

2070: if (argc > 2) 

2071: { 

2072: if (out != NULL) 

2073: fclose( out); 

2074: } 

2075: if (in != NULL) 


2077: 

2078: if (err) 

2079: { 

2080: fprintf( stderr, "\n failed.\n"); 

2081: return err; 

2082: } 

2083: else 

2084: { 

2085: fprintf( stderr, "\n ready.\n"); 

2086: return 0; 

2087: } 

2088: } 

2089: 

2090: /*--------------------------------------------------------------- 

2091: * is_data_line() 

2092: *--------------------------------------------------------------*/ 

2093: int 

2094: is_data_line( char *line, int N) 

2095: { 

2096: int i; 

2097: 

2098: /* scan leading white spaces */ 

2099: for (i = 0; i < N; i++) 

2100: { 

2101: if (line[i] != ’ ’ /* space */ 

2102: && line[i] != ’\t’ /* tab */ 

2103: ) 

2104: break; 

2105: } 

2106: /* check next character */ 

2107: if (line[i] == ’#’) /* comment */ 

2108: { 

2109: return 0;


2110: } 

2111: if (line[i] == ’\n’) /* newline */ 

2112: { 

2113: return 0; 

2114: } 

2115: if (line[i] == ’\r’) /* carrige return (Windows) */ 

2116: { 

2117: return 0; 

2118: } 

2119: 

2120: return 1; /* is data line */ 

2121: } 

2122: 

2123: /*--------------------------------------------------------------- 

2124: * get_nth_field() 

2125: * scans a string up to the desired column (field) 

2126: *--------------------------------------------------------------*/ 

2127: char * 

2128: get_nth_field( char *line, int n) 

2129: { 

2130: char *ptr = NULL; 

2131: int ch, i = 0, loop_flag, cnt, field_flag; 

2132: 

2133: if (line == NULL) 

2134: return ptr; 

2135: 

2136: loop_flag = 1; 

2137: field_flag = 0; 

2138: cnt = 0; 

2139: do 

2140: { 

2141: ch = line[i]; 

2142: if (ch == ’\0’) 

2143: { 

2144: loop_flag = 0; 

2145: break; 

2146: } 

2147: if (!field_flag) 

2148: { 

2149: if (ch != ’ ’ && ch != ’\t’ && ch != ’\r’ && ch != ’\n’) 

2150: { 


2152: cnt++; 

2153: if (cnt == n) 

2154: { 

2155: /* desired field is found */ 

2156: ptr = &( line[i]); 

2157: loop_flag = 0; 

2158: } 

2159: } 

2160: } 

2161: else 

2162: { 

2163: /* search next white space */ 

2164: if (ch == ’ ’ || ch == ’\t’ || ch == ’\r’ || ch == ’\n’) 

2165: { 


2167: } 

2168: } 

2169: i++; 

2170: } while (loop_flag); 

2171: return ptr; 

2172: } 

0: /***************************************************************** 

1: * 

2: * File........: prototypes.h 

3: * Function....: proto typing for different functions 


5: * last changes: 27.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef PROTO_H 

15: #define PROTO_H 

16: 

17: 

18: typedef struct { 

19: int linear; /* linear model */ 

20: int svd; /* special computation for linear models */ 

21: int LM; /* 0 .. Gaus-Newton, 1 .. Levenberg-Marquardt */ 

22: int chisq_target; /* indicates that ’chisq_target’ was set */ 

23: int trueH; /* use true Hessian matrix */ 

24: } LS_FLAG; 

25: 

26: /* least squares routine */ 

27: int 

28: ls( double (*funct) (int,double*,double*), 


30: int,int,int,double*,double*), 


32: int,int,int,int,double*,double*), 

33: int (*init)(int, double*,double*,double*, 

34: unsigned char*,FILE*), 

35: int N, int M, double *obs, double *cond, double **jacob, 

36: double *weights, double *a, unsigned char* a_flag, 

37: int algo_mode, LS_FLAG *ls_flag, 

38: double chisq_target, double **covar, FILE *out); 

39: 

40: int svd_inversion( int N, double **normal, double **normal_i, 

41: FILE *out); 

42: int 

43: solve_lin( int N, int M, double *obs, double *weights, 

44: double **jacob, double **covar, double *a, 

45: FILE *out); 

46: 

47: /* parsing of command-line parameters */ 

48: char* get_nth_field( char *line, int n); 

49: int is_data_line( char *line, int N); 

50: 

51: /* matrix inversion */ 

52: int singvaldec( double **a, int N, int M, double w[], double **v); 

53: void backsub_LU( double **lu, int N, int *indx, double back[]); 

54: int decomp_LU( double **normal, int M, int *indx, int *s); 

55: void heap_sort_d_(unsigned long N, double ra[], int idx[]); 

56: void heap_sort_d(unsigned long N, double ra[]); 

57: 

58: /* estimation of weights */ 

59: void est_weights1( int N, double *deltasq, 

60: double *weights, FILE *out); 

61: void est_weights2( int N, double *cond, double *obs, 

62: double *weights, int obs_per_bin, FILE *out); 

63: int outlier_detection1( int N, double sigma_y, double *deltasq, 

64: double *weights, double nu, FILE *out); 

65: int outlier_detection2( int N, double *deltasq, 

66: double *weights, FILE *out); 

67: 

68: void 

69: ls_straightline( 

70: int N, /* number of entries */ 

71: double cond[], /* vector of conditions */ 

72: double obs[], /* vector of observations */ 

73: double a[] /* container for parameters to be estimated */ 

74: ); 

75: 

76: #endif 

0: /***************************************************************** 

1: * 

2: * File........: ls.c 

3: * Function....: least squares with alternative matrix inversion 


5: * last changes: 05.02.2008, 28.09.2009, 25.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 

17: #include 








25: #include 

26: #else 

27: #include 

28: #define random rand 

29: #endif 

30: 

31: long ITERAT_MAX; 

32: double NU_FAC; 

33: //#define QDEBUG 

34: 

35: /*--------------------------------------------------------------- 

36: * ls() 

37: * 

38: *--------------------------------------------------------------*/ 

39: int 

40: ls( double (*funct) (int,double*,double*), 


42: int,int,int,double*,double*), 


44: int,int,int,int,double*,double*), 

45: int (*init)(int, double*,double*,double*, 

46: unsigned char*,FILE*), 

47: int N, int M, double *obs, double *cond, double **jacob,


48: double *weights, double *a, unsigned char* a_flag, 

49: int algo_mode, LS_FLAG *ls_flag, 

50: double chisq_target, double **covar, FILE *out) 

51: { 

52: char *rtn = "ls"; 

53: int err = 0, i, j, k, n; 

54: int Nfree; 

55: int stop_flag; /* supports convergence criterion */ 

56: int iter_cnt; /* counter for nonlinear iterations */ 

57: int iter_max=ITERAT_MAX; /* maximum number of iterations */ 

58: double **cofac = NULL; /* cofactor matrix for matrix 

59: inversion */ 

60: double **normal = NULL; /* N = J^(T) * W * J */ 

61: double **normal_i = NULL; /* inverse of N */ 

62: double **tmpmat = NULL; /* temporary matrix */ 

63: double *tmpvec = NULL; /* J^(T) * W * r */ 

64: double *datac = NULL; /* calculated values based on parameters 

65: */ 

66: double *da = NULL; /* parameter update deltasq a */ 

67: double *deltasq = NULL; /* = w * [obs - f(x|a) ] ^2 */ 

68: double chisq, det, tmp, residual, deriv_2nd, variance; 

69: double min_chisq=0, *min_a=NULL; /* remember best result */ 

70: double mu_fac = 0; /* factor for Levenberg-Marquardt */ 

71: double max_diag; /* maximum value of Njj */ 

72: double diag[M_MAX]; /* vector of diagonal of Normal matrix */ 

73: 


75: "\n# -- %s - start ------------------------------", rtn); 

76: 

77: /* 

78: * allocate memory 

79: */ 

80: 

81: /* normal matrix N = J^(T) * W * J, its inverse */ 

82: normal = matrix( M, M); 

83: normal_i = matrix( M, M); 

84: 

85: cofac = matrix( M, M); /* cofactor matrix */ 

86: tmpvec = vector( M); /* container for J^(T) * W * G */ 

87: datac = vector( N); /* calculated data using f(x|a) */ 

88: deltasq = vector( N); /* remaining differences */ 

89: da = vector( M); /* model parameter update */ 

90: min_a = vector( M); /* remember best parameter set */ 

91: 

92: iter_cnt = 1; 

93: if (!ls_flag->linear) 

94: { 

95: /* initialise minimum (best) values */ 

96: for (j = 0; j < M; j++) 

97: { 

98: min_a[j] = a[j]; 

99: } 

100: min_chisq = -1.; 

101: } 

102: else 

103: { 

104: /* nothing to iterate for linear models */ 

105: } 

106: 

107: if (ls_flag->svd && ls_flag->linear) 

108: { 

109: /* This function exploits the SVD for solving linear problems. 

110: * Inverting of the normal matrix is not required, which 

111: * sometimes runs into problems when inverting the normal matrix 

112: * of difficult model functions as, for example, polynomials of 

113: * high order. It returns the estimated parameters in a and the 

114: * covariance matrix covar 

115: */ 

116: err = solve_lin( N, M, obs, weights, jacob, covar, a, out); 

117: if (err) 

118: { 


120: "\n\n### Unable to solve this linear system!"); 

121: fprintf( stderr, "\n Abort!\n"); 


123: } 

124: } 

125: else 

126: { 

127: mu_fac = 0.0001; /* initial factor for Levenberg-Marquard */ 

128: 

129: /* iteration if nonlinear */ 

130: do 

131: { 

132: /* feedback on console */ 

133: printf( "\r\t\t %4d", iter_cnt); 

134: 

135: #ifdef QDEBUG 


137: "\n#\n#== Obs == Weight == Jacobian ================="); 

138: for (i = 0; i < N; i++) 

139: { 

140: fprintf( out, "\n# %8.1f %8.6f", obs[i], weights[i]); 

141: for (j = 0; j < M; j++) 

142: { 

143: fprintf( out, " %8.5f", jacob[i][j]); 

144: } 

145: } 

146: #endif 

147: 

148: /* 

149: * calculate normal matrix N 

150: * N = J^(T) * W * J 

151: */ 

152: max_diag = 0; 

153: for (j = 0; j < M; j++) 

154: { 

155: for (i = 0; i < M; i++) 

156: { 

157: normal[j][i] = 0.; 

158: for (n = 0; n < N; n++) 

159: { 

160: normal[j][i] += jacob[n][j] * jacob[n][i] * weights[n]; 

161: } 

162: 

163: } 

164: /* only for nonlinear models of importance: 

165: * get maximum value on main diagonal 

166: */ 

167: diag[j] = normal[j][j]; 

168: if (max_diag < normal[j][j]) 

169: { 

170: max_diag = normal[j][j]; 

171: } 

172: } 


174: fprintf( out, "\n#\n#== normal matrix ================="); 

175: for (i = 0; i < M; i++) 

176: { 

177: fprintf( out, "\n# "); 

178: for (j = 0; j < M; j++) 

179: { 

180: fprintf( out, " %12.2f", normal[i][j]); 

181: } 

182: } 

183: fflush( out); 

184: #endif 

185: 

186: /* K = J^(T) * W * r */ 


188: { 

189: /* tmpvec = J^(T) * W * y */ 

190: for (j = 0; j < M; j++) 

191: { 

192: tmpvec[j] = 0.; 

193: for (n = 0; n < N; n++) 

194: { 

195: tmpvec[j] += jacob[n][j] * obs[n] * weights[n]; 

196: } 

197: } 

198: } 

199: else /* nonlinear */ 

200: { 

201: /* tmpvec = J^(T) * W * r */ 

202: /* r contains residuals */ 

203: for (j = 0; j < M; j++) 

204: { 

205: tmpvec[j] = 0.; 

206: for (i = 0; i < N; i++) 

207: { 

208: residual = obs[i] - funct( i, cond, a); 

209: tmpvec[j] += jacob[i][j] * residual * weights[i]; 

210: } 

211: } 

212: if (errno) 

213: { 

214: perror( "\n### "); 

215: fprintf( stderr, " errno = %d", errno); 

216: fprintf( out, "\n Error in computation (%d), ", errno); 

217: fprintf( out, "see standard output (console)\n"); 

218: err = errno; 


220: } 

221: 

222: /* add Levenberg-Marquardt term on main diagonal */ 


224: { 

225: for (j = 0; j < M; j++) 

226: { 

227: normal[j][j] += mu_fac * max_diag; 

228: } 

229: } 

230: /* add Q term ==> true Hessian matrix */ 

231: if (ls_flag->trueH) 

232: { 

233: for (i = 0; i < N; i++) 

234: { 

235: residual = obs[i] - funct( i, cond, a); 

236: for (j = 0; j < M; j++) 

237: { 

238: for (k = 0; k < M; k++) 

239: {


240: deriv_2nd = funct_deriv2( funct, j, k, M, i,cond,a); 

241: normal[j][k] += deriv_2nd * residual; 

242: } 

243: } 

244: } 

245: } 

246: } 

247: 

248: /* 

249: * inversion of normal matrix 

250: * (cofactor method, LU decomposition, or SVD) 

251: * 

252: */ 

253: if (algo_mode == 0) 

254: { 

255: switch (M) 

256: { 

257: case 1: 

258: /* y = a1 */ 

259: /* df/da1 = 1 */ 

260: det = normal[0][0]; /* determinant */ 

261: if (det != 0) 

262: { 

263: cofac[0][0] = 1.; 

264: } 

265: else 

266: { 

267: err = errmsg( ERR_IS_ZERO, rtn, "determinant", 0); 


269: } 

270: break; 

271: 

272: case 2: 

273: det = determinant_2x2( normal); /* determinant */ 

274: coFactor_2x2( normal, cofac); /* coFactor matrix */ 

275: break; 

276: 

277: case 3: 

278: det = determinant_3x3( normal); /* determinant */ 

279: coFactor_3x3( normal, cofac); /* coFactor matrix */ 

280: break; 

281: case 4: /* need 4 Parameters */ 

282: det = inverse_4x4( normal, cofac); 

283: break; 

284: case 5: /* need 5 Parameters */ 

285: det = inverse_5x5( normal, cofac); 

286: break; 

287: 

288: default: 


290: fprintf( stderr, "for standard matrix inversion"); 

291: err = errmsg( ERR_CALL, rtn, 

292: "check command-line parameters ", 0); 


294: } /* switch */ 

295: if (fabs( det) > 1.0e-20) 

296: { 

297: for (i = 0; i < M; i++) 

298: { 

299: for (j = 0; j < M; j++) 

300: { 

301: normal_i[i][j] = cofac[i][j] / det; 

302: } 

303: } 

304: } 

305: else 

306: { 

307: err = errmsg( ERR_IS_ZERO, rtn, "determinant", 0); 


309: "\n Please, consider to use option ’-a 1’ ! "); 


311: "\n#\n### determinant is zero ! "); 


313: "\n### Please, consider to use option ’-a 1’ !\n#"); 


315: } 

316: } 

317: else if (algo_mode == 1) /* SVD */ 

318: { 

319: err = svd_inversion( M, normal, normal_i, out); 

320: if (err) 

321: { 

322: /* take best parameter */ 

323: for (j = 0; j < M; j++) 

324: { 

325: a[j] = min_a[j]; 

326: } 

327: break; 

328: } 

329: } /* algo_mode SVD */ 

330: else if (algo_mode == 2) /* LU decomposition */ 

331: { 

332: int *indx = NULL, s; 

333: double *column = NULL; 

334: 

335: indx = ivector( M); 

336: column = vector( M); 

337: 

338: /* decompose the matrix */ 

339: err = decomp_LU( normal, M, indx, &s); 

340: if (err) 

341: { 

342: if (err == 6) 

343: fprintf( out, ERR_IS_ZERO_MSG, "decomp_LU", "’max_element’"); 

344: free_ivector( &indx); 

345: free_vector( &column); 


347: } 

348: /* find inverse by back-substitution of columns */ 

349: for (j = 0; j < M; j++) 

350: { 

351: for (i = 0; i < M; i++) 

352: column[i] = 0.0; 

353: column[j] = 1.0; 

354: 

355: backsub_LU( normal, M, indx, column); 

356: 

357: for (i = 0; i < M; i++) 

358: normal_i[i][j] = column[i]; 

359: } 

360: free_vector( &column); 

361: free_ivector( &indx); 

362: } /* LU decomp */ 

363: 



366: "\n#\n#== inverse normal matrix ================="); 

367: for (i = 0; i < M; i++) 

368: { 

369: fprintf( out, "\n# "); 

370: for (j = 0; j < M; j++) 

371: { 

372: fprintf( out, " %12.2f", normal_i[i][j]); 

373: } 

374: } 

375: fflush( out); 

376: #endif 

377: 

378: /* final matrix multiplication to get parameter updates */ 

379: for (j = 0; j < M; j++) 

380: { 

381: da[j] = 0.; 

382: for (i = 0; i < M; i++) 

383: { 

384: da[j] += normal_i[j][i] * tmpvec[i]; 

385: } 

386: } 


388: { 

389: /* linear: parameter = update */ 

390: for (j = 0; j < M; j++) 

391: { 

392: a[j] = da[j]; 

393: } 

394: } 


396: { 

397: stop_flag = 0; 

398: 

399: if (iter_cnt < 3000) 

400: { 

401: fprintf( out, "\n#\n# Iteration of least squares: %d", 

402: iter_cnt); 

403: fprintf( out, "\n# Updates: "); 

404: } 

405: for (j = 0; j < M; j++) 

406: { 

407: if (iter_cnt < 3000) 

408: fprintf( out, "da%d=%.14G, ", j+1, da[j]); 

409: /* if changes are negigible */ 

410: if ( //fabs( da[j]) < fabs( a[j]) * TOL || 

411: fabs(da[j]) < TOL) /* case a[j] == 0 */ 

412: stop_flag++; 

413: } 

414: 

415: /* adjust parameters */ 

416: for (j = 0; j < M; j++) 

417: { 

418: /* adjust */ 

419: a[j] += da[j]; 

420: } 

421: 

422: /* update Jacobian matrix for nonlinear models */ 

423: for (i = 0; i < N; i++) 

424: { 

425: for (j = 0; j < M; j++) 

426: { 


428: } 

429: } 

430: } 

431:


432: /* compute weighted and squared differences chi-squared */ 

433: chisq = 0.0; 

434: Nfree = -M; /* reduce by number of parameters */ 


436: { 

437: for (i = 0; i < N; i++) 

438: { 



441: datac[i] = 0.0; 

442: for (j = 0; j < M; j++) 

443: { 

444: datac[i] += a[j] * jacob[i][j]; 

445: } 

446: tmp = fabs( obs[i] - datac[i]); 


448: deltasq[i] = tmp * tmp; 


450: if (weights[i] > 0.) 

451: Nfree++; 

452: } 

453: } 


455: { 

456: for (i = 0; i < N; i++) 

457: { 



460: datac[i] = funct( i, cond, a); 

461: 

462: tmp = fabs( obs[i] - datac[i]); 


464: deltasq[i] = tmp * tmp; 


466: if (weights[i] > 0.) 

467: Nfree++; 

468: } 

469: if (min_chisq < 0) /* initial value */ 

470: { 

471: min_chisq = chisq; 

472: } 

473: else if (min_chisq > chisq) 

474: { 

475: /* new result is closer to minimum */ 

476: min_chisq = chisq; 

477: /* copy parameters */ 

478: for (j = 0; j < M; j++) 

479: { 

480: min_a[j] = a[j]; 

481: } 

482: if (mu_fac > 2. * DBL_EPSILON) 

483: mu_fac *= 0.5; /* decrease Lev-Mar parameter */ 

484: /* improvement */ 

485: } 

486: else 

487: { 


489: { 

490: if (iter_cnt < 3000) 

491: fprintf( out, "\n#\n# rejection, chisq=%.14G", 

492: chisq); 

493: if (mu_fac < 1.e+8) 

494: { 

495: /* increase Lev-Mar parameter */ 

496: /* should not be a multiple of decreasing factor */ 

497: /* Thurber.dat was not satisfied with 3. */ 

498: mu_fac *= 9.; 

499: } 

500: /* restore old parameters */ 

501: for (j = 0; j < M; j++) 

502: { 

503: a[j] = min_a[j]; 

504: } 

505: } 

506: else 

507: { 

508: if (iter_cnt < 3000) 

509: fprintf( out, "\n#\n# uphill, chisq=%.14G", chisq); 

510: } 

511: } 

512: } /* if nonliner */ 

513: 

514: variance = min_chisq / (double)Nfree; 

515: 

516: if (!ls_flag->linear) 

517: { 

518: if (iter_cnt < 3000) 

519: { 

520: fprintf( out, "\n#\n# Parameters: "); 

521: for (i = 0; i < M; i++) 

522: { 

523: fprintf( out, "a%d=%.12G, ", i+1, a[i]); 

524: } 

525: 

526: fprintf( out, "\n#\n# chisq: %.14G", min_chisq); 

527: if (ls_flag->LM) /* Lev-Marquardt method */ 

528: { 

529: fprintf( out, "\t mu_fac: %e", mu_fac); 

530: } 

531: } 

532: printf( " chisq = %.15G ", min_chisq); 

533: /* set break condition */ 

534: if (min_chisq == 0.0) stop_flag = M; 

535: fflush(stdout); 

536: 

537: /* test of convergence */ 

538: if (stop_flag == M) /* all adjustments are negligible */ 

539: { 

540: fprintf( out, "\n#\n# convergence after %d iterations", 



543: { 

544: fprintf( out, "\n# check target (%f) ", chisq_target); 

545: /* check, whether maximum target error is reached */ 

546: if (chisq chisq_target) */ 

590: else 

591: break; 

592: } /* if (stop_flag == M) */ 

593: } /* if (!ls_flag->linear) */ 

594: 

595: iter_cnt++; 

596: if (!ls_flag->linear && iter_cnt >= iter_max) 

597: { 


599: for (j = 0; j < M; j++) 

600: { 

601: a[j] = min_a[j]; 

602: } 


604: "\n\n no convergence after %d iterations", 


606: fprintf( stderr, "\n chisq x 1000 = %f", 

607: chisq * 1000); 


609: "\n#\n# no convergence after %d iterations", 


611: fprintf( out, "\n# chisq x 1000 = %f", 

612: chisq * 1000); 

613: 

614: /* ### needs more elaboration ! #####*/ 


616: { 

617: fprintf( out, "\n# check target (%f) ", chisq_target); 

618: /* check, whether maximum target error is reached */ 

619: if (chisq


624: /* no, lets re-initialise the parameters */ 

625: fprintf( out, "\n# re-initialise parameters "); 

626: /* modifies only values NOT given on command line! */ 

627: init( N, obs, cond, a, a_flag, out); 

628: /* update Jacobian matrix for nonlinear models */ 

629: for (i = 0; i < N; i++) 

630: { 

631: for (j = 0; j < M; j++) 

632: { 


634: } 

635: } 

636: iter_cnt = 1; 

637: min_chisq = -1; 

638: mu_fac = 0.0001; 

639: } 

640: else 

641: break; 

642: } 

643: } 

644: while (!ls_flag->linear); 

645: /* iterate if nonlinear */ 

646: } 

647: 

648: /* 

649: * determination of covariance matrix 

650: * if not used solve_lin() 

651: */ 

652: if (!ls_flag->svd || !ls_flag->linear) 

653: { 

654: /* compute normal w/o mu !!!! */ 

655: for (j = 0; j < M; j++) 

656: { 

657: for (i = 0; i < M; i++) 

658: { 

659: normal[j][i] = 0.; 

660: for (n = 0; n < N; n++) 

661: { 

662: normal[j][i] += jacob[n][j] * jacob[n][i] * weights[n]; 

663: } 

664: } 

665: } 

666: 

667: /* inversion 

668: * for ill-conditioned problems (e.g. polynomials of high 

669: * order) the inversion of the normal matrix might fail 

670: * 

671: */ 

672: err = svd_inversion( M, normal, covar, out); 

673: if (err) 

674: { 


676: for (j = 0; j < M; j++) 

677: { 

678: a[j] = min_a[j]; 

679: } 

680: } 

681: } 

682: endfunc: 


684: "\n# -- %s - end ------------------------------", rtn); 

685: 

686: free_vector( &min_a); 

687: free_vector( &da); 

688: free_vector( &tmpvec); 

689: free_vector( &datac); 

690: free_vector( &deltasq); 

691: free_matrix( &normal); 

692: free_matrix( &normal_i); 

693: free_matrix( &cofac); 

694: free_matrix( &tmpmat); 

695: 


697: } 

0: /***************************************************************** 

1: * 

2: * File........: ls_straightline.c 

3: * Function....: least-squares solution for straight lines 


5: * last changes: 20.10.2007 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: 

17: /*--------------------------------------------------------------- 

18: * ls_straightline() 

19: *--------------------------------------------------------------*/ 

20: void 

21: ls_straightline( 

22: int N, /* number of entries */ 

23: double cond[], /* vector of conditions */ 

24: double obs[], /* vector of observations */ 

25: double a[] /* container for parameters to be estimated */ 

26: ) 

27: { 

28: int i; 

29: double Sxx, Sx, Sy, Sxy, tmp; 

30: 

31: Sx = Sxx = Sy = Sxy = 0.; 

32: for (i = 0; i < N; i++) 

33: { 

34: Sx += cond[i]; 

35: Sy += obs[i]; 

36: Sxx += cond[i] * cond[i]; 

37: Sxy += cond[i] * obs[i]; 

38: } 

39: 

40: 

41: tmp = N * Sxx - Sx * Sx; 

42: a[0] = (Sxx * Sy - Sx * Sxy) / tmp; 

43: a[1] = (N * Sxy - Sx * Sy) / tmp; 

44: } 

0: /***************************************************************** 

1: * 

2: * File........: solve_lin.c 

3: * Function....: solving linear least squares via SVD 


5: * last changes: 25.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 





21: 

22: //#define QDEBUG 

23: 

24: /*--------------------------------------------------------------- 

25: * solve_lin() 

26: * 

27: *--------------------------------------------------------------*/ 

28: int 

29: solve_lin( int N, int M, double *obs, double *weights, 

30: double **jacob, double **covar, double *a, 

31: FILE *out) 

32: { 

33: char *rtn = "solve_lin"; 

34: int i, j, n, err = 0; 

35: double thresh, smax; 


37: double **tmpmat2 = NULL; /* temporary matrix */ 

38: double *s = NULL; /* singular values */ 

39: double **V = NULL; /* V matrix */ 

40: double **WJ = NULL; /* W*J matrix */ 

41: 

42: V = matrix( M, M); /* V matrix for SVD */ 

43: s = vector( M); /* singular values for SVD */ 

44: WJ = matrix( N, M); /* temporary matrix */ 

45: tmpmat = matrix( M, M); /* temporary matrix */ 

46: tmpmat2 = matrix( M, N); /* temporary matrix */ 

47: 

48: /* WJ = sqrt(W)*J */ 

49: for (i = 0; i < N; i++) 

50: { 

51: for (j = 0; j < M; j++) 

52: { 

53: WJ[i][j] = sqrt(weights[i]) * jacob[i][j]; 

54: } 

55: } 

56: 


58: fprintf( out, "\n#\n#== Weight * Jacobian ================="); 

59: for (i = 0; i < N; i++) 

60: { 

61: fprintf( out, "\n# "); 

62: for (j = 0; j < M; j++) 

63: { 

64: fprintf( out, " %8.5f", WJ[i][j]); 

65: } 

66: } 

67: #endif 

68:


69: /* do the SVD */ 

70: err = singvaldec( WJ, N, M, s, V); 

71: if (err) 

72: { 

73: free_matrix( &V); 

74: free_vector( &s); 

75: free_matrix( &WJ); 


77: free_matrix( &tmpmat2); 


79: } 

80: 


82: fprintf( out, "\n#\n#== U ================="); 

83: for (i = 0; i < N; i++) 

84: { 


86: for (j = 0; j < M; j++) 

87: { 

88: fprintf( out, " %8.5f", WJ[i][j]); 

89: } 

90: } 

91: fprintf( out, "\n#\n#== V ================="); 

92: for (i = 0; i < M; i++) 

93: { 


95: for (j = 0; j < M; j++) 

96: { 

97: fprintf( out, " %8.5f", V[i][j]); 

98: } 

99: } 

100: #endif 

101: 

102: /* check the singular values */ 

103: smax = 0.0; 

104: for (j = 0; j < M; j++) 

105: { 

106: if (s[j] > smax) smax = s[j]; 

107: } 

108: if (smax < TOL_S) 

109: { 


111: "\n###\n### singular matrix, smax = %f",smax); 



114: 

115: err = 1; 


117: } 

118: else if (smax > 1.e+31) 

119: { 


121: "\n###\n### degraded matrix, smax = %f",smax); 



124: err = 1; 


126: } 

127: 

128: thresh = MIN( TOL_S * smax, TOL_S); 

129: 

130: fprintf( out, "\n#\n# singular values (thresh = %.14G)\n# ", 

131: thresh); 

132: for (j = 0; j < M; j++) 

133: { 

134: fprintf( out, "s%d=%.14G, ", j+1, s[j]); 

135: } 

136: 

137: /* invert singular values */ 

138: for (j = 0; j < M; j++) 

139: { 

140: /*


35: int i; 

36: int *idx_dev=NULL; 

37: double *dev_sort = NULL; 

38: double lambda_L, lambda_L2, lambda_L2_inv; 

39: double max_deviate, bound; 

40: const double kappa_L = 0.05; 

41: 

42: fprintf( out, "\n# -- %s - start ----------------------", rtn); 

43: /* 

44: * memory allocation 

45: */ 

46: idx_dev = ivector( N); 

47: dev_sort = vector( N); 

48: 

49: /* ascending sorting of deviates and indices */ 

50: memcpy( dev_sort, deviates, sizeof(double) * N); 

51: for (i = 0; i < N; i++) 

52: { 

53: if (weights[i] == 0.) 

54: { 

55: /* weights can already be set to zero by purpose 

56: * in the linearisation process 

57: * corresponding deviates must be ignored somehow 

58: */ 

59: dev_sort[i] = 0.; 

60: } 

61: } 

62: /* sorting of absolute deviates and of an index array */ 

63: heap_sort_d_( N, dev_sort, idx_dev); 

64: 

65: /* get max. of all absolute deviates */ 

66: max_deviate = dev_sort[N-1]; 

67: 


69: fprintf( out, "\n# max_deviate: %f", max_deviate); 

70: 

71: /* 

72: * check values 

73: */ 

74: if (max_deviate == 0.0) 

75: { 

76: fprintf( out, "\n#\n# all deviates are equal to zero!"); 

77: fprintf( out, "\n# nothing to weight, perfect fit!"); 

78: } 

79: else 

80: { 

81: /* 

82: * initialisation of threshold 

83: */ 

84: /* keep half of the values with equal weights */ 

85: lambda_L = dev_sort[N/2]; 

86: bound = max_deviate * kappa_L; 

87: /* ensure minimum value for this threshold */ 

88: if (lambda_L < bound) 

89: { 

90: /* value for worst case, stabilising LS */ 

91: lambda_L = bound; 

92: } 

93: lambda_L2 = lambda_L * lambda_L; 

94: fprintf( out, "\n# lambda_L = %f", lambda_L); 

95: 

96: /* 

97: * do the weighting 

98: */ 

99: /* inspect unsorted data */ 

100: lambda_L2_inv = 1. / lambda_L2; 

101: for ( i = 0; i < N; i++) 

102: { 

103: if (weights[i] > 0.) 

104: { 

105: /* weights can already be set to zero by purpose 

106: * in the linearisation process 

107: */ 

108: if (deviates[i] < lambda_L) 

109: { 

110: /* fixed weight */ 

111: weights[i] = lambda_L2_inv; 

112: } 

113: else 

114: { 

115: /* adapted weight */ 

116: weights[i] = 1. / (deviates[i] * deviates[i]); 

117: } 

118: } 

119: } 

120: 

121: } /* if max_deviate > 0 */ 

122: 

123: #ifdef NORM_W 

124: /* may not used when evaluating the goodness-of-fit */ 

125: { 

126: int cnt; 

127: double sum; 

128: /* Normalisation of weights */ 

129: sum = 0.; 

130: cnt = 0; 

131: for (i = 0; i < N; i++) 

132: { 

133: if (weights[i]) 

134: { 

135: sum += weights[i]; 

136: cnt++; 

137: } 

138: } 

139: for (i = 0; i < N; i++) 

140: { 

141: weights[i] = weights[i] * cnt / sum; 

142: } 

143: } 

144: #endif 

145: 

146: /* output information for debugging */ 

147: fprintf( out, "\n#\n# dev_sort[i] weights[ idx[i] ]"); 

148: for (i = 0; i < N && i < MAX_LINES_W; i++) 

149: { 

150: fprintf( out, "\n#%4d %14.9e %16.8f", i, 

151: dev_sort[i], weights[ idx_dev[i] ]); 

152: } 

153: 

154: free_vector( &dev_sort); 

155: free_ivector( &idx_dev); 

156: fprintf( out, "\n# -- %s - end -------------------------",rtn); 

157: } 

158: 

159: /*--------------------------------------------------------------- 

160: * est_weights2() 

161: * 

162: * weights estimation based on binning 

163: * 

164: *--------------------------------------------------------------*/ 

165: void 

166: est_weights2( int N, double *cond, double *obs, 

167: double *weights, int obs_per_bin, FILE *out) 

168: { 

169: char *rtn="est_weights2"; 

170: int i, n, m0, m, b, cnt; 

171: int num_bins; 

172: int *idx=NULL; 

173: double w, var, diff, a[2], last_cond; 

174: double *cond_sort=NULL; 

175: double *bin_cond = NULL; 

176: double *bin_obs = NULL; 

177: 


179: "\n# -- %s - start ------------------------------", rtn); 

180: 

181: /* vector of conditions in a single bin */ 

182: bin_cond = vector( obs_per_bin); 

183: /* vector of observations in a single bin */ 

184: bin_obs = vector( obs_per_bin); 

185: 

186: /* determine the number of bins */ 

187: num_bins = N / obs_per_bin; 

188: /* one bin for the rest */ 

189: if (N % obs_per_bin) num_bins++; 

190: 

191: cond_sort = vector(N); /* array for sorted conditions */ 

192: idx = ivector( N); /* vector for sorted indices */ 

193: 

194: /* copy all conditions */ 

195: memcpy( cond_sort, cond, sizeof(double)*N); 

196: 

197: /* ascending sorting of conditions and indices */ 

198: heap_sort_d_( N, cond_sort, idx); 

199: 

200: /* initialise last condition value; just for output */ 

201: last_cond = cond_sort[0]; 

202: 

203: fprintf( out, "\n# Number of bins: %d", num_bins); 

204: fprintf( out, "\n# bin number_of_observations a1 "); 

205: fprintf( out, "a2 last_cond variance"); 

206: 

207: n = 0; /* n... already used observations */ 

208: 

209: /* for all bins */ 

210: for ( b = 0; b < num_bins; b++) 

211: { 

212: if ( N-n < obs_per_bin/ 2) 

213: { 

214: /* applies for the last 2 bins: 

215: * if too less remaining observation, 

216: * then let bins overlap 

217: */ 

218: m0 = n - obs_per_bin/2; 

219: obs_per_bin = N-m0; 

220: } 

221: else m0 = n; 

222: 

223: /* 

224: * piece-wise linear approximation per bin 

225: */ 

226:


227: /* copy bin related values */ 

228: cnt = 0; 

229: for ( i = 0, m = m0; i < obs_per_bin && m < N; i++, m++) 

230: { 

231: bin_cond[i] = cond_sort[m]; 

232: /* bin_cond[i] = cond[ idx[m] ]; same */ 

233: bin_obs[i] = obs[ idx[m] ]; 

234: cnt++; 

235: } 

236: /* determine parameters for piece-wise linear fit */ 

237: ls_straightline( cnt, bin_cond, bin_obs, a); 

238: 

239: /* determine uncertainty */ 

240: m = m0; 

241: var = 0.; 

242: for ( i = 0; i < obs_per_bin && m < N; i++, m++) 

243: { 

244: diff = obs[ idx[m] ] - (a[0] + a[1] * bin_cond[i]); 

245: var += diff * diff; 

246: } 

247: var = var / (double)cnt; 

248: if (var > 0.) 

249: w = 1. / var; 

250: else w = 0.; 


252: "\n# %4d %10d %14.4e %14.4e %14.4e %12.3e", 

253: b, i, a[0], a[1], bin_cond[i-1], var); 

254: fprintf( stdout, 

255: "\n g%d(x) = (x > %.4f && x < %.4f) ? %.4f +x* %.4f : 0", 

256: b, last_cond, bin_cond[i-1], a[0], a[1]); 

257: 

258: last_cond = bin_cond[i-1]; 

259: 

260: /* klone determined bin weight for all corresponding 

261: * observations 

262: */ 

263: for ( i = 0, m = m0; i < obs_per_bin && m < N; i++, m++) 

264: { 

265: weights[ idx[m] ] = w; 

266: } 

267: n = m; /* update number of already used observations */ 

268: } 

269: 

270: free_vector( &bin_cond); 

271: free_vector( &bin_obs); 

272: free_vector( &cond_sort); 

273: free_ivector( &idx); 


275: "\n# -- %s - end ------------------------------", rtn); 

276: } 

0: /***************************************************************** 

1: * 

2: * File........: outlier_detection.c 

3: * Function....: outlier detection 


5: * last changes: 03.07.2009 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 





21: #include "erf.h" 


23: 

24: /* disables output from outlier detection */ 

25: /* #define COMPTEST */ 

26: 

27: /*--------------------------------------------------------------- 

28: * outlier_detection1() 

29: * 

30: * outlier_detection based on standard deviation of obs. 

31: * plus re-weighting 

32: *--------------------------------------------------------------*/ 

33: int 

34: outlier_detection1( int N,/* number of observations */ 

35: double sigma_y, /* standard uncertainty */ 

36: double *deviates, /* absolute deviates */ 

37: double *weights, /* weights of observations */ 

38: double nu, /* Chauvenet’s parameter */ 


40: { 

41: char *rtn = "outlier_detection1"; 

42: int i, err; 

43: int count_outlier; /* counts the outliers */ 

44: double erfval; 

45: double lambda_O; 

46: double kappa_O; 

47: 

48: #ifndef COMPTEST 


50: "\n# -- %s - start ------------------------------", rtn); 

51: #endif 

52: 

53: if (nu > 0. && nu < 1.0) 

54: { 

55: /* set threshold according to Chauvenet’s criterion, 

56: * if nu is inside correct range 

57: */ 

58: err = erfinv( 1 - nu / N, &erfval); 

59: if (err) return 0; 

60: kappa_O = sqrt(2.) * erfval; 

61: } 

62: else 

63: { 

64: kappa_O = 4; /* use fixed conservative threshold */ 

65: } 

66: 

67: /* set breakdown point (threshold) */ 

68: lambda_O = sigma_y * kappa_O; 

69: 


71: fprintf( out, "\n# sigma_y = %f, kappa_O = %f, lambda_O = %f", 

72: sigma_y, kappa_O, lambda_O); 

73: #endif 

74: 

75: /* compare all deviates with threshold */ 

76: count_outlier = 0; 

77: for (i = 0; i < N; i++) 

78: { 

79: if (deviates[i] >= lambda_O) /* take as outlier */ 

80: { 

81: weights[i] = 0.0; 

82: count_outlier++; 

83: } 

84: } 

85: 



88: "\n# -- %s - end ------------------------------", rtn); 

89: #endif 

90: 

91: return count_outlier; 

92: } 

93: 

94: /*--------------------------------------------------------------- 

95: * outlier_detection2() 

96: * 

97: * cluster-based outlier detection (ClubOD) 

98: * 

99: *--------------------------------------------------------------*/ 

100: int 

101: outlier_detection2( int N,/* number of observations */ 

102: double *deviates, /* absolute deviates */ 

103: double *weights, /* weights of observations */ 


105: { 

106: char *rtn="outlier_detection2"; 

107: int i, j; 

108: int start_i; /* range for outlier search */ 

109: int stop; /* flag */ 

110: int cntZ; /* counter for distances being equal to zero */ 

111: int count_outlier; /* counts the outliers */ 

112: int *idx_dev=NULL; 

113: double relation, relation_max; 

114: double dist_loc, dist_ave; 

115: double *dist_glob = NULL; 

116: double *dist_all = NULL, dist_all_max; 

117: double *dist_sort = NULL; 

118: double *dev_sort = NULL; 

119: double lambda_O; 

120: double dist_thresh; 

121: double kappa1; /* kappa to be used */ 

122: 

123: /* number of observations for determination of kappa_1 */ 

124: const int NN[19]= 

125: { 8, 11, 16, 23, 32, 45, 64, 91, 128, 181, 256, 

126: 362, 512, 724, 1024, 1448, 2048, 2896, 4096 

127: }; 

128: /* kappa_1 values according to NN[] */ 

129: const double ka1[19]= 

130: { 7.3, 7.7, 10.1, 11.8, 14.1, 16.7, 20.3, 25.2, 31.5, 39.6, 51.3, 

131: 66.6, 86.4, 112, 150, 198.0, 261.0, 351.0, 

132: }; 

133: const double kappa2 = 2.0; 

134: /* proportion of observations that should belong to the 

135: * bulk of good observations 

136: */ 

137: const double kappa4 = 0.6; 

138: 

139: #ifndef COMPTEST


140: fprintf( out, "\n# -- %s - start ----------------------", rtn); 

141: #endif 

142: 

143: /* 

144: * memory allocation 

145: */ 

146: idx_dev = ivector( N); /* index array */ 

147: dev_sort = vector( N); /* sorted absolute deviations */ 

148: dist_all = vector( N); /* distances between deviations */ 

149: dist_sort = vector( N); /* sorted distances */ 

150: dist_glob = vector( N); /* global distances */ 

151: 

152: /* 

153: * determination of kappa_1 in dependent on number of 

154: * observations (threshold for suspicious distances) 

155: */ 

156: if (N > NN[0]) 

157: { 

158: if (N >= NN[18]) 

159: kappa1 = ka1[18]; 

160: else 

161: { 

162: for (i = 1; i < 19; i++) 

163: { 

164: if ( N 0; i--) 

186: { 

187: dist_all[i] = dev_sort[i] - dev_sort[i-1]; 

188: } 

189: 

190: /* dummy */ 

191: dist_all[0] = 0.; 

192: 

193: /* ascending sorting of distances in order to get 

194: * the median distance 

195: */ 

196: memcpy( dist_sort, dist_all, sizeof(double) * N); 

197: heap_sort_d( N, dist_sort); 

198: 



201: fprintf( out, "\n# kappa1: %f", kappa1); 

202: fprintf( out, "\n# kappa2: %f", kappa2); 

203: #endif 

204: 

205: /* keep major part as good observations */ 

206: start_i = (int) ceil( kappa4 * N); 

207: 

208: /* determination of dist_glob, 

209: * separate value for each deviate 

210: */ 

211: { 

212: double arg, wj, sum_wj; 

213: /* for all observations, which have to be tested */ 

214: for ( i = start_i; i < N; i++) 

215: { 

216: /* compute weighted average as d_glob, 

217: * 2* sigma = N, variance = N*N/4 

218: */ 

219: arg = -0.5 * 4. / (N * N); 

220: sum_wj = 0.; 

221: dist_glob[i] = 0; 

222: 

223: /* take all distances into account, exclude [0] */ 

224: for (j = 1; j < i; j++) 

225: { 

226: wj = exp( j*j * arg); 

227: /* dist_all[] sorted according increasing deviates 

228: * largest fac2 for distance of highes deviate 

229: */ 

230: dist_glob[i] += dist_all[i-j] * wj; 

231: sum_wj += wj; 

232: } 

233: if (sum_wj > 0.) 

234: dist_glob[i] /= sum_wj; /* normalise by sum */ 

235: else 

236: dist_glob[i] = 0.0; 

237: } 

238: } 

239: 

240: if (dist_glob[start_i] == 0.0) /* check for smallest deviate */ 

241: { 


243: fprintf( out, "\n#\n# all distances are equal to zero!"); 

244: fprintf( out, "\n# nothing to weight, perfect fit!"); 

245: #endif 

246: } 

247: else 

248: { 

249: /* 

250: * initialisation of thresholds 

251: */ 

252: /* reset breakdown point */ 

253: lambda_O = 0; 

254: 

255: /* 

256: * search for suspicious distance 

257: */ 

258: 



261: "\n#\n# n deviate d[n] d_glob"); 

262: fprintf( out, " d[n]/d_glob d_loc d[n]/d_loc "); 


264: "\n# -----------------------------------------------"); 

265: fprintf( out, "-------------------------------"); 

266: #endif 

267: 

268: stop = 0; 

269: relation_max = 0.; 

270: dist_all_max = 0; 

271: 

272: /* check only upper portion of sorted deviates */ 

273: for (i = start_i; i < N && !stop; i++) 

274: { 

275: dist_thresh = dist_glob[i] * kappa1; 

276: 


278: fprintf( out, "\n# %3d\t %.3e\t %.3e", i, dev_sort[i], 

279: dist_all[i]); 

280: fprintf( out, "\t %8.2e\t %8.2f", 

281: dist_glob[i], dist_all[i] / dist_glob[i]); 

282: #endif 

283: 

284: /* if global condition is fulfilled, then check also local 

285: * one 

286: */ 

287: if (dist_all[i] >= dist_thresh) 

288: { 

289: double arg, wj, sum_wj; 

290: 

291: /* determination of local distance value, 

292: * 12* sigma = N, variance = N*N/144 

293: */ 

294: arg = -0.5 * 144. / (N * N); 

295: cntZ = 0; 

296: sum_wj = 0; 

297: dist_ave = 0; 

298: for (j = 1; j < i; j++) 

299: { 

300: wj = exp( j*j * arg); 

301: /* largest fac2 for closest neighbour */ 

302: dist_ave += dist_all[i-j] * wj; 

303: sum_wj += wj; 

304: /* count distances equal to zero */ 

305: if (dist_all[i-j] == 0.0) cntZ++; 

306: } 

307: if (sum_wj) 

308: dist_loc = dist_ave / sum_wj; 

309: else 

310: dist_loc = 0.0; 

311: 

312: /* exception handling, if more than 50% of distances 

313: * are equal to zero 

314: */ 

315: if (cntZ 0.0) 

319: relation = dist_all[i] / dist_loc; 

320: else 

321: relation = 0.0; 

322: } 

323: else /* exception handling */ 

324: { 

325: /* current distance is > zero, border case */ 

326: if (dist_all[i] > 0) 

327: { 

328: relation = kappa2; 

329: } 

330: else 

331: {


332: /* not considered further */ 

333: relation = 0; 

334: } 

335: } 

336: 


338: fprintf( out, "\t %.3e", dist_loc); 

339: fprintf( out, "\t %f", relation); 

340: #endif 

341: 

342: /* check second condition */ 

343: if (relation >= kappa2) 

344: { 

345: /* outliers found */ 

346: 


348: fprintf( out, " *"); 

349: #endif 

350: /* look for the highest relation (change in distances)*/ 

351: if (relation > relation_max) 

352: { 


354: fprintf( out, " ##"); 

355: #endif 

356: /* deviate of current position is taken as 

357: * breakdown point 

358: */ 

359: lambda_O = dev_sort[i]; 

360: /* store current releation as maximal one */ 

361: relation_max = relation; 

362: /* store current distance as maximum distance */ 

363: dist_all_max = dist_all[i]; 

364: } 

365: else if (relation == relation_max) 

366: { 

367: /* can happen, for instance, if relation was several 

368: * times equal to kappa2 

369: */ 

370: /* if equal, then take teh one corresponding to the 

371: * larger absolute deviate 

372: */ 

373: if (dist_all[i] >= dist_all_max) 

374: { 

375: /* take the one with higher distance */ 


377: fprintf( out, " ##"); 

378: #endif 

379: lambda_O = dev_sort[i]; 

380: relation_max = relation; 

381: dist_all_max = dist_all[i]; 

382: } 

383: } 

384: /*stop = 1; */ 

385: } 

386: } /* if (dist_sort[i] > dist_thresh) */ 

387: } /* for i */ 

388: 

389: /* check whether there was at least one relation 

390: * higher than kappa2 

391: */ 


393: if (relation_max > 0.0) 

394: { 

395: fprintf( out, "\n#\n# outliers detected !"); 

396: fprintf( out, "\t lambda_O = %f", lambda_O); 

397: } 

398: #endif 

399: 

400: /* inspect unsorted data, set weights of outliers to zero*/ 

401: count_outlier = 0; 

402: if (lambda_O > 0) 

403: { 

404: for ( i = 0; i < N; i++) 

405: { 

406: if (deviates[i] >= lambda_O) /* outliers */ 

407: { 

408: weights[i] = 0.; 

409: count_outlier++; 

410: } 

411: } 

412: } 

413: } /* if (enough observations) */ 

414: 

415: /* output information for debugging */ 


417: fprintf( out, "\n#\n# n deviate "); 

418: fprintf( out, " d[n] weights[ idx[i] ]"); 

419: for (i = 0; i < N && i < MAX_LINES_W; i++) 

420: { 

421: fprintf( out, "\n#%4d %14.9e %14.9e %16.8f", i, 

422: dev_sort[i], dist_all[i], 

423: weights[ idx_dev[i] ]); 

424: } 

425: #endif 

426: 

427: free_vector( &dist_glob); 

428: free_vector( &dev_sort); 

429: free_vector( &dist_sort); 

430: free_vector( &dist_all); 

431: free_ivector( &idx_dev); 

432: 


434: fprintf( out, "\n# -- %s - end -----------------------",rtn); 

435: #endif 

436: 

437: return count_outlier; 

438: }

S.3 Model functions 23 

S.3 Model functions 

0: /***************************************************************** 

1: * 

2: * File........: functions.c 

3: * Function....: model functions and their derivatives 


5: * last changes: 07.05.2008, 23.06.2009, 26.10.2009, 18.02.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 

17: #include 

18: #include 




22: 

23: #define DEG2RAD M_PI/180. 

24: 

25: /* for reasons of compatibility all derivative functions 

26: * have the same parameter list 

27: * xxx_deriv( double (*funct)(int,double*,double*), 

28: * int i, int j, int M, double *cond, double *a) 

29: * 

30: * However, the only function requiring (*funct) is the 

31: * generic function f_deriv() 

32: */ 

33: 

34: /*--------------------------------------------------------------- 

35: * fconstant_deriv() 

36: *--------------------------------------------------------------*/ 

37: double 

38: fconstant_deriv( double (*funct)(int,double*,double*), 

39: int i, int j, int M, double *cond, double *a) 

40: { 

41: return 1.0; /* derivation of a1 */ 

42: } 

43: 

44: /*--------------------------------------------------------------- 

45: * flin_deriv() 

46: * f(x|a) = a1 + SUM_j a_j * x_j 

47: *--------------------------------------------------------------*/ 

48: double 

49: flin_deriv( double (*funct)(int,double*,double*), 


51: { 

52: /* i ... number of current observation */ 

53: if (j == 0) 

54: return 1.; /* derivation of a1 */ 

55: else 

56: return cond[(M-1) * i + j - 1]; 

57: } 

58: 

59: /*--------------------------------------------------------------- 

60: * fcosine_deriv() 

61: * f(x|a) = a1 + a2 * cos( x) + a3 * sin( x) 

62: *--------------------------------------------------------------*/ 

63: double 

64: fcosine_deriv( double (*funct)(int,double*,double*), 


66: { 

67: if (j == 0) 


69: else if (j == 1) 

70: return (cos( cond[i] * DEG2RAD)); 

71: else 

72: return (sin( cond[i] * DEG2RAD)); 

73: } 

74: 

75: /*--------------------------------------------------------------- 

76: * fcosine_nonlin() 

77: * f(x|a) = a1 + a2 * cos( x - a3) 

78: *--------------------------------------------------------------*/ 

79: double 

80: fcosine_nonlin( int i, double *cond, double *a) 

81: { 

82: return a[0] + a[1] * cos( (cond[i] - a[2]) * DEG2RAD); 

83: } 

84: 

85: /*--------------------------------------------------------------- 

86: * fcosine_nonlin_deriv() 

87: * f(x|a) = a1 + a2 * cos( x - a3) 

88: *--------------------------------------------------------------*/ 

89: double 

90: fcosine_nonlin_deriv( double (*funct)(int,double*,double*), 


92: { 

93: if (j == 0) 


95: else if (j == 1) 

96: return (cos( (cond[i] - a[2]) * DEG2RAD)); 

97: else 

98: return (a[1] * sin( (cond[i] - a[2]) * DEG2RAD)); 

99: } 

100: 

101: /*--------------------------------------------------------------- 

102: * fcosine_trend() 

103: * f(x|a) = a1 + a2 * x + a3 * cos( x - a4) 

104: *--------------------------------------------------------------*/ 

105: double 

106: fcosine_trend( int i, double *cond, double *a) 

107: { 

108: return a[0] + a[1] * cond[i] + a[2] * cos( cond[i] - a[3]); 

109: } 

110: 

111: /*--------------------------------------------------------------- 

112: * fcosine_trend_deriv() 

113: * f(x|a) = a1 + a2 * x + a3 * cos( x - a4) 

114: *--------------------------------------------------------------*/ 

115: double 

116: fcosine_trend_deriv( double (*funct)(int,double*,double*), 


118: { 

119: if (j == 0) 


121: else if (j == 1) 

122: return cond[i]; 

123: else if (j == 2) 

124: return cos( cond[i] - a[3]); 

125: else 

126: return (a[2] * sin( cond[i] - a[3])); 

127: } 

128: 

129: /*--------------------------------------------------------------- 

130: * ftrigonometric1() 

131: * f(x|a) = a1 + a2*cos(a3*x-a4) 

132: *--------------------------------------------------------------*/ 

133: double 

134: ftrigonometric1( int i, double *cond, double *a) 

135: { 

136: return a[0] + a[1] * cos( a[2]*cond[i] - a[3]); 

137: } 

138: 

139: /*--------------------------------------------------------------- 

140: * ftrigonometric2() 


142: *--------------------------------------------------------------*/ 

143: double 

144: ftrigonometric2( int i, double *cond, double *a) 

145: { 

146: return a[0] + a[1] * cos( a[2]*cond[i] - a[3]) 

147: + a[4] * cos( 2*a[2]*cond[i] - a[5]); 

148: } 

149: 

150: /*--------------------------------------------------------------- 

151: * flogarithmic() 

152: * f(x|a) = log( a1 * x) 

153: *--------------------------------------------------------------*/ 

154: double 

155: flogarithmic( int i, double *cond, double *a) 

156: { 

157: assert( a[0] * cond[i] > 0.); 

158: return log( a[0] * cond[i]); 

159: } 

160: 

161: /*--------------------------------------------------------------- 

162: * flogarithmic_deriv() 

163: * f(x|a) = log( a1 * x) 

164: *--------------------------------------------------------------*/ 

165: double 

166: flogarithmic_deriv( double (*funct)(int,double*,double*), 


168: { 

169: /* correction of values, which are outside the domain of 

170: definition */ 

171: /* if (a[0] y’= 1/a */ 

173: if (a[0]


190: /*--------------------------------------------------------------- 

191: * fexponential() 

192: * f(x|a) = a1 + a2 * exp( a3 * x) 

193: *--------------------------------------------------------------*/ 

194: double 

195: fexponential( int i, double *cond, double *a) 

196: { 

197: return (a[0] + a[1] * exp( a[2] *cond[i])); 

198: } 

199: 

200: /*--------------------------------------------------------------- 

201: * fexponential_deriv() 

202: * f(x|a) = a1 + a2 * exp( a3 * x) 

203: *--------------------------------------------------------------*/ 

204: double 

205: fexponential_deriv( double (*funct)(int,double*,double*), 


207: { 

208: if (j == 0) 

209: return 1.; 

210: else if (j == 1) 

211: return (exp( a[2] * cond[i])); 

212: else 

213: { 

214: if (a[2] < 0) /* limitation of parameter space */ 

215: { 

216: return (cond[i] * a[1] * exp( a[2] * cond[i])); 

217: } 

218: else 

219: return cond[i] * a[1]; /* set a[2] virtually to zero */ 

220: } 

221: } 

222: 

223: 

224: /*--------------------------------------------------------------- 

225: * fpolynomial() 

226: * f(x|a) = sum_{j=1}^M aj * x^(j-1) 

227: *--------------------------------------------------------------*/ 

228: double fpolynomial( int i, double *cond, double *a) 

229: { 

230: long j; 

231: double y, xj; 

232: /* since M ist not passed as a parameter, we assume maximal 

233: * number. oveflous a[j] must be zero ! 

234: */ 

235: y = a[0]; 

236: xj = 1.; 

237: for ( j = 1; j < M_MAX; j++) 

238: { 

239: xj *= cond[i]; 

240: y += a[j] * xj; 

241: } 

242: return y; 

243: } 

244: 

245: /*--------------------------------------------------------------- 

246: * fpolynomial_deriv() 

247: * f(x|a) = sum_{j=1}^M aj * x^(j-1) 

248: *--------------------------------------------------------------*/ 

249: double 

250: fpolynomial_deriv( double (*funct)(int,double*,double*), 


252: { 

253: return pow( cond[i], (double)j); 

254: } 

255: 

256: /*--------------------------------------------------------------- 

257: * fgen_laplace() 

258: * f(x|a) = a1 * exp( -|x|â2 * a3) 

259: *--------------------------------------------------------------*/ 

260: double 

261: fgen_laplace( int i, double *cond, double *a) 

262: { 

263: return a[0] * exp( -pow( fabs( cond[i]), a[1]) * a[2]); 

264: } 

265: 

266: /*--------------------------------------------------------------- 

267: * fgen_laplace_deriv() 

268: * f(x|a) = a1 * exp( -|x|â2 * a3) 

269: *--------------------------------------------------------------*/ 

270: double 

271: fgen_laplace_deriv( double (*funct)(int,double*,double*), 


273: { 


275: a[1] = 1E-10; 

276: if (j == 0) 

277: { 

278: /* y = a0 * exp( -|x|â1 * a2) 

279: * dy/da0 = exp( -a2 * |x|â1) 

280: */ 

281: return exp( -a[2] * pow( fabs( cond[i]), a[1])); 

282: } 

283: else if (j == 1) 

284: { 

285: /* y = a0 * exp( -a2 * |x|â1) 

286: * dy/da1 = a0 * exp( -a2 * |x|â1) * -a2 * |x|â1 * ln|x| 

287: */ 

288: return -a[0] * exp( -a[2] * pow( fabs( cond[i]), a[1])) * 

289: a[2] * 

290: pow( fabs( cond[i]), a[1]) * log( fabs( cond[i])); 

291: } 

292: else 

293: { 

294: /* y = a0 * exp( -a2 * |x|â1) 

295: * dy/da2 = a0 * exp( -a2 * |x|â1) * - |x|â1 

296: */ 

297: return -a[0] * exp( -a[2] * pow( fabs( cond[i]), a[1])) * 

298: pow( fabs( cond[i]), a[1]); 

299: } 

300: } 

301: 

302: /*--------------------------------------------------------------- 

303: * fexpon2() 

304: * f(x|a) = a1 * exp( a2 * x) 

305: *--------------------------------------------------------------*/ 

306: double 

307: fexpon2( int i, double *cond, double *a) 

308: { 

309: return (a[0] * exp( a[1] * cond[i])); 

310: } 

311: 

312: /*--------------------------------------------------------------- 

313: * fexpon2_deriv() 

314: * f(x|a) = a1 * exp( a2 * x) 

315: *--------------------------------------------------------------*/ 

316: double 

317: fexpon2_deriv( double (*funct)(int,double*,double*), 


319: { 

320: if (j == 0) 

321: { 


323: { 

324: return (exp( a[1] * cond[i])); 

325: } 

326: else 

327: return 1; /* set a[1] virtually to zero */ 

328: } 

329: else 

330: { 


332: { 

333: return (cond[i] * a[0] * exp( a[1] * cond[i])); 

334: } 

335: else 

336: return cond[i] * a[0]; /* set a[1] virtually to zero */ 

337: } 

338: } 

339: 

340: /*--------------------------------------------------------------- 

341: * fgauss2() 

342: * f(x|a) = a1 * exp( a3 * (x-a2)^2) + 

343: * a4 * exp( a6 * (x-a5)^2) 

344: *--------------------------------------------------------------*/ 

345: double 

346: fgauss2( int i, double *cond, double *a) 

347: { 

348: double tmp1 = cond[i] - a[1]; 


350: return (a[0] * exp( a[2] * tmp1 * tmp1) + 

351: a[3] * exp( a[5] * tmp2 * tmp2) ); 

352: } 

353: 

354: /*--------------------------------------------------------------- 

355: * fgauss1() 

356: * f(x|a) = a1 * exp( a3 * (x-a2)^2) 

357: *--------------------------------------------------------------*/ 

358: double 

359: fgauss1( int i, double *cond, double *a) 

360: { 


362: return a[0] * exp( a[2] * tmp1 * tmp1); 

363: } 

364: 

365: /*--------------------------------------------------------------- 

366: * fgauss_deriv() 

367: * f(x|a) = a1 * exp( a3 * (x-a2)^2) 

368: *--------------------------------------------------------------*/ 

369: double 

370: fgauss_deriv( double (*funct)(int,double*,double*), 


372: { 


374: 


376: a[1] = 1E-10; 

377: if (a[2] > 0) /* limitation of parameter space */ 

378: a[2] = -1E-10; 

379: if (j==0) 

380: /* y = a1 * exp( a3 * (x-a2)^2) 

381: *dy/da1 = exp( a3 * (x-a2)^2)


382: */ 

383: return exp( a[2] * tmp1 * tmp1); 

384: else if (j==1) 

385: /* y = a1 * exp( a3 * (x-a2)^2) 

386: *dy/da2 =-a1 * exp( a3 * (x-a2)^2) * a3 * 2 * (x-a2) 

387: */ 

388: return -a[0] * exp( a[2] * tmp1 * tmp1) * a[2] * 

389: 2 * tmp1; 

390: else 

391: /* y = a1 * exp( a3 * (x-a2)^2) 

392: *dy/da3 = a1 * exp( a3 * (x-a2)^2) * (x-a2)^2 

393: */ 

394: return a[0] * exp( a[2] * tmp1 * tmp1) * tmp1*tmp1; 

395: } 

396: 

397: /*--------------------------------------------------------------- 

398: * fgauss1_deriv2() 

399: * f(x|a) = a1 * exp( a3 * (x-a2)^2) 

400: * siehe http://www.mathetools.de/differenzieren/ 

401: *--------------------------------------------------------------*/ 

402: double 

403: fgauss_deriv2( double (*funct)(int,double*,double*), 

404: int j, int k, int M, int i, double *cond, double *a) 

405: { 


407: 

408: if (a[2] > 0) /* limitation of parameter space */ 

409: a[2] = -1E-10; 

410: 

411: if (j==0) 

412: { 

413: if (k == 0) 

414: /* y = a1 * exp( a3 * (x-a2)^2) 

415: *dy/da1 = exp( a3 * (x-a2)^2) 

416: *d2y/d2a1 = 0 

417: */ 

418: return 0; 

419: else if (k == 1) 

420: /* y = a1 * exp( a3 * (x-a2)^2) 

421: *dy/da1 = exp( a3 * (x-a2)^2) 

422: *d2y/da1da2 = -exp( a3 * (x-a2)^2) * a3 * 2 * (x-a2) 

423: */ 

424: return -exp( a[2] * tmp1*tmp1) * a[2] * 2 * tmp1; 

425: else 

426: /* y = a1 * exp( a3 * (x-a2)^2) 

427: *dy/da1 = exp( a3 * (x-a2)^2) 

428: *d2y/da1da3 = exp( a3 * (x-a2)^2) * (x-a2)^2 

429: */ 

430: return exp( a[2] * tmp1*tmp1) * tmp1* tmp1; 

431: } 

432: else if (j==1) 

433: { 

434: if (k == 0) 

435: /* y = a1 * exp( a3 * (x-a2)^2) 


437: *dy/da2da1 =-exp( a3 * (x-a2)^2) * a3 * 2 * (x-a2) 

438: */ 

439: return -exp( a[2] * tmp1*tmp1) * a[2] * 2 * tmp1; 

440: else if (k == 1) 

441: /* y = a1 * exp( a3 * (x-a2)^2) 


443: *dy/da2 =-2*a1*a3 * exp( a3 * (x-a2)^2) * (x-a2) 

444: *dy/d2a2=-2*a1*a3 * exp( a3 * (x-a2)^2)* (-1) + 

445: 2*a1*a3 * exp( a3 * (x-a2)^2)* a3* 2*(x-a2) * (x-a2) 

446: *dy/d2a2= 4*a1*a3^2 * exp( a3 * (x-a2)^2)*(x-a2)^2 + 

447: * 2*a1*a3 * exp( a3 * (x-a2)^2) 

448: */ 

449: return 4*a[0]*a[2]*a[2] * exp( a[2] * tmp1*tmp1)*tmp1*tmp1 + 

450: 2*a[0]*a[2] * exp( a[2] * tmp1*tmp1); 

451: else 

452: /* y = a1 * exp( a3 * (x-a2)^2) 

453: *dy/da2 =-2*a1*a3 * exp( a3 * (x-a2)^2) * (x-a2) 

454: *dy/da2da3 =-2*a1*(x-a2)^3* a3 * exp( a3 * (x-a2)^2) - 

455: * 2 * a1* (x-a2)*exp( a3 * (x-a2)^2) 

456: */ 

457: return 2*a[0] * tmp1*tmp1*tmp1 * a[2] * exp( a[2] * tmp1*tmp1) 

458: -2 * a[0]* tmp1 * exp( a[2] * tmp1*tmp1); 

459: } 

460: else 

461: { 

462: if (k == 0) 

463: /* y = a1 * exp( a3 * (x-a2)^2) 


465: *dy/da3da1 = exp( a3 * (x-a2)^2) * (x-a2)^2 

466: */ 

467: return exp( a[2] * tmp1*tmp1) * tmp1* tmp1; 

468: else if (k == 1) 

469: /* y = a1 * exp( a3 * (x-a2)^2) 


471: *dy/da2da3 =-2*a1*(x-a2)^3* a3 * exp( a3 * (x-a2)^2) - 

472: * 2 * a1* (x-a2)*exp( a3 * (x-a2)^2) 

473: */ 

474: return 2*a[0] * tmp1*tmp1*tmp1 * a[2] * exp( a[2] * tmp1*tmp1) 

475: -2 * a[0]* tmp1 * exp( a[2] * tmp1*tmp1); 

476: else 

477: /* y = a1 * exp( a3 * (x-a2)^2) 


479: *dy/d2a3= a1 * exp( a3 * (x-a2)^2) * (x-a2)^4 

480: */ 

481: return a[0] * exp( a[2] * tmp1*tmp1) * tmp1*tmp1 * tmp1*tmp1; 

482: } 

483: } 

484: 

485: /*--------------------------------------------------------------- 

486: * fcircleTLS() 

487: * f(x|a) = 0 = (sqrt[(x1-a1)^2 + (x2-a2)^2^] - a3)^2 

488: *--------------------------------------------------------------*/ 

489: double 

490: fcircleTLS( int i, double *cond, double *a) 

491: { 

492: double tmp1, tmp2, d; 

493: /* two conditions per measurement */ 

494: tmp1 = cond[2*i ] - a[0]; 

495: tmp2 = cond[2*i+1] - a[1]; 

496: d = sqrt(tmp1*tmp1 + tmp2*tmp2) - a[2]; 

497: return d; 

498: } 

499: 

500: /*--------------------------------------------------------------- 

501: * fcircleTLS_deriv() 

502: * f(x|a) = 0 = (sqrt[(x1-a1)^2 + (x2-a2)^2^] - a3)^2 

503: *--------------------------------------------------------------*/ 

504: double 

505: fcircleTLS_deriv( double (*funct)(int,double*,double*), 


507: { 

508: double b, tmp1, tmp2; 

509: tmp1 = a[0] - cond[2*i ]; 

510: tmp2 = a[1] - cond[2*i+1]; 

511: b = sqrt(tmp1*tmp1 + tmp2*tmp2); 

512: if (j==0) 

513: return tmp1 / b; 

514: else if (j==1) 

515: return tmp2 / b; 

516: else 

517: return (-1); 

518: } 

519: /*--------------------------------------------------------------- 

520: * fcircle() 

521: * f(x|a) = 0 = (x1-a1)^2 + (x2-a2)^2 - a3^2 

522: *--------------------------------------------------------------*/ 

523: double 

524: fcircle( int i, double *cond, double *a) 

525: { 

526: double tmp1, tmp2; 

527: /* two conditions per measurement */ 

528: tmp1 = cond[2*i ] - a[0]; 

529: tmp2 = cond[2*i+1] - a[1]; 

530: 

531: return tmp1*tmp1 + tmp2*tmp2 - a[2]*a[2]; 

532: } 

533: 

534: /*--------------------------------------------------------------- 

535: * fcircle_deriv() 

536: * f(x|a) = 0 = (x-a1)^2 + (x2-a2)^2 - a3^2 

537: *--------------------------------------------------------------*/ 

538: double 

539: fcircle_deriv( double (*funct)(int,double*,double*), 


541: { 

542: if (j==0) 

543: return 2*(a[0] - cond[2*i]); 

544: else if (j==1) 

545: return 2*(a[1] - cond[2*i+1]); 

546: else 

547: return -2 * a[2]; 

548: } 

549: 

550: /*--------------------------------------------------------------- 

551: * fcirclelin_deriv() 

552: * f(x|b) = x1^2 + x2^2 = b1*x1 + b2*x2 - b3 

553: *--------------------------------------------------------------*/ 

554: double 

555: fcirclelin_deriv( double (*funct)(int,double*,double*), 


557: { 

558: if (j==0) 

559: return cond[2*i]; 

560: else if (j==1) 

561: return cond[2*i+1]; 

562: else 

563: return -1.; 

564: } 

565: 

566: /*--------------------------------------------------------------- 

567: * frotation() 

568: * 21... x = f1(u|a) = a1 + cos(a3) * u - sin(a3) * v 

569: * y = f2(u|a) = a2 + sin(a3) * u + cos(a3) * v 

570: *--------------------------------------------------------------*/ 

571: double 

572: frotation( int i, double *cond, double *a) 

573: {


574: if (i%2 == 0) 

575: { 

576: /* equation for x */ 

577: return a[0] + cos(a[2]) * cond[i] - sin(a[2]) * cond[i+1]; 

578: } 

579: else 

580: { 

581: /* equation for y */ 

582: return a[1] + sin(a[2]) * cond[i-1] + cos(a[2]) * cond[i]; 

583: } 

584: } 

585: 

586: /*--------------------------------------------------------------- 

587: * fpolynom2_deriv() 

588: * f(x|a) = a1 + a2 * x + a3 * x*x 

589: *--------------------------------------------------------------*/ 

590: double 

591: fpolynom2_deriv( double (*funct) (int,double*,double*), 


593: { 

594: if (j == 0) 

595: return 1.; 

596: else if (j == 1) 

597: { 


599: } 

600: else 

601: { 

602: return cond[i] * cond[i]; 

603: } 

604: } 

605: 

606: 

607: /*--------------------------------------------------------------- 

608: * fpolynom3_deriv() 

609: * f(x|a) = a1 + a2 * x + a3 * x*x + a4 * x*x*x 

610: *--------------------------------------------------------------*/ 

611: double 

612: fpolynom3_deriv( double (*funct) (int,double*,double*), 


614: { 

615: if (j == 0) 

616: return 1.; 

617: else if (j == 1) 

618: { 


620: } 

621: else if (j == 2) 

622: { 

623: return cond[i] * cond[i]; 

624: } 

625: else 

626: { 

627: return cond[i] * cond[i] * cond[i]; 

628: } 

629: } 

630: 

631: /*--------------------------------------------------------------- 

632: * fquadsurface_deriv() 

633: * f(x|a) = a1 + a2*x1 + a3*x1^2 + a4*x2 + a5*x2^2 

634: *--------------------------------------------------------------*/ 

635: double 

636: fquadsurface_deriv( double (*funct) (int,double*,double*), 


638: { 

639: if (j == 0) 

640: return 1.; 

641: else if (j == 1) 

642: { 

643: return cond[2*i]; 

644: } 

645: else if (j == 2) 

646: { 

647: return cond[2*i] * cond[2*i]; 

648: } 

649: else if (j == 3) 

650: { 

651: return cond[2*i+1]; 

652: } 

653: else 

654: { 

655: return cond[2*i+1] * cond[2*i+1]; 

656: } 

657: } 

658: 

659: /*--------------------------------------------------------------- 

660: * fNN_3_3() 

661: *--------------------------------------------------------------*/ 

662: double 

663: fNN_3_3( int i, double *cond, double *a) 

664: { 

665: double h1, h2, h3; 

666: double arg1, arg2, arg3; 

667: 

668: /* 1st hidden neuron */ 

669: arg1 = a[0] + a[1] * cond[3*i] 

670: + a[2] * cond[3*i+1] 

671: + a[3] * cond[3*i+2]; 

672: h1 = tanh( arg1); 

673: 

674: /* 2nd hidden neuron */ 

675: arg2 = a[4] + a[5] * cond[3*i] 

676: + a[6] * cond[3*i+1] 

677: + a[7] * cond[3*i+2]; 

678: h2 = tanh( arg2); 

679: 

680: /* 3rd hidden neuron */ 

681: arg3 = a[8] + a[9] * cond[3*i] 

682: + a[10] * cond[3*i+1] 

683: + a[11] * cond[3*i+2]; 

684: h3 = tanh( arg3); 

685: 

686: /* output neuron */ 

687: return a[12] * h1 + a[13] * h2 + a[14] * h3; 

688: } 

689: 

690: /*--------------------------------------------------------------- 

691: * fNN_3_3_sigmoid(), obsolete 

692: *--------------------------------------------------------------*/ 

693: double 

694: fNN_3_3_sigmoid( int i, double *cond, double *a) 

695: { 

696: double h1, h2, h3; 

697: double arg1, arg2, arg3; 

698: 


700: arg1 = a[0] + a[1] * cond[3*i] 

701: + a[2] * cond[3*i+1] 

702: + a[3] * cond[3*i+2]; 

703: h1 = 2. / (1. + exp( -arg1)) - 1; 

704: 


706: arg2 = a[4] + a[5] * cond[3*i] 

707: + a[6] * cond[3*i+1] 

708: + a[7] * cond[3*i+2]; 

709: h2 = 2. / (1. + exp( -arg2)) - 1; 

710: 


712: arg3 = a[8] + a[9] * cond[3*i] 

713: + a[10] * cond[3*i+1] 

714: + a[11] * cond[3*i+2]; 

715: h3 = 2. / (1. + exp( -arg3)) - 1; 

716: 


718: return a[12] * h1 + a[13] * h2 + a[14] * h3 + a[15]; 

719: } 

720: 

721: /*--------------------------------------------------------------- 

722: * fNN_3_2() 

723: * f(x|a) = 

724: *--------------------------------------------------------------*/ 

725: double 


727: { 

728: double h1, h2; 

729: double arg1, arg2; 

730: 


732: arg1 = a[0] + a[1] * cond[3*i] 

733: + a[2] * cond[3*i+1] 

734: + a[3] * cond[3*i+2]; 

735: if (arg1 < 0) arg1 = 0; 

736: h1 = 2. / (1. + exp( -arg1)) - 1; 

737: 


739: arg2 = a[4] + a[5] * cond[3*i] 

740: + a[6] * cond[3*i+1] 

741: + a[7] * cond[3*i+2]; 

742: if (arg2 < 0) arg2 = 0; 

743: h2 = 2. / (1. + exp( -arg2)) - 1; 

744: 


746: return a[8] * h1 + a[9] * h2 + a[10]; 

747: } 

748: 

749: /*--------------------------------------------------------------- 

750: * fNN_2_2() 

751: * f(x|a) = 

752: *--------------------------------------------------------------*/ 

753: double 


755: { 



758: 


760: arg1 = a[0] + a[1] * cond[2*i] 

761: + a[2] * cond[2*i+1]; 

762: h1 = 2. / (1. + exp( -arg1)) - 1; 

763: 


765: arg2 = a[3] + a[4] * cond[2*i]


766: + a[5] * cond[2*i+1]; 

767: h2 = 2. / (1. + exp( -arg2)) - 1; 

768: 


770: return a[6] * h1 + a[7] * h2 + a[8]; 

771: } 

772: 

773: /*--------------------------------------------------------------- 

774: * fNN_1_2() 

775: * f(x|a) = 

776: *--------------------------------------------------------------*/ 

777: double 


779: { 



782: 


784: arg1 = a[0] + a[1] * cond[i]; 

785: /*h1 = 2. / (1. + exp( -arg1)) - 1;*/ 

786: h1 = tanh( arg1); 

787: 


789: arg2 = a[2] + a[3] * cond[i]; 

790: /* h2 = 2. / (1. + exp( -arg2)) - 1; */ 

791: h2 = tanh( arg2); 

792: 


794: return a[4] * h1 + a[5] * h2 + a[6]; 

795: } 

796: 

797: /*--------------------------------------------------------------- 

798: * fNN_1_3() 

799: * f(x|a) = 

800: *--------------------------------------------------------------*/ 

801: double 


803: { 

804: double h1, h2, h3; 

805: double arg; 

806: 


808: arg = a[0] + a[1] * cond[i]; 

809: h1 = tanh( arg); 

810: /* h1 = 2. / (1. + exp( -arg)) - 1; */ 

811: 


813: arg = a[2] + a[3] * cond[i]; 

814: h2 = tanh( arg); 

815: /* h2 = 2. / (1. + exp( -arg)) - 1; */ 

816: 


818: arg = a[4] + a[5] * cond[i]; 

819: h3 = tanh( arg); 

820: /* h3 = 2. / (1. + exp( -arg)) - 1; */ 

821: 


823: return a[6] * h1 + a[7] * h2 + a[8] * h2 + a[9]; 

824: } 

825: 

826: /*--------------------------------------------------------------- 

827: * f_deriv() 

828: * numerical derivation, used for several model functions 

829: *--------------------------------------------------------------*/ 

830: double 

831: f_deriv( double (*funct)(int,double*,double*), 


833: { 

834: double tmp1, tmp2, atmp[M_MAX], ajp, ajm, C; 

835: double del; 

836: 

837: /* inspect positions close to current one */ 

838: if ( a[j] != 0.0) 

839: { 

840: C = 1000000; 

841: del = a[j]/C; 

842: } 

843: else 

844: { 

845: del = 0.001; 

846: } 

847: ajp = a[j] + del; /* plus a bit of current parameter value*/ 

848: ajm = a[j] - del; /* minus % */ 

849: /* create modified parameter vector, 

850: * copy maximum number of parameters 

851: */ 

852: /* copy all possible parameters, needed for POLYNOMIAL_REG */ 

853: memcpy( atmp, a, sizeof(double) * M_MAX); 

854: atmp[j] = ajp; 

855: /* look, what result is at modified position */ 

856: tmp1 = funct( i , cond, atmp); 

857: atmp[j] = ajm; 

858: tmp2 = funct( i , cond, atmp); 

859: 

860: /* compute gradient */ 

861: return tmp1 / (2*del) - tmp2 / (2*del); 

862: } 

863: 

0: /***************************************************************** 

1: * 

2: * File........: functions.h 

3: * Function....: proto typing for functions.c 


5: * last changes: 25.09.2009, 06.11.2009, 08.01.2010, 18.02.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef FUNCT_H 

15: #define FUNCT_H 

16: 

17: /* linear functions */ 

18: double fconstant_deriv( double (*funct)(int,double*,double*), 

19: int i, int j, int M, double *cond, double *a); 

20: double flin_deriv( double (*funct)(int,double*,double*), 


22: double fcosine_deriv( double (*funct)(int,double*,double*), 


24: double fprediction_deriv( double (*funct)(int,double*,double*), 


26: double fpolynom2_deriv( double (*funct)(int,double*,double*), 


28: double fpolynom3_deriv( double (*funct)(int,double*,double*), 


30: double fpolynomial_deriv( double (*funct)(int,double*,double*), 


32: double fquadsurface_deriv( double (*funct)(int,double*,double*), 


34: 

35: /* nonlinear functions */ 

36: double fpolynomial( int i, double *cond, double *a); 

37: int init_polynomial( int N, double *obs, double *cond, 

38: double *a, unsigned char *a_flag, FILE *logfile); 

39: 

40: double fcosine_nonlin( int i, double *cond, double *a); 

41: double fcosine_nonlin_deriv( double (*funct)(int,double*,double*), 


43: int init_cosine_nonlin( int N, double *obs, double *cond, 


45: 

46: double fcosine_trend( int i, double *cond, double *a); 

47: double fcosine_trend_deriv( double (*funct)(int,double*,double*), 


49: int init_cosine_trend( int N, double *obs, double *cond, 


51: 

52: double ftrigonometric1( int i, double *cond, double *a); 

53: int init_trigonometric1( int N, double *obs, double *cond, 


55: 

56: double ftrigonometric2( int i, double *cond, double *a); 

57: int init_trigonometric2( int N, double *obs, double *cond, 


59: 

60: double flogarithmic( int i, double *cond, double *a); 

61: double flogarithmic_deriv( double (*funct)(int,double*,double*), 


63: double flogarithmic_deriv2( double (*funct)(int,double*,double*), 

64: int j, int k, int M, int i, double *cond, double *a); 

65: int init_logarithmic( int N, double *obs, double *cond, 


67: 

68: double fexponential( int i, double *cond, double *a); 

69: double fexponential_deriv( double (*funct)(int,double*,double*), 


71: int init_exponential( int N, double *obs, double *cond, 

72: double *a, unsigned char *a_flag, FILE *out); 

73: 

74: double fexpon2( int i, double *cond, double *a); 

75: int init_expon2( int N, double *obs, double *cond, 


77: double fgen_laplace( int i, double *cond, double *a); 

78: double fgen_laplace_deriv( double (*funct)(int,double*,double*), 


80: int init_gen_laplace( int N, double *obs, double *cond, 


82: double fexpon2_deriv( double (*funct)(int,double*,double*), 


84: 

85: double fgauss2( int i, double *cond, double *a); 

86: double fgauss1( int i, double *cond, double *a); 

87: 

88: int init_gauss2( int N, double *obs, double *cond, 


90: int init_gauss1( int N, double *obs, double *cond,double *a, 

91: unsigned char *a_flag, int peak_flag, FILE *out);


92: 

93: double fgauss_deriv( double (*funct)(int,double*,double*), 


95: double fgauss_deriv2( double (*funct)(int,double*,double*), 

96: int j, int k, int M, int i, double *cond, double *a); 

97: int init_gauss( int N, double *obs, double *cond,double *a, 

98: unsigned char *a_flag, FILE *out); 

99: 

100: double frotation( int i, double *cond, double *a); 

101: int init_rotation( int N, double *obs, double *cond, 


103: 

104: double fcircleTLS( int i, double *cond, double *a); 

105: double fcircleTLS_deriv( double (*funct)(int,double*,double*), 


107: double fcircle( int i, double *cond, double *a); 

108: double fcircle_deriv( double (*funct)(int,double*,double*), 


110: int init_circle( int N, double *obs, double *cond, 


112: 

113: double fcirclelin_deriv( double (*funct)(int,double*,double*), 


115: int init_circlelin( int N, double *obs, double *cond, 


117: 

118: double fNN_3_3( int i, double *cond, double *a); 

119: int init_NN3x3x1( int N, double *obs, double *cond, 


121: int init_NN( int N, double *obs, double *cond, 






127: int init_NN1x3x1( int N, double *obs, double *cond, 


129: 

130: /* common numerical derivation function for all 

131: * nonlinear problems 

132: */ 

133: double f_deriv( double (*funct)(int,double*,double*), 


135: 

136: #endif 

0: 

1: /***************************************************************** 

2: * 

3: * File....: functions.c 

4: * Function: model functions and their derivatives 

5: * Author..: Tilo Strutz 

6: * Date....: 23.09.2007 

7: * 





12: * 

13: *****************************************************************/ 

14: #include 

15: #include 

16: #include 

17: #include 



20: 

21: #define DEG2RAD M_PI/180. 

22: 

23: /*--------------------------------------------------------------- 

24: * fNIST_Eckerle4() 

25: * f(x|a) = a1 / a2 * exp(-0.5*((x -a3)/ a2)^2) 

26: *--------------------------------------------------------------*/ 

27: double 

28: fNIST_Eckerle4( int i, double *cond, double *a) 

29: { 

30: double x; 

31: x = (cond[i] - a[2]) / a[1]; 

32: return (a[0] / a[1]) * exp( -0.5*x*x); 

33: } 

34: 

35: /*--------------------------------------------------------------- 

36: * fNIST_Eckerle4_deriv() 

37: * f(x|a) = a1 / a2 * exp(-0.5*((x -a3)/ a2)^2) 

38: *--------------------------------------------------------------*/ 

39: double 

40: fNIST_Eckerle4_deriv( double (*funct)(int,double*,double*), 


42: { 

43: double x; 

44: x = (cond[i] - a[2]) / a[1]; 

45: if (j == 0) 

46: /* y = a0 / a1 * exp(-0.5*((x -a2)/ a1)^2) */ 

47: return exp(-0.5*x*x) / a[1]; 

48: else if (j == 1) 

49: return a[0] * exp(-0.5*x*x) / (a[1]*a[1]) * (x*x - 1); 

50: else 

51: return a[0] * exp(-0.5*x*x) * (cond[i] - a[2]) / 

52: (a[1]*a[1]*a[1]); 

53: } 

54: 

55: /*--------------------------------------------------------------- 

56: * fNIST_Rat43() 

57: * f(x|a) = a1 / [1 + exp(a2 - a3*x)]^(1/a4) 

58: *--------------------------------------------------------------*/ 

59: double 

60: fNIST_Rat43( int i, double *cond, double *a) 

61: { 

62: double x; 

63: x = exp( a[1] - a[2]*cond[i]); 

64: return a[0] / pow(1 + x, 1/a[3]); 

65: } 

66: 

67: /*--------------------------------------------------------------- 

68: * fNIST_Rat43_deriv() 

69: * f(x|a) = a1 / [1 + exp(a2 - a3*x)]^(1/a4) 

70: *--------------------------------------------------------------*/ 

71: double 

72: fNIST_Rat43_deriv( double (*funct)(int,double*,double*), 


74: { 

75: double x; 

76: x = exp( a[1] - a[2]*cond[i]); 

77: /* y = a0 / [1 + exp( a1-a2*x)]^(1/a3) */ 

78: if (j == 0) 

79: return 1. / pow(1 + x, 1/a[3]); 

80: else if (j == 1) 

81: return -a[0] * x * pow( (x+1), -1/a[3]-1 ) / a[3]; 

82: else if (j == 2) 

83: return a[0]*cond[i] * x * pow( (x+1), -1/a[3]-1 ) / a[3]; 

84: else 

85: return a[0] * log( x+1) / (pow( (x+1), 1/a[3]) *a[3]*a[3]); 

86: } 

87: 

88: /*--------------------------------------------------------------- 

89: * fNIST_Rat42() 

90: * f(x|a) = a1 / (1 + exp(a2 - a3*x)) 

91: *--------------------------------------------------------------*/ 

92: double 

93: fNIST_Rat42( int i, double *cond, double *a) 

94: { 

95: return a[0] / (1 + exp( a[1] - a[2]*cond[i]) ); 

96: } 

97: 

98: /*--------------------------------------------------------------- 

99: * fNIST_Rat42_deriv() 

100: * f(x|a) = a1 / (1 + exp(a2 - a3*x)) 

101: *--------------------------------------------------------------*/ 

102: double 

103: fNIST_Rat42_deriv( double (*funct)(int,double*,double*), 


105: { 

106: /* y = a0 / (1 + exp( a1 - a2*x)) */ 

107: if (j == 0) 

108: return 1. / (1 + exp( a[1] - a[2]*cond[i]) ); 

109: else if (j == 1) 

110: return -a[0] * exp( a[1] - a[2]*cond[i]) / 

111: pow( (1 + exp( a[1] - a[2]*cond[i])), 2. ); 

112: else 

113: return a[0] * cond[i] * exp( a[1] - a[2]*cond[i]) / 

114: pow( (1 + exp( a[1] - a[2]*cond[i])), 2. ); 

115: } 

116: 

117: /*--------------------------------------------------------------- 

118: * fNIST_thurber() 

119: * f(x|a) =(a1 + a2*x + a3*x**2 + a4*x**3) / 

120: * (1 + a5*x + a6*x**2 + a7*x**3) 

121: *--------------------------------------------------------------*/ 

122: double 

123: fNIST_thurber( int i, double *cond, double *a) 

124: { 

125: double x2, x3; 

126: x2 = cond[i]*cond[i]; 

127: x3 = x2*cond[i]; 

128: return (a[0] + a[1]*cond[i] + a[2]*x2 + a[3]*x3) / 

129: (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3); 

130: } 

131: 

132: /*--------------------------------------------------------------- 

133: * fNIST_thurber_deriv() 

134: * f(x|a) = a1 * exp( a2 / (x+a3)) 

135: *--------------------------------------------------------------*/ 

136: double 

137: fNIST_thurber_deriv( double (*funct)(int,double*,double*), 


139: { 

140: double x2, x3; 


142: x3 = x2*cond[i]; 

143: if (j == 0) 

144: /* y = (a0 + a1*x + a2*x**2 + a3*x**3) /


145: (1 + a4*x + a5*x**2 + a6*x**3) */ 

146: return 1. / (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3); 

147: else if (j == 1) 

148: return cond[i] / (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3); 

149: else if (j == 2) 

150: return x2 / (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3); 

151: else if (j == 3) 

152: return x3 / (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3); 

153: else if (j == 4) 

154: return -cond[i] * (a[0] + a[1]*cond[i] + a[2]*x2 + a[3]*x3) / 

155: pow( (1 + a[4]*cond[i] + a[5]*x2 + a[6]*x3), 2.); 

156: else if (j == 5) 

157: return -x2 * (a[0] + a[1]*cond[i] + a[2]*x2 + a[3]*x3) / 


159: else 

160: return -x3 * (a[0] + a[1]*cond[i] + a[2]*x2 + a[3]*x3) / 


162: } 

163: 

164: /*--------------------------------------------------------------- 

165: * fNIST_MGH09() 

166: * f(x|a) =a1 * (x**2 + a2*x) / (x*x + a3*x + a4) 

167: *--------------------------------------------------------------*/ 

168: double 

169: fNIST_MGH09( int i, double *cond, double *a) 

170: { 

171: double x2; 


173: return a[0] * (x2 + a[1]*cond[i]) / 

174: (x2 + a[2]*cond[i] + a[3]); 

175: } 

176: 

177: /*--------------------------------------------------------------- 

178: * fNIST_MGH09_deriv() 

179: * f(x|a) =a1 * (x**2 + a2*x) / (x*x + a3*x + a4) 

180: *--------------------------------------------------------------*/ 

181: double 

182: fNIST_MGH09_deriv( double (*funct)(int,double*,double*), 


184: { 

185: double x2; 


187: if (j == 0) 

188: /* y = a0 * (x**2 + a1*x) / (x*x + a2*x + a3) */ 

189: /* dy/da0 = (x**2 + a1*x) / (x*x + a2*x + a3) */ 

190: return (x2 + a[1]*cond[i]) / (x2 + a[2]*cond[i] + a[3]); 

191: else if (j == 1) 

192: return a[0] * cond[i] / (x2 + a[2]*cond[i] + a[3]); 

193: else if (j == 2) 

194: return -a[0] * (x2 + a[1]*cond[i])*cond[i] / 

195: pow( (x2 + a[2]*cond[i] + a[3]), 2.); 

196: else 

197: return -a[0] * (x2 + a[1]*cond[i]) / 

198: pow( (x2 + a[2]*cond[i] + a[3]), 2.); 

199: } 

200: 

201: /*--------------------------------------------------------------- 

202: * fNIST_MGH10() 

203: * f(x|a) = a1 * exp( a2 / (x+a3)) 

204: *--------------------------------------------------------------*/ 

205: double 

206: fNIST_MGH10( int i, double *cond, double *a) 

207: { 

208: return a[0] * exp( a[1] / (cond[i] + a[2])); 

209: } 

210: 

211: /*--------------------------------------------------------------- 

212: * fNIST_MGH10_deriv() 

213: * f(x|a) = a1 * exp( a2 / (x+a3)) 

214: *--------------------------------------------------------------*/ 

215: double 

216: fNIST_MGH10_deriv( double (*funct)(int,double*,double*), 


218: { 

219: if (j == 0) 

220: /* y = a0 * exp( a1 / (x+a2)) */ 

221: /* dy/da0 = exp( a1 / (x+a2)) */ 

222: return exp( a[1] / (cond[i] + a[2])); 

223: else if (j == 1) 

224: /* y = a0 * exp( a1 / (x+a2)) */ 

225: /* dy/da1 = a0 * exp( a1 / (x+a2)) / (x+a2) */ 

226: return a[0] * exp( a[1] / (cond[i] + a[2])) / (cond[i]+ a[2]); 

227: else 

228: /* y = a0 * exp( a1 / (x+a2)) */ 

229: /* dy/da2 =-a0*a1 * exp( a1 / (x+a2)) / (x+a2)^2 */ 

230: return -a[0] * a[1] * exp( a[1] / (cond[i] + a[2])) / 

231: ((cond[i]+ a[2])*(cond[i]+ a[2])); 

232: } 

233: 

234: /*--------------------------------------------------------------- 

235: * fNIST_MGH10_deriv2() 

236: * f(x|a) = a1 * exp( a2 / (x+a3)) 

237: *--------------------------------------------------------------*/ 

238: double 

239: fNIST_MGH10_deriv2( double (*funct)(int,double*,double*), 

240: int j, int k, int M, int i, double *cond, double *a) 

241: { 


243: /* j ... derivation with respect to a_j */ 

244: /* k ... derivation with respect to a_k */ 

245: if (j == 0) 

246: { 

247: if ( k == 0) 

248: /* y = a0 * exp( a1 / (x+a2)) */ 

249: /* dy/da0 = exp( a1 / (x+a2)) */ 


251: else if ( k == 1) 

252: /* y = a0 * exp( a1 / (x+a2)) */ 

253: /* dy/da0 = exp( a1 / (x+a2)) */ 

254: /* d2y/da0da1 = exp( a1 / (x+a2)) / (x+a2) */ 

255: return exp( a[1] / (cond[i] + a[2])) / 

256: (cond[i] + a[2]); 

257: else 

258: /* y = a0 * exp( a1 / (x+a2)) */ 

259: /* dy/da0 = exp( a1 / (x+a2)) */ 

260: /* d2y/da0da2 = -a1 * exp( a1 / (x+a2)) / (x+a2)^2 */ 

261: return -a[1] * exp( a[1] / (cond[i] + a[2])) / 

262: ((cond[i] + a[2])*(cond[i] + a[2])); 

263: } 

264: else if (j == 1) 

265: { 

266: if ( k == 0) 

267: /* y = a0 * exp( a1 / (x+a2)) */ 


269: /* d2y/da1da0 = exp( a1 / (x+a2)) / (x+a2) */ 

270: return exp( a[1] / (cond[i] + a[2])) / 

271: (cond[i] + a[2]); 

272: else if ( k == 1) 

273: /* y = a0 * exp( a1 / (x+a2)) */ 


275: /* d2y/d2a1 = a0 * exp( a1 / (x+a2)) / (x+a2)^2 */ 

276: return a[0] * exp( a[1] / (cond[i] + a[2])) / 

277: ((cond[i] + a[2])*(cond[i] + a[2])); 

278: else 

279: /* y = a0 * exp( a1 / (x+a2)) */ 


281: /* d2y/da1da2 =-a0 * exp( a1 / (x+a2)) / (x+a2)^2 - 

282: a0*a1 * exp( a1 / (x+a2)) / (x+a2)^3 */ 

283: /* d2y/da1da2 =-a0 * exp( a1 / (x+a2)) / (x+a2)^2 * 

284: (1 + a1 / (x+a2)) */ 


286: ((cond[i] + a[2])*(cond[i] + a[2])) * 

287: (1 + a[1]/(cond[i]+ a[2])); 

288: } 

289: else 

290: { 

291: if ( k == 0) 

292: /* y = a0 * exp( a1 / (x+a2)) */ 


294: /* d2y/da0da2 = -a1 * exp( a1 / (x+a2)) / (x+a2)^2 */ 


296: ((cond[i] + a[2])*(cond[i] + a[2])); 

297: else if ( k == 1) 

298: /* y = a0 * exp( a1 / (x+a2)) */ 


300: /* d2y/da1da2 =-a0 * exp( a1 / (x+a2)) / (x+a2)^2 - 

301: a0*a1 * exp( a1 / (x+a2)) / (x+a2)^3 */ 

302: /* d2y/da1da2 =-a0 * exp( a1 / (x+a2)) / (x+a2)^2 * 

303: (1 + a1 / (x+a2)) */ 


305: ((cond[i] + a[2])*(cond[i] + a[2])) * 

306: (1 + a[1]/(cond[i]+ a[2])); 

307: else 

308: /* y = a0 * exp( a1 / (x+a2)) */ 


310: /* d2y/da2da2 =2*a0*a1 * exp( a1 / (x+a2)) / (x+a2)^3 + 

311: a0*a1^2 * exp( a1 / (x+a2)) / (x+a2)^4 */ 

312: /* d2y/da2da2 = a0*a1 * exp( a1 / (x+a2)) / (x+a2)^3 * 

313: (2 + a1 / (x+a2) */ 

314: return a[0] * a[1] * exp( a[1] / (cond[i] + a[2])) / 

315: ((cond[i]+ a[2])*(cond[i]+ a[2])*(cond[i]+ a[2])) * 

316: (2 + a[1] /(cond[i]+ a[2])); 

317: } 

318: } 

319: 

320: /*--------------------------------------------------------------- 

321: * fNIST_Bennett5() 

322: * f(x|a) = a1 * (x+a2)^(-1/a3) 

323: *--------------------------------------------------------------*/ 

324: double 

325: fNIST_Bennett5( int i, double *cond, double *a) 

326: { 

327: return a[0] * pow( (cond[i] + a[1]), -1./a[2]); 

328: } 

329: 

330: /*--------------------------------------------------------------- 

331: * fNIST_Bennett5_deriv() 

332: * f(x|a) = a1 * (x+a2)^(-1/a3) 

333: *--------------------------------------------------------------*/ 

334: double 

335: fNIST_Bennett5_deriv( double (*funct)(int,double*,double*), 

336: int i, int j, int M, double *cond, double *a)


337: { 


339: if (j == 0) 

340: return pow( (cond[i] + a[1]), -1./a[2]); /* derivation of a1 */ 

341: else if (j == 1) 

342: return a[0] * pow( (cond[i] + a[1]), -1./a[2] - 1.)*(-1./a[2]); 

343: /* derivation of a2 */ 

344: else 

345: return a[0] * pow( (cond[i] + a[1]), -1./a[2]) * 

346: log( a[1] + cond[i]) / (a[2]*a[2]); 

347: } 

348: 

349: /*--------------------------------------------------------------- 

350: * fNIST_BoxBOD() 

351: * f(x|a) = a1 * (1 - exp( -a2 * x) ) 

352: *--------------------------------------------------------------*/ 

353: double 

354: fNIST_BoxBOD( int i, double *cond, double *a) 

355: { 

356: return ( a[0] * (1 - exp( -a[1] *cond[i])) ); 

357: } 

358: 

359: /*--------------------------------------------------------------- 

360: * fNIST_BoxBOD_deriv() 

361: * f(x|a) = a1 * (1 - exp( -a2 * x) ) 

362: *--------------------------------------------------------------*/ 

363: double 

364: fNIST_BoxBOD_deriv( double (*funct)(), int i, int j, int M, 

365: double *cond, double *a) 

366: { 

367: /* y = a0 * (1 - exp( -a1 * x) ) */ 

368: if ( a[1] < 0 ) a[1] = 0; 

369: if (j == 0) 

370: { 

371: return (1 - exp( -a[1] *cond[i])); 

372: } 

373: else 

374: { 

375: return ( a[0] * cond[i] * exp( -a[1]*cond[i]) ); 

376: } 

377: } 

0: /***************************************************************** 

1: * 

2: * File....: functions_NIST.h 

3: * Function: proto typing for functions_NIST.c 

4: * Author..: Tilo Strutz 

5: * Date....: 23.09.2009 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef FUNCT_NIST_H 

15: #define FUNCT_NIST_H 

16: 

17: 

18: /* linear functions */ 

19: 

20: /* nonlinear functions */ 

21: 

22: double fNIST_BoxBOD( int i, double *cond, double *a); 

23: double fNIST_BoxBOD_deriv( double (*funct)(int,double*,double*), 


25: int init_NIST_BoxBOD( int N, double *obs, 

26: double *cond, double *a, unsigned char *a_flag, FILE *out); 

27: double fNIST_MGH09( int i, double *cond, double *a); 

28: double fNIST_MGH09_deriv( double (*funct)(int,double*,double*), 


30: int init_NIST_MGH09( int N, double *obs, double *cond, 


32: 

33: double fNIST_thurber( int i, double *cond, double *a); 

34: double fNIST_thurber_deriv( double (*funct)(int,double*,double*), 


36: int init_NIST_thurber( int N, double *obs, 


38: 

39: double fNIST_Rat42( int i, double *cond, double *a); 

40: double fNIST_Rat42_deriv( double (*funct)(int,double*,double*), 


42: int init_NIST_Rat42( int N, double *obs, 


44: 

45: double fNIST_Rat43( int i, double *cond, double *a); 

46: double fNIST_Rat43_deriv( double (*funct)(int,double*,double*), 


48: int init_NIST_Rat43( int N, double *obs, 


50: 

51: double fNIST_Eckerle4( int i, double *cond, double *a); 

52: double fNIST_Eckerle4_deriv( double (*funct)(int,double*,double*), 


54: int init_NIST_Eckerle4( int N, double *obs, 


56: 

57: double fNIST_MGH10( int i, double *cond, double *a); 

58: int init_NIST_MGH10( int N, double *obs, 


60: double fNIST_MGH10_deriv( double (*funct)(int,double*,double*), 


62: double fNIST_MGH10_deriv2( double (*funct)(int,double*,double*), 

63: int i, int j, int M, int n, double *cond, double *a); 

64: 

65: double fNIST_Bennett5( int i, double *cond, double *a); 

66: int init_NIST_Bennett5( int N, double *obs, 


68: double fNIST_Bennett5_deriv( double (*funct)(int,double*,double*), 


70: 

71: #endif

S.4 Initialisation of nonlinear models 31 

S.4 Initialisation of nonlinear 

models 

0: /**************************************************************** 

1: * 

2: * File........: init_collection.c 

3: * Function....: parameter initialisation for 

4: * different functions 


6: * last changes: 02.07.2009, 30.09.2009, 08.01.2010, 18.02.2010 

7: * 





12: * 

13: ****************************************************************/ 

14: #include 

15: #include 

16: #include 

17: #include 





22: 


24: #include 

25: #else 

26: #include 


28: #endif 

29: 

30: /*--------------------------------------------------------------- 

31: * init_polynomial() 

32: * f(x|a) = sum_{j=1}^M aj * x^(j-1) 

33: *--------------------------------------------------------------*/ 

34: int init_polynomial( int N, double *obs, double *cond, 

35: double *a, unsigned char *a_flag, FILE *logfile) 

36: { 

37: long j; 

38: 

39: // if (!a_flag[0] && !a_flag[1]) 

40: // { 

41: /* estimate first two parameters */ 

42: // ls_straightline( N, cond, obs, a); 

43: // } 

44: // else 

45: { 

46: if (!a_flag[0]) 

47: a[0] = ((double)rand()/ RAND_MAX - 0.5) * 10.01; 

48: if (!a_flag[1]) 

49: a[1] = ((double)rand()/ RAND_MAX - 0.5) * 10.01; 

50: } 

51: /* assume maximal number of parameters */ 

52: for ( j = 2; j < M_MAX; j++) 

53: { 

54: if (!a_flag[j]) 

55: a[j] = ((double)rand()/ RAND_MAX - 0.5) * 10.01; 

56: } 

57: return 0; 

58: } 

59: 

60: /*--------------------------------------------------------------- 

61: * init_cosine_nonlin() 

62: * 5: f(x|a) = a1 + a2 * cos( x - a3) (omega = 2*pi) 

63: *--------------------------------------------------------------*/ 

64: int 

65: init_cosine_nonlin( int N, double *obs, double *cond, 


67: { 

68: int i; 

69: double mean; 

70: 

71: /* mean value for a[0] */ 

72: if (!a_flag[0]) 

73: { 

74: mean = 0; 

75: for (i = 0; i < N; i++) 

76: mean += obs[i]; 

77: a[0] = mean / N; 

78: } 

79: 

80: /* estimation of a2 = radius */ 

81: //if (!a_flag[1]) /* if not set on command line */ 

82: //{ 

83: // mean = 0; 

84: // for (i = 0; i < N; i++) 

85: // mean += obs[i] * sqrt( 2.); 

86: // a[1] = mean / N; 

87: //} 

88: { 

89: double max_obs, min_obs; 

90: max_obs = min_obs = obs[0]; 

91: for (i = 1; i < N; i++) 

92: { 

93: if (max_obs < obs[i]) max_obs = obs[i]; 

94: if (min_obs > obs[i]) min_obs = obs[i]; 

95: } 

96: if (!a_flag[1]) /* if not set on command line */ 

97: { 

98: a[1] = 0.5 * ( max_obs - min_obs); 

99: } 

100: } 

101: 

102: /* estimation of a3 = phase shift */ 

103: if (!a_flag[2]) 

104: { 

105: a[2] = 1.; /* dummy */ 

106: } 

107: 


109: } 

110: 

111: /*--------------------------------------------------------------- 

112: * init_cosine_trend() 

113: * 12: f(x|a) = a1 + a2 * x + a3 * cos( x - a4) 

114: *--------------------------------------------------------------*/ 

115: int 

116: init_cosine_trend( int N, double *obs, double *cond, 


118: { 

119: int i; 


121: 


123: if (!a_flag[0]) 

124: { 

125: mean = 0; 

126: for (i = 0; i < N; i++) 

127: mean += obs[i]; 

128: a[0] = mean / N; 

129: } 

130: 

131: /* estimation of a3 = linear trend */ 

132: if (!a_flag[1]) 

133: { 

134: a[1] = 0.; /* dummy */ 

135: } 

136: 

137: /* estimation of a3 = radius */ 


139: { 

140: mean = 0; 

141: for (i = 0; i < N; i++) 

142: mean += obs[i] * sqrt( 2.); 

143: a[2] = mean / N; 

144: } 

145: 


147: if (!a_flag[3]) 

148: { 

149: a[3] = 0.; /* dummy */ 

150: } 

151: 


153: } 

154: 

155: /*--------------------------------------------------------------- 

156: * init_trigonometric1() 

157: * f(x|a) = a1 + a2*cos(a3*x-a4) 

158: *--------------------------------------------------------------*/ 

159: int 

160: init_trigonometric1( int N, double *obs, double *cond, 


162: { 

163: int i; 


165: 


167: if (!a_flag[0]) 

168: { 

169: mean = 0; 

170: for (i = 0; i < N; i++) 

171: mean += obs[i]; 

172: a[0] = mean / N; 

173: } 

174: 

175: /* estimation of a3 = period */ 

176: { 

177: double max_x, min_x; 

178: max_x = min_x = cond[0]; 

179: for (i = 1; i < N; i++) 

180: { 

181: if (max_x < cond[i]) max_x = cond[i]; 

182: if (min_x > cond[i]) min_x = cond[i]; 

183: } 

184: if (!a_flag[2]) 

185: a[2] = 2*3.141 / (2 * ( max_x - min_x)); 

186: }


187: 

188: /* estimation of a2 = amplitude */ 

189: { 



192: for (i = 1; i < N; i++) 

193: { 



196: } 


198: { 


200: } 

201: } 

202: 


204: if (!a_flag[3]) 

205: { 

206: a[3] = 0.; /* dummy */ 

207: } 

208: 


210: } 

211: 

212: /*--------------------------------------------------------------- 

213: * init_trigonometric2() 


215: *--------------------------------------------------------------*/ 

216: int 

217: init_trigonometric2( int N, double *obs, double *cond, 


219: { 

220: int i; 


222: 


224: if (!a_flag[0]) 

225: { 

226: mean = 0; 

227: for (i = 0; i < N; i++) 

228: mean += obs[i]; 

229: a[0] = mean / N; 

230: } 

231: 

232: /* estimation of a3 = period */ 

233: { 

234: double max_x, min_x; 

235: max_x = min_x = cond[0]; 

236: for (i = 1; i < N; i++) 

237: { 

238: if (max_x < cond[i]) max_x = cond[i]; 

239: if (min_x > cond[i]) min_x = cond[i]; 

240: } 

241: if (!a_flag[2]) 

242: a[2] = 2*3.141 / (2 * ( max_x - min_x)); 

243: } 

244: 

245: /* estimation of a2, a5 = amplitude */ 

246: { 



249: for (i = 1; i < N; i++) 

250: { 



253: } 


255: { 


257: } 


259: { 

260: a[4] = rand() * 0.5 * ( max_obs - min_obs); 

261: } 

262: } 

263: 

264: /* estimation of a4,a6 = phase shift */ 

265: if (!a_flag[3]) 

266: { 

267: a[3] = 0.; /* dummy */ 

268: } 

269: if (!a_flag[5]) 

270: { 

271: a[5] = 0.; /* dummy */ 

272: } 


274: } 

275: 

276: /*--------------------------------------------------------------- 

277: * init_logarithmic() 

278: * f(x|a) = log( a1 * x) 

279: *--------------------------------------------------------------*/ 

280: int 

281: init_logarithmic( int N, double *obs, double *cond, 


283: { 

284: if (!a_flag[0]) 

285: a[0] = 5; 


287: } 

288: /*--------------------------------------------------------------- 

289: * init_exponential() 

290: * f(x|a) = a1 + a2 * exp( a3 * x) 

291: *--------------------------------------------------------------*/ 

292: int 

293: init_exponential( int N, double *obs, double *cond, 


295: { 

296: int err = 0; /* return value */ 

297: int i, itmp; 


299: 

300: /* number of conditions to be inspected */ 

301: itmp = MAX( 0, MIN( 5, N)); 

302: 

303: /* estimation of a1 = tail of graph */ 

304: if (!a_flag[0]) 

305: { 

306: mean = 0; 

307: for (i = N - 1; i > N - itmp; i--) 

308: mean += obs[i]; 

309: a[0] = mean / itmp; 

310: } 

311: 

312: /* estimation of a2 = head of function */ 

313: if (!a_flag[1]) 

314: { 

315: mean = 0; 

316: for (i = 0; i < itmp; i++) 

317: mean += obs[i]; 

318: 

319: /* assumes conditions starting close to zero 

320: * y(x=0) = a1 + a2 * exp( a3 * 0) = a1 + a2 

321: */ 

322: a[1] = mean / itmp; 

323: } 

324: 

325: /* estimation of a3 = gradient at head of function */ 

326: if (!a_flag[2]) 

327: { 

328: mean = 0; 

329: for (i = 1; i < itmp; i++) 

330: mean += (obs[i] - obs[i - 1]) / (cond[i] - cond[i - 1]); 

331: a[2] = mean / (itmp * 0.5); 

332: } 

333: 

334: /* if not decaying */ 

335: if (a[0] > a[1]) 

336: { 

337: fprintf( stderr, "\n a1 > a2 !"); 

338: fprintf( stderr, "\n flip signs of a2 and a3 !\n"); 

339: a[1] = -a[1]; 

340: a[2] = -a[2]; 

341: } 

342: 


344: } 

345: 

346: /*--------------------------------------------------------------- 

347: * init_expon2() 

348: * f(x|a) = a1 * exp( a2 * x) 

349: *--------------------------------------------------------------*/ 

350: int 

351: init_expon2( int N, double *obs, double *cond, 

352: double *a, unsigned char *a_flag, FILE *out) 

353: { 



356: 

357: /* number of conditions to be inspected */ 

358: itmp = MAX( 0, MIN( 5, N)); 

359: 


361: if (!a_flag[0]) 

362: { 

363: mean = 0; 

364: for (i = 0; i < itmp; i++) 

365: mean += obs[i]; 

366: 


368: * y(x=0) = a1 * exp( a2 * 0) = a1 

369: */ 

370: a[0] = mean / itmp; 

371: } 

372: 

373: /* estimation of a2 = gradient at head of function 

374: * a2 = f’(0)/a1 

375: */ 

376: if (!a_flag[1]) 

377: { 

378: mean = 0;


379: for (i = 1; i obs[i]) 

419: { 

420: min_val = obs[i]; 

421: i_min = i; /* peak position */ 

422: condmin = cond[i]; 

423: } 

424: } 

425: if (max_val == min_val) 

426: { 

427: fprintf( out, "\n\n Nothing to fit !!"); 

428: a[0] = 0.; 

429: a[2] = -50000000.0; 

430: a[1] = 0.; 

431: err = 8; 


433: } 

434: 

435: mean = sum = var = 0.; 

436: /* take only that part which has the highest peak */ 

437: if (fabs(max_val) > fabs(min_val)) 

438: { 

439: /* positive amplitude */ 

440: for (i = 0; i < N; i++) 

441: { 

442: if (obs[i] > 0.) 

443: { 

444: /* mean and variance of condition 

445: * observed value is like probability 

446: */ 

447: tmp = cond[i] * obs[i]; 

448: mean += tmp; 

449: var += cond[i] * tmp; 

450: sum += obs[i]; 

451: } 

452: } 

453: if (sum > 0.) 

454: { 

455: mean /= sum; /* average along cond[i] */ 

456: var = var/sum - mean*mean; 

457: } 

458: } 

459: else 

460: { 

461: /* negative amplitude */ 

462: for (i = 0; i < N; i++) 

463: { 

464: if (obs[i] < 0.) 

465: { 

466: tmp = - cond[i] * obs[i]; 

467: mean += tmp; 


469: sum -= obs[i]; 

470: } 

471: } 

472: if (sum > 0.) 

473: { 

474: mean /= sum; 


476: } 

477: } 

478: 

479: /* if only one data point, then sigma is zero */ 

480: if (var > 0.) sigma = sqrt( var); /* deviation of Gaussian */ 

481: else 

482: sigma = 0.0000001; 

483: 

484: 

485: /* get index of mean position */ 

486: for (i = 1; i < N; i++) 

487: { 

488: if (cond[i-1] fabs(mean - condmax)) 

506: sigma -= fabs(mean - condmax); 

507: } 

508: } 

509: else 

510: { 

511: { 

512: if (!a_flag[0]) a[0] = min_val; 

513: if (!a_flag[1]) a[1] = condmin; 

514: if (sigma > fabs(mean-condmin)) sigma -= fabs(mean-condmin); 

515: } 

516: } 

517: /* transcode deviation */ 

518: if (!a_flag[2]) a[2] = -0.5 / (sigma*sigma); 

519: 

520: endfunc: 


522: } 

523: 

524: /*--------------------------------------------------------------- 

525: * init_gen_laplace() 

526: * f(x|a) = a1 * exp( -|x|â2 * a3) 

527: *--------------------------------------------------------------*/ 

528: int 

529: init_gen_laplace( int N, double *obs, double *cond, 


531: { 


533: * y(x=0) = a1 * exp( 0) = a1 

534: */ 

535: if (!a_flag[0]) 

536: { 

537: a[0] = obs[0]; 

538: } 

539: if (!a_flag[1]) 

540: { 

541: a[1] = 1.0; 

542: } 

543: if (!a_flag[2]) 

544: { 

545: a[2] = 0.8; 

546: } 

547: 


549: } 

550: 

551: /*--------------------------------------------------------------- 

552: * init_circlelin() 

553: * f(x|a) = 0 = (x1-a1)^2 + (x2-a2)^2 - a3^2 

554: *--------------------------------------------------------------*/ 

555: int 

556: init_circlelin( int N, double *obs, double *cond, 


558: { 


560: double b1, b2, b3; 

561: 

562: /* get estimates of centre coordinates and radius */ 

563: err = init_circle( N, obs, cond, a, a_flag, logfile); 

564: 

565: /* convert into vector b */ 

566: b1 = 2 * a[0]; 

567: b2 = 2 * a[1]; 

568: b3 = a[0]*a[0] + a[1]*a[1] - a[2]*a[2]; 

569: 

570: /* put back to a[] */


571: a[0] = b1; 

572: a[1] = b2; 

573: a[2] = b3; 

574: 


576: } 

577: 

578: /*--------------------------------------------------------------- 

579: * init_circle() 

580: * f(x|a) = 0 = (x1-a1)^2 + (x2-a2)^2 - a3^2 

581: *--------------------------------------------------------------*/ 

582: int 

583: init_circle( int N, double *obs, double *cond, 


585: { 


587: int i; 

588: double sum_x, sum_y, rad2, diff1, diff2; 

589: 

590: fprintf( logfile, "\n#\n# init_circle()"); 

591: 

592: /* 

593: * determine circle centre 

594: */ 

595: 

596: /* compute centroids of conditions */ 

597: sum_x = sum_y = 0.; 

598: /* two conditions */ 

599: for (i = 0; i < 2*N; i+=2) 

600: { 

601: sum_x += cond[i]; 

602: sum_y += cond[i+1]; 

603: } 

604: sum_x /= (double)N; 

605: sum_y /= (double)N; 

606: 

607: rad2 = 0; 

608: for (i = 0; i < 2*N; i+=2) 

609: { 

610: diff1 = cond[i] - sum_x; 

611: diff2 = cond[i+1] - sum_y; 

612: rad2 += sqrt( diff1*diff1 + diff2*diff2); 

613: } 

614: rad2 = rad2 / (double)N; 

615: fprintf( logfile, "\n#\n# mean of condition coordinates"); 

616: fprintf( logfile, "\n# mean(x)= %f", sum_x); 

617: fprintf( logfile, "\n# mean(y)= %f", sum_y); 

618: fprintf( logfile, "\n# radius = %f", rad2); 

619: 

620: if (!a_flag[0]) a[0] = sum_x; 

621: if (!a_flag[1]) a[1] = sum_y; 

622: if (!a_flag[2]) a[2] = rad2; 

623: 

624: fprintf( logfile, 

625: "\n# f(x|a) =0= (x1-%f)**2 + (x2-%f)**2 - %f**2", 

626: a[0], a[1], a[2]); 

627: 


629: } 

630: 

631: /*--------------------------------------------------------------- 

632: * init_rotation() 

633: * 21... f1(x|a) = a1 + cos(a3) * x1 - sin(a3) * x2 

634: * f2(x|a) = a2 + sin(a3) * x1 + cos(a3) * x2 

635: *-------------------------------------------------------------*/ 

636: int 

637: init_rotation( int N, double *obs, double *cond, 


639: { 


641: int i; 

642: double sum_x, sum_y, sum_u, sum_v; 

643: 

644: fprintf( logfile, "\n#\n# init_rotation()"); 

645: 

646: /* 

647: * determine rough translation 

648: */ 

649: 

650: /* compute centroids of conditions and observations */ 

651: sum_x = sum_y = 0; 

652: sum_u = sum_v = 0; 

653: /* assume double observations and conditions */ 

654: for (i = 0; i < N * 2; i+=2) 

655: { 

656: sum_x += obs[i]; 

657: sum_y += obs[i+1]; 

658: sum_u += cond[i]; 

659: sum_v += cond[i+1]; 

660: } 

661: sum_x /= (double)N; 

662: sum_y /= (double)N; 

663: sum_u /= (double)N; 

664: sum_v /= (double)N; 

665: fprintf( logfile, "\n#\n# mean of condition coordinates"); 

666: fprintf( logfile, "\n# mean(u)= %f", sum_u); 

667: fprintf( logfile, "\n# mean(v)= %f", sum_v); 

668: fprintf( logfile, "\n# mean of observed coordinates"); 

669: fprintf( logfile, "\n# mean(x)= %f", sum_x); 

670: fprintf( logfile, "\n# mean(y)= %f", sum_y); 

671: 

672: if (!a_flag[0]) a[0] = sum_x - sum_u; 

673: if (!a_flag[1]) a[1] = sum_y - sum_v; 

674: if (!a_flag[2]) a[2] = 0; /* assume no rotation */ 

675: 

676: 


678: "\n# f1(u,v) = %f + cos(%f) * u - sin(%f) * v", 

679: a[0], a[2], a[2]); 


681: "\n# f2(u,v) = %f + sin(%f) * u + cos(%f) * v", 

682: a[1], a[2], a[2]); 

683: 


685: } 

686: 

687: /*--------------------------------------------------------------- 

688: * init_NN3x3x1() 

689: * 3x3x1 

690: *--------------------------------------------------------------*/ 

691: int 

692: init_NN3x3x1( int N, double *obs, double *cond, 


694: { 

695: int i, j; 

696: double minval, maxval; 


698: struct timeval tv; 

699: struct timezone tz; 

700: 

701: gettimeofday( &tv, &tz); 

702: srandom( tv.tv_sec); 

703: #else 

704: /* Seed the random-number generator with current time so that 

705: * the numbers will be different every time we run. 

706: */ 

707: srand( (unsigned)time( NULL ) ); 

708: #endif 

709: 

710: /* give parameters random values */ 

711: for ( j = 0; j < M_MAX; j++) 

712: { 

713: if (!a_flag[j]) 

714: a[j] = 2. * (float)random()/ (float)RAND_MAX - 1.; 

715: } 

716: 

717: /* make random numbers in a range that |cond x param| < 5 */ 

718: minval = maxval = cond[0]; 

719: for ( i = 1; i < N; i++) 

720: { 

721: if (minval > cond[3*i]) minval = cond[3*i]; 

722: if (maxval < cond[3*i]) maxval = cond[3*i]; 

723: } 

724: /* weights from 1st input */ 

725: if (!a_flag[1]) a[1] = a[1] / (maxval-minval); 



728: 


730: for ( i = 1; i < N; i++) 

731: { 

732: if (minval > cond[3*i+1]) minval = cond[3*i+1]; 

733: if (maxval < cond[3*i+1]) maxval = cond[3*i+1]; 

734: } 

735: /* weights from 2nd input */ 



738: if (!a_flag[10])a[10]= a[10] / (maxval-minval); 

739: 


741: for ( i = 1; i < N; i++) 

742: { 

743: if (minval > cond[3*i+2]) minval = cond[3*i+2]; 

744: if (maxval < cond[3*i+2]) maxval = cond[3*i+2]; 

745: } 

746: /* weights from 3rd input */ 



749: if (!a_flag[11])a[11]= a[11]/ (maxval-minval); 

750: 


752: } 

753: 

754: /*--------------------------------------------------------------- 

755: * init_NN1x3x1() 

756: * 1x3x1 

757: *--------------------------------------------------------------*/ 

758: int 

759: init_NN1x3x1( int N, double *obs, double *cond, 


761: { 

762: int i, j;


763: double minval, maxval; 




767: 



770: #else 



773: */ 


775: #endif 

776: 

777: /* give parameters random values */ 

778: for ( j = 0; j < M_MAX; j++) 

779: { 

780: if (!a_flag[j]) 

781: { 

782: a[j] = 2. * (float)random() / (float)RAND_MAX - 1.; 

783: } 

784: } 

785: 

786: /* make random numbers in a range that |cond x param| < 5 */ 


788: for ( i = 1; i < N; i++) 

789: { 

790: if (minval > cond[i]) minval = cond[i]; 

791: if (maxval < cond[i]) maxval = cond[i]; 

792: } 

793: /* weights from 1st input */ 




797: 


799: } 

800: 

801: /*--------------------------------------------------------------- 

802: * init_NN() 

803: * 3x... 

804: *--------------------------------------------------------------*/ 

805: int 

806: init_NN( int N, double *obs, double *cond, 


808: { 

809: int j; 




813: 



816: #else 



819: */ 


821: #endif 

822: 

823: for ( j = 0; j < M_MAX; j++) 

824: { 

825: if (!a_flag[j]) 

826: { 

827: a[j] = 1. * (float)random() / (float)RAND_MAX - 0.5; 

828: } 

829: } 


831: } 

0: /***************************************************************** 

1: * 

2: * File........: init_gauss2.c 


4: * data fitting with 2 Gaussians 


6: * last changes: 02.07.2009 

7: * 





12: * 

13: *****************************************************************/ 

14: #include 

15: #include 

16: #include 

17: #include 



20: 

21: /*--------------------------------------------------------------- 

22: * init_gauss1() 

23: * f(x|a) = a1 * exp( (x-a2)^2 * a3) 

24: *--------------------------------------------------------------*/ 

25: int 

26: init_gauss1( int N, double *obs, double *cond, 

27: double *a, unsigned char *a_flag, 

28: int peak_flag, FILE *logfile) 

29: { 


31: int i; 

32: int i_mean = 0, i_max, i_min; 

33: double max_val, min_val, condmin=0., condmax=0.; 

34: double mean, var, sum, sigma, tmp; 

35: 

36: /* 

37: * get starting point 

38: * assuming that one Gaussian is good enough to fit the data 

39: */ 

40: 

41: /* get peak of curve */ 

42: max_val = min_val = obs[1]; 

43: i_max = i_min = 1; 

44: condmax = cond[1]; 

45: condmin = cond[1]; 

46: for (i = 2; i < N-1; i++) /* let 1 sample border */ 

47: { 

48: if (max_val < obs[i]) 

49: { 

50: max_val = obs[i]; 

51: i_max = i; /* peak position index */ 

52: condmax = cond[i]; /* peak position */ 

53: } 

54: if (min_val > obs[i]) 

55: { 

56: min_val = obs[i]; 

57: i_min = i; /* peak position */ 

58: condmin = cond[i]; 

59: } 

60: } 

61: if (max_val == min_val) 

62: { 

63: fprintf( logfile, "\n\n Nothing to fit !!"); 

64: a[0] = 0.; 

65: a[2] = -50000000.0; 

66: a[1] = 0.; 

67: err = 8; 


69: } 

70: 

71: mean = sum = var = 0.; 

72: /* take only that part which has the highest peak */ 

73: if (fabs(max_val) > fabs(min_val)) 

74: { 

75: /* positive amplitude */ 

76: for (i = 0; i < N; i++) 

77: { 

78: if (obs[i] > 0.) 

79: { 

80: /* mean and variance of condition 

81: * observed value is like probability 

82: */ 

83: tmp = cond[i] * obs[i]; 

84: mean += tmp; 


86: sum += obs[i]; 

87: } 

88: } 

89: if (sum > 0.) 

90: { 

91: mean /= sum; /* average along cond[i] */ 


93: } 

94: } 

95: else 

96: { 

97: /* negative amplitude */ 

98: for (i = 0; i < N; i++) 

99: { 

100: if (obs[i] < 0.) 

101: { 

102: tmp = - cond[i] * obs[i]; 

103: mean += tmp; 


105: sum -= obs[i]; 

106: } 

107: } 

108: if (sum > 0.) 

109: { 

110: mean /= sum; 


112: } 

113: } 

114: /* if only one data point, then sigma is zero */ 

115: if (var > 0.) sigma = sqrt( var); /* deviation of Gaussian */ 

116: else 

117: sigma = 0.0000001; 

118: 

119: 

120: /* get index of mean position */


121: for (i = 1; i < N; i++) 

122: { 

123: if (cond[i-1] fabs(mean - condmax)) 

142: sigma -= fabs(mean - condmax); 

143: } 

144: else 

145: { 

146: /* increase by value dependent on obs at mean position */ 

147: if (!a_flag[0]) 

148: { 

149: a[0] = max_val + (max_val - obs[i_mean]) * 0.5; 

150: } 

151: if (!a_flag[1]) a[1] = mean; 

152: } 

153: } 

154: else 

155: { 

156: if (peak_flag) 

157: { 

158: if (!a_flag[0]) a[0] = min_val; 

159: if (!a_flag[1]) a[1] = condmin; 

160: if (sigma > fabs(mean-condmin)) sigma -= fabs(mean-condmin); 

161: } 

162: else 

163: { 

164: if (!a_flag[0]) 

165: { 

166: a[0] = max_val + (max_val - obs[i_mean]) * 0.5; 

167: } 

168: if (!a_flag[1]) a[1] = mean; 

169: } 

170: } 

171: /* transcode deviation */ 

172: if (!a_flag[2]) a[2] = -0.5 / (sigma*sigma); 

173: 

174: endfunc: 


176: } 

177: 

178: /*--------------------------------------------------------------- 

179: * init_gauss2() 

180: * f(x|a) = a1 * exp( a2 * (x-a3)^2) + 

181: * a4 * exp( a5 * (x-a6)^2) 

182: *--------------------------------------------------------------*/ 

183: int 

184: init_gauss2( int N, double *obs, double *cond, 


186: { 


188: int i, M; 

189: double sigma1, sigma2; 

190: double *obs_cpy=NULL; 

191: 

192: M = 6; /* fixed number of parameters */ 

193: obs_cpy = vector( N); 

194: 

195: /* 

196: * get starting point 

197: * assuming that one Gaussian is good enough to fit the data 

198: */ 

199: /* initialises a[0], a[1], a[2]; select highest peak */ 

200: err = init_gauss1( N, obs, cond, a, a_flag, 1, out); 

201: if (err) goto endfunc; 

202: 

203: sigma2 = sqrt( -0.5 / a[2]); /* get deviation back */ 

204: 

205: fprintf( out, "\n# Initial parameter: first Gaussian"); 

206: fprintf( out, "\n# amplitude: %f, mean: %f, deviation: %f", 

207: a[0], a[1], sigma2); 

208: /* 

209: * compute residuals between observation and model 

210: */ 

211: for ( i = 0; i < N; i++) 

212: { 

213: obs_cpy[i] = obs[i] - fgauss1( i, cond, a); 

214: } 

215: /* prevent overwriting of first three parameters */ 

216: a[3] = a[0]; 

217: a[4] = a[1]; 

218: a[5] = a[2]; 

219: 

220: /* initialises a[0], a[1], a[2]; fitting of residual */ 

221: init_gauss1( N, obs_cpy, cond, a, a_flag, 1, out); 

222: sigma1 = sqrt( -0.5 / a[2]); 

223: fprintf( out, "\n# Initial parameter: second Gaussian"); 

224: fprintf( out, "\n# amplitude: %f, mean: %f, deviation: %f", 

225: a[0], a[1], sigma1); 

226: 

227: fprintf( out, "\n#\n# f(x) = %f * exp( ( x- %f)**2 * %f)", 

228: a[0],a[1],a[2]); 

229: fprintf( out, "+ %f * exp( ( x- %f)**2 * %f)", 

230: a[3],a[4],a[5]); 

231: endfunc: 

232: free_vector( &obs_cpy); 


234: } 

0: 

1: /***************************************************************** 

2: * 

3: * File........: init_NIST.c 


5: * different functions 


7: * last changes: 28.09.2009, 20.01.2010 

8: * 





13: * 

14: *****************************************************************/ 

15: #include 

16: #include 

17: #include 

18: #include 




22: #include 

23: #else 

24: #include 


26: #endif 

27: 

28: /*--------------------------------------------------------------- 

29: * init_NIST_Eckerle4() 

30: * f(x|a) = a1 / a2 * exp(-0.5*((x -a3)/ a2)^2) 

31: *--------------------------------------------------------------*/ 

32: int 

33: init_NIST_Eckerle4( int N, double *obs, double *cond, 


35: { 

36: int i, maxpos; 

37: double maxval; 

38: 

39: /* estimated parameter of a Gaussian bell */ 

40: 

41: /* get mean value at maximum point */ 

42: if (!a_flag[2]) 

43: { 

44: maxval = obs[0]; 

45: maxpos = 0; 

46: a[2] = cond[0]; 

47: for ( i = 1; i < N; i++) 

48: { 

49: if (maxval < obs[i]) 

50: { 

51: maxval = obs[i]; 

52: maxpos = i; 

53: a[2] = cond[i]; 

54: } 

55: } 

56: } 

57: /* get sigma */ 

58: if (!a_flag[1]) 

59: { 

60: for ( i = maxpos+1; i < N; i++) 

61: { 

62: if (obs[i] < maxval/2) 

63: { 

64: a[1] = i - maxpos; 

65: break; 

66: } 

67: } 

68: } 

69: /* get magnification */ 

70: if (!a_flag[0]) 

71: { 

72: a[0] = maxval * a[1]; 

73: } 

74: 

75: return 0;


76: } 

172: /* set 1 */ 

77: 

173: if (!a_flag[0]) a[0] = -2000; 

78: /*--------------------------------------------------------------- 174: if (!a_flag[1]) a[1] = 50; 

79: * init_NIST_Rat43() 

175: if (!a_flag[2]) a[2] = 0.8; 

80: * f(x|a) = a1 / (1 + exp(a2 - a3*x)^(1/a4)) 

176: 

81: *--------------------------------------------------------------*/ 177: return 0; 

82: int 

178: } 

83: init_NIST_Rat43( int N, double *obs, double *cond, 

179: 

84: double *a, unsigned char *a_flag, FILE *logfile) 180: /*--------------------------------------------------------------- 

85: { 

181: * init_NIST_BoxBOD() 

86: /* set 1 */ 

182: * f(x|a) = a1 * (1 - exp( -a2 * x) ) 

87: if (!a_flag[0]) a[0] = 100; 

183: *--------------------------------------------------------------*/ 

88: if (!a_flag[1]) a[1] = 10; 

184: int 

89: if (!a_flag[2]) a[2] = 1; 

185: init_NIST_BoxBOD( int N, double *obs, double *cond, 

90: if (!a_flag[3]) a[3] = 1; 


91: 

187: { 

92: return 0; 


93: } 

189: double mean, maxval; 

94: 

190: 

95: /*--------------------------------------------------------------- 191: itmp = MAX( 0, MIN( 5, N)); 

96: * init_NIST_Rat42() 

192: 

97: * f(x|a) = a1 / (1 + exp(a2 - a3*x)) 


98: *--------------------------------------------------------------*/ 194: if (!a_flag[0]) 

99: int 

195: { 

100: init_NIST_Rat42( int N, double *obs, double *cond, 

196: maxval = obs[0]; 

101: double *a, unsigned char *a_flag, FILE *logfile) 197: for (i = 1; i < itmp; i++) 

102: { 

198: { 

103: /* set 1 */ 

199: if (maxval < obs[i]) maxval = obs[i]; 

104: if (!a_flag[0]) a[0] = 100; 

200: } 

105: if (!a_flag[1]) a[1] = 10; 

201: a[0] = maxval; 

106: if (!a_flag[2]) a[2] = 0.1; 

202: } 

107: 

203: /* estimation of a1*a2 = gradient at head of function */ 


204: if (!a_flag[1]) 

109: } 

205: { 

110: 

206: mean = 0; 

111: /*--------------------------------------------------------------- 207: for (i = 1; i < itmp; i++) 

112: * init_NIST_thurber() 

208: mean += (obs[i] - obs[i - 1]) / (cond[i] - cond[i - 1]); 

113: * f(x|a) =(a1 + a2*x + a3*x**2 + a4*x**3) / 

209: a[1] = mean / (itmp) / a[0]; 

114: * (1 + a5*x + a6*x**2 + a7*x**3) 

210: /* use moderate value */ 

115: *--------------------------------------------------------------*/ 211: if (a[1] > 2.) a[1] = 2.; 

116: int 

212: } 

117: init_NIST_thurber( int N, double *obs, double *cond, 213: 

118: double *a, unsigned char *a_flag, FILE *logfile) 214: return 0; 

119: { 

215: } 

120: /* set 1 */ 

121: if (!a_flag[0]) a[0] = 1000; 

122: if (!a_flag[1]) a[1] = 1000; 

123: if (!a_flag[2]) a[2] = 400; 

124: if (!a_flag[3]) a[3] = 40; 

125: if (!a_flag[4]) a[4] = 0.7; 

126: if (!a_flag[5]) a[5] = 0.3; 

127: if (!a_flag[6]) a[6] = 0.03; 

128: 


130: } 

131: 

132: /*--------------------------------------------------------------- 

133: * init_NIST_MGH09() 

134: * f(x|a) = a1 * (x**2 + a2*x) / (x*x + a3*x + a4) 

135: *--------------------------------------------------------------*/ 

136: int 

137: init_NIST_MGH09( int N, double *obs, double *cond, 

138: 

139: { 

double *a, unsigned char *a_flag, FILE *logfile) 

140: /* set 1 */ 

141: if (!a_flag[0]) a[0] = 25; 

142: if (!a_flag[1]) a[1] = 39; 

143: if (!a_flag[2]) a[2] = 41.5; 

144: if (!a_flag[3]) a[3] = 39; 

145: 


147: } 

148: 

149: /*--------------------------------------------------------------- 

150: * init_NIST_MGH10() 

151: * f(x|a) = a1 * exp( a2 / (x+a3)) 

152: *--------------------------------------------------------------*/ 

153: int 

154: init_NIST_MGH10( int N, double *obs, 

155: 

156: { 

double *cond, double *a, unsigned char *a_flag, FILE *out) 

157: /* set 1 */ 

158: if (!a_flag[0]) a[0] = 2; 

159: if (!a_flag[1]) a[1] = 400000; 

160: if (!a_flag[2]) a[2] = 25000; 

161: 


163: } 

164: /*--------------------------------------------------------------- 

165: * init_NIST_Bennett5() 

166: * f(x|a) = a1 * (x+a2)^(-1/a3) 

167: *--------------------------------------------------------------*/ 

168: int 

169: init_NIST_Bennett5( int N, double *obs, 

170: 

171: { 

double *cond, double *a, unsigned char *a_flag, FILE *out)


S.5 Matrix processing 

S.5.1 Utils 

0: /***************************************************************** 

1: * 

2: * File........: decomp_LU.c 

3: * Function....: LU decomposition 


5: * last changes: 20.10.2007 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 



18: #define LITTLEBIT 1.0e-20; 

19: 

20: /*--------------------------------------------------------------- 

21: * decomp_LU() 

22: *--------------------------------------------------------------*/ 

23: int 

24: decomp_LU( double **normal, int M, int *indx, int *s) 

25: { 

26: char *rtn = "decomp_LU"; 

27: int err = 0, i, imax = 0, j, k; 

28: double max_element, val, sum, tmp; 

29: double *row_scale = NULL; /* scaling of each row */ 

30: 

31: /* allocate vector */ 

32: row_scale = vector( M); 

33: 

34: *s = 1; 

35: /* examine input matrix */ 

36: for (i = 0; i < M; i++) 

37: { 

38: max_element = 0.0; 

39: for (j = 0; j < M; j++) 

40: { 

41: if (( tmp = fabs( normal[i][j])) > max_element) 

42: max_element = tmp; 

43: } 

44: if (max_element == 0.0) 

45: { 

46: err = errmsg( ERR_IS_ZERO, rtn, "’max_element’", 0); 


48: } 

49: row_scale[i] = 1.0 / max_element; 

50: } 

51: /* loop over columns of Crout’s method */ 

52: for (j = 0; j < M; j++) 

53: { 

54: for (i = 0; i < j; i++) 

55: { 

56: sum = normal[i][j]; 

57: for (k = 0; k < i; k++) 

58: sum -= normal[i][k] * normal[k][j]; 

59: normal[i][j] = sum; 

60: } 

61: max_element = 0.0; 

62: for (i = j; i < M; i++) 

63: { 

64: sum = normal[i][j]; 

65: for (k = 0; k < j; k++) 

66: { 

67: sum -= normal[i][k] * normal[k][j]; 

68: } 

69: normal[i][j] = sum; 

70: /* is new pivot better than current best ? */ 

71: if (( val = row_scale[i] * fabs( sum)) >= max_element) 

72: { 

73: max_element = val; 

74: imax = i; 

75: } 

76: } 

77: if (j != imax) 

78: { 

79: /* interchange of rows */ 

80: for (k = 0; k < M; k++) 

81: { 

82: val = normal[imax][k]; 

83: normal[imax][k] = normal[j][k]; 

84: normal[j][k] = val; 

85: } 

86: *s = -( *s); 

87: /* interschange scale factors */ 

88: row_scale[imax] = row_scale[j]; 

89: } 

90: indx[j] = imax; 

91: if (normal[j][j] == 0.0) 

92: normal[j][j] = LITTLEBIT; 

93: if (j != (M - 1)) 

94: { 

95: /* divide by the pivot element */ 

96: val = 1.0 / (normal[j][j]); 

97: for (i = j + 1; i < M; i++) 

98: normal[i][j] *= val; 

99: } 

100: /* next column in reduction */ 

101: } 

102: 

103: endfunc: 

104: free_vector( &row_scale); 


106: } 

107: 

108: /*--------------------------------------------------------------- 

109: * backsub_LU() 

110: *--------------------------------------------------------------*/ 

111: void 

112: backsub_LU( double **lu, int N, int *indx, double back[]) 

113: { 

114: int i, ii, idx, j; 

115: double sum; 

116: 

117: ii = -1; 

118: for (i = 0; i < N; i++) 

119: { 

120: idx = indx[i]; 

121: sum = back[idx]; 

122: back[idx] = back[i]; 

123: if (ii >= 0.) 

124: { 

125: for (j = ii; j = 0; i--) 

133: { 

134: sum = back[i]; 

135: for (j = i + 1; j < N; j++) 

136: sum -= lu[i][j] * back[j]; 

137: back[i] = sum / lu[i][i]; 

138: } 

139: } 

0: /***************************************************************** 

1: * 

2: * File........: svd_inversion.c 

3: * Function....: matrix inversion via SVD 


5: * last changes: 18.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 

15: #include 

16: #include 






22: 

23: /*--------------------------------------------------------------- 

24: * svd_inversion() 

25: * 

26: *--------------------------------------------------------------*/ 

27: int 

28: svd_inversion( int M, double **normal, double **normal_i, FILE *out) 

29: { 

30: char *rtn = "svd_inversion"; 

31: int i, j, err = 0; 

32: double thresh, smax; 


34: double *s = NULL; /* singular values */ 

35: double **V = NULL; /* V matrix */ 

36: 

37: V = matrix( M, M); /* V matrix for SVD */ 

38: s = vector( M); /* singular values for SVD */ 

39: tmpmat = matrix( M, M); /* temporary matrix */ 

40: 

41: err = singvaldec( normal, M, M, s, V); 

42: if (err) 

43: { 

44: free_matrix( &V);

S.5 Matrix processing 39 

45: free_vector( &s); 



48: } 

49: 

50: smax = 0.0; 

51: for (j = 0; j < M; j++) 

52: { 

53: if (s[j] > smax) smax = s[j]; 

54: } 

55: if (smax < TOL_S2) 

56: { 





61: 

62: err = 1; 


64: } 

65: else if (smax > 1.e+31) 

66: { 





71: err = 1; 


73: } 

74: 

75: thresh = MIN( TOL_S * smax, TOL_S); 

76: 

77: /* invert singular values */ 

78: for (j = 0; j < M; j++) 

79: { 

80: /* abs_b) 

33: { 

34: dval = abs_b / abs_a; 

35: val = abs_a * sqrt( 1.0 + dval * dval); 

36: return val; 

37: } 

38: else 

39: { 

40: if (abs_b == 0.0) 

41: return 0.0; 

42: else 

43: { 

44: dval = abs_a / abs_b; 

45: val = abs_b * sqrt( 1.0 + dval * dval); 

46: return val; 

47: } 

48: } 

49: } 

50: 

51: /*--------------------------------------------------------------- 

52: * singvaldec() 

53: * singular value decomposition 

54: * translation from http://www.pdas.com/programs/fmm.f90 

55: *--------------------------------------------------------------*/ 

56: int 

57: singvaldec( double **a, int N, int M, double w[], double **v) 

58: { 

59: char *rtn = "singvaldec"; 

60: int err = 0; 

61: int flag, i, its, j, jj, k, l = 0, nm; 

62: double anorm, c, f, g, h, s, scale, x, y, z, *rv1; 

63: 

64: rv1 = vector( M); 

65: 

66: /* 

67: * housholder reduction to bidiagonal form 

68: */ 

69: g = scale = anorm = 0.0; 

70: for (i = 0; i < M; i++) 

71: { 

72: l = i + 1; 

73: assert( i >= 0); 

74: rv1[i] = scale * g; 

75: g = s = scale = 0.0; 

76: if (i < N) 

77: { 

78: for (k = i; k < N; k++) 

79: { 

80: scale += fabs( a[k][i]); 

81: } 

82: if (scale) 

83: { 

84: for (k = i; k < N; k++) 

85: { 

86: a[k][i] /= scale; 

87: s += a[k][i] * a[k][i]; 

88: } 

89: f = a[i][i]; 

90: g = -SIGN( sqrt( s), f); 

91: h = f * g - s; 

92: a[i][i] = f - g; 

93: for (j = l; j < M; j++) 

94: { 

95: s = 0.0; 

96: for (k = i; k < N; k++) 

97: { 

98: s += a[k][i] * a[k][j]; 

99: } 

100: f = s / h; 

101: for (k = i; k < N; k++) 

102: a[k][j] += f * a[k][i]; 

103: } 

104: for (k = i; k < N; k++) 

105: a[k][i] *= scale; 

106: } 

107: } 

108: w[i] = scale * g; 

109: g = s = scale = 0.0; 

110: if (i < N && i != M - 1) 

111: { 

112: for (k = l; k < M; k++) 

113: { 

114: scale += fabs( a[i][k]); 

115: } 

116: if (scale) 

117: { 

118: for (k = l; k < M; k++) 

119: { 

120: a[i][k] /= scale; 

121: s += a[i][k] * a[i][k]; 

122: } 

123: f = a[i][l]; 

124: g = -SIGN( sqrt( s), f); 

125: h = f * g - s; 

126: a[i][l] = f - g;


127: for (k = l; k < M; k++) 

128: { 

129: assert( k >= 0); 

130: rv1[k] = a[i][k] / h; 

131: } 

132: for (j = l; j < N; j++) 

133: { 

134: for (s = 0.0, k = l; k < M; k++) 

135: s += a[j][k] * a[i][k]; 

136: for (k = l; k < M; k++) 

137: a[j][k] += s * rv1[k]; 

138: } 

139: for (k = l; k < M; k++) 

140: a[i][k] *= scale; 

141: } 

142: } 

143: anorm = MAX( anorm, (fabs( w[i]) + fabs( rv1[i]))); 

144: } 

145: 

146: /* 

147: * accumulation of right-hand transformations 

148: */ 

149: for (i = M - 1; i >= 0; i--) 

150: { 

151: if (i < M - 1) 

152: { 

153: if (g) 

154: { 

155: for (j = l; j < M; j++) 

156: { 

157: v[j][i] = (a[i][j] / a[i][l]) / g; 

158: } 

159: for (j = l; j < M; j++) 

160: { 

161: for (s = 0.0, k = l; k < M; k++) 

162: s += a[i][k] * v[k][j]; 

163: for (k = l; k < M; k++) 

164: v[k][j] += s * v[k][i]; 

165: } 

166: } 

167: for (j = l; j < M; j++) 

168: v[i][j] = v[j][i] = 0.0; 

169: } 

170: v[i][i] = 1.0; 

171: assert( i >= 0); 

172: g = rv1[i]; 

173: l = i; 

174: } 

175: 

176: /* 

177: * accumulation of left-hand transformations 

178: */ 

179: for (i = MIN( N, M) - 1; i >= 0; i--) 

180: { 

181: l = i + 1; 

182: g = w[i]; 

183: for (j = l; j < M; j++) 

184: a[i][j] = 0.0; 

185: if (g) 

186: { 

187: g = 1.0 / g; 

188: for (j = l; j < M; j++) 

189: { 

190: for (s = 0.0, k = l; k < N; k++) 

191: s += a[k][i] * a[k][j]; 

192: f = (s / a[i][i]) * g; 

193: for (k = i; k < N; k++) 

194: a[k][j] += f * a[k][i]; 

195: } 

196: for (j = i; j < N; j++) 

197: a[j][i] *= g; 

198: } 

199: else 

200: { 

201: for (j = i; j < N; j++) 

202: a[j][i] = 0.0; 

203: } 

204: ++a[i][i]; 

205: } 

206: 

207: /* 

208: * diagonalization of the bidiagonal form 

209: */ 

210: for (k = M - 1; k >= 0; k--) /* loop over singular values */ 

211: { 

212: assert( k >= 0); 

213: for (its = 0; its < 30; its++) /* loop over allowed 

214: iterations */ 

215: { 

216: flag = 1; 

217: for (l = k; l >= 0; l--) /* test for splitting */ 

218: { 

219: nm = l - 1; /* note that rv1[1] is always zero */ 

220: if (( double)( fabs( rv1[l]) + anorm) == anorm) 

221: { 

222: flag = 0; 

223: break; 

224: } 

225: if (( double)( fabs( w[nm]) + anorm) == anorm) 

226: break; 

227: } 

228: if (flag) 

229: { 

230: assert( l >= 0); 

231: c = 0.0; /* cancellation of rv1[l] if l greater than 1 */ 

232: s = 1.0; 

233: for (i = l; i < k; i++) 

234: { 

235: f = s * rv1[i]; 

236: rv1[i] = c * rv1[i]; 

237: if (( double)( fabs( f) + anorm) == anorm) 

238: break; 

239: g = w[i]; 

240: h = euclid_dist( f, g); 

241: w[i] = h; 

242: h = 1.0 / h; 

243: c = g * h; 

244: s = -f * h; 

245: for (j = 0; j < N; j++) 

246: { 

247: y = a[j][nm]; 

248: z = a[j][i]; 

249: a[j][nm] = y * c + z * s; 

250: a[j][i] = z * c - y * s; 

251: } 

252: } 

253: } 

254: /* test for convergence */ 

255: z = w[k]; 

256: if (l == k) 

257: { 

258: if (z < 0.0) /* singular value is made non-negative */ 

259: { 

260: w[k] = -z; 

261: for (j = 0; j < M; j++) 

262: v[j][k] = -v[j][k]; 

263: } 

264: break; 

265: } 

266: if (its == 30) 

267: { 


269: "\n%s: No convergence after 30 iterations(SVD)\n", rtn); 

270: err = 57; 


272: } 

273: /* shift from bottom 2 by 2 minor */ 

274: x = w[l]; 

275: nm = k - 1; 

276: y = w[nm]; 

277: g = rv1[nm]; 

278: assert( k >= 0); 

279: h = rv1[k]; 

280: f = 

281: ( (y - z) * (y + z) + (g - h) * (g + 

282: h)) / (2.0 * h * y); 

283: g = euclid_dist( f, 1.0); 

284: f = 

285: ( (x - z) * (x + z) + h * (( y / (f + SIGN( g, 

286: f))) - h)) / x; 

287: 

288: /* next qr transformation */ 

289: c = s = 1.0; 

290: for (j = l; j = 0); 

294: g = rv1[i]; 

295: y = w[i]; 

296: h = s * g; 

297: g = c * g; 

298: z = euclid_dist( f, h); 

299: rv1[j] = z; 

300: c = f / z; 

301: s = h / z; 

302: f = x * c + g * s; 

303: g = g * c - x * s; 

304: h = y * s; 

305: y *= c; 

306: for (jj = 0; jj < M; jj++) 

307: { 

308: x = v[jj][j]; 

309: z = v[jj][i]; 

310: v[jj][j] = x * c + z * s; 

311: v[jj][i] = z * c - x * s; 

312: } 

313: z = euclid_dist( f, h); 

314: w[j] = z; 

315: if (z) /* rotation can be arbitrary if z is zero */ 

316: { 

317: z = 1.0 / z; 

318: c = f * z;


319: s = h * z; 

320: } 

321: f = c * g + s * y; 

322: x = c * y - s * g; 

323: for (jj = 0; jj < N; jj++) 

324: { 

325: y = a[jj][j]; 

326: z = a[jj][i]; 

327: a[jj][j] = y * c + z * s; 

328: a[jj][i] = z * c - y * s; 

329: } 

330: } 

331: assert( l >= 0); 

332: assert( k >= 0); 

333: rv1[l] = 0.0; 

334: rv1[k] = f; 

335: w[k] = x; 

336: } 

337: } 

338: 

339: endfunc: 

340: free_vector( &rv1); 


342: } 

S.5.2 Allocation and matrix handling 

0: /***************************************************************** 

1: * 

2: * File........: matrix_utils.c 

3: * Function....: special functions for matrices 


5: * last changes: 20.10.2009 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 


16: 

17: /*--------------------------------------------------------------- 

18: * vector() 

19: * create a vector with subscript range v[0..N-1] 

20: *--------------------------------------------------------------*/ 

21: double *vector( long N) 

22: { 

23: int err = 0; 

24: double *v; 

25: 

26: v = (double*)calloc( N, sizeof(double)); 

27: if (v == NULL) 

28: { 

29: err = errmsg( ERR_ALLOCATE, "vector", " ", 0); 

30: exit( err); 

31: } 

32: return v; 

33: } 

34: 

35: /*--------------------------------------------------------------- 

36: * fvector() 


38: *--------------------------------------------------------------*/ 

39: float *fvector( long N) 

40: { 

41: int err = 0; 

42: float *v; 

43: 

44: v = (float*)calloc( N, sizeof(float)); 

45: if (v == NULL) 

46: { 



49: } 

50: return v; 

51: } 

52: 

53: /*--------------------------------------------------------------- 

54: * ivector() 


56: *--------------------------------------------------------------*/ 

57: int * 

58: ivector( long N) 

59: { 

60: int err = 0; 

61: int *v; 

62: 

63: v = (int*)calloc( N, sizeof(int)); 

64: if (v == NULL) 

65: { 



68: } 

69: return v; 

70: } 

71: 

72: /*--------------------------------------------------------------- 

73: * matrix() 

74: * create a matrix with subscript range v[0..M-1][0..N-1] 

75: *--------------------------------------------------------------*/ 

76: double ** 

77: matrix( long N, long M) 

78: { 

79: int err = 0; 

80: long i; 

81: double **m; 

82: 

83: /* allocate pointers to rows */ 

84: m = (double **)malloc( N * sizeof(double*)); 

85: if (m == NULL) 

86: { 

87: err = errmsg( ERR_ALLOCATE, "matrix", " ", 0); 


89: } 

90: 

91: /* allocate rows and set pointers to them */ 

92: m[0] = (double*)calloc( M * N, sizeof(double)); 

93: if (m[0] == NULL) 

94: { 



97: } 

98: 

99: for (i = 1; i < N; i++) 

100: { 

101: m[i] = m[i - 1] + M; 

102: } 

103: 

104: /* return pointer to array of pointers to rows */ 

105: return m; 

106: } 

107: /*--------------------------------------------------------------- 

108: * fmatrix() 

109: * create a matrix with subscript range v[0..M-1][0..N-1] 

110: *--------------------------------------------------------------*/ 

111: float ** 

112: fmatrix( long N, long M) 

113: { 

114: int err = 0; 

115: long i; 

116: float **m; 

117: 

118: /* allocate pointers to rows */ 

119: m = (float **)malloc( N * sizeof(float*)); 

120: if (m == NULL) 

121: { 



124: } 

125: 

126: /* allocate rows and set pointers to them */ 

127: m[0] = (float*)calloc( M * N, sizeof(float)); 

128: if (m[0] == NULL) 

129: { 



132: } 

133: 

134: for (i = 1; i < N; i++) 

135: { 

136: m[i] = m[i - 1] + M; 

137: } 

138: 

139: /* return pointer to array of pointers to rows */ 

140: return m; 

141: } 

142: 

143: /*--------------------------------------------------------------- 

144: * free a vector allocated by vector() 

145: *--------------------------------------------------------------*/ 

146: void 

147: free_vector( double *v[]) 

148: { 

149: if (*v != NULL) 

150: free( *v); 

151: *v = NULL; 

152: } 

153: 

154: /*--------------------------------------------------------------- 

155: * free a vector allocated by vector() 

156: *--------------------------------------------------------------*/ 

157: void 

158: free_ivector( int *v[]) 

159: { 

160: if (*v != NULL) 

161: free( *v);


162: *v = NULL; 

258: a[1][1] * ( 

163: } 

259: a[2][2] * (-a[3][0]*a[0][3]*a[4][4] - a[3][3]*a[4][0]*a[0][4] 

164: 

260: +a[4][0]*a[0][3]*a[3][4] + a[4][3]*a[3][0]*a[0][4] ) + 

165: /*--------------------------------------------------------------- 261: a[3][0] * (+a[0][2]*a[2][3]*a[4][4] + a[0][3]*a[4][2]*a[2][4] ) + 

166: * free a matrix allocated by matrix() 

262: a[3][2] * (+a[2][0]*a[0][3]*a[4][4] + a[2][3]*a[4][0]*a[0][4] ) + 

167: *--------------------------------------------------------------*/ 263: a[3][3] * (-a[2][0]*a[0][2]*a[4][4] + a[4][0]*a[0][2]*a[2][4] 

168: void 

264: +a[4][2]*a[2][0]*a[0][4] ) + 

169: free_matrix( double **m[]) 

265: a[4][0] * (-a[0][2]*a[2][3]*a[3][4] - a[0][3]*a[3][2]*a[2][4] ) + 

170: { 

266: a[4][2] * (-a[2][0]*a[0][3]*a[3][4] - a[2][3]*a[3][0]*a[0][4] ) + 

171: 

267: a[4][3] * (+a[2][0]*a[0][2]*a[3][4] - a[3][0]*a[0][2]*a[2][4] 

172: if (*m != NULL) 

268: -a[3][2]*a[2][0]*a[0][4] ) 

173: { 

269: ) + 

174: if (*m[0] != NULL) 

270: a[2][2] * ( 

175: free( *m[0]); 

271: a[3][0] * (+a[0][1]*a[1][3]*a[4][4] + a[0][3]*a[4][1]*a[1][4] ) + 

176: free( *m); 

272: a[3][1] * (+a[1][0]*a[0][3]*a[4][4] + a[1][3]*a[4][0]*a[0][4] ) + 

177: } 

273: a[3][3] * (-a[1][0]*a[0][1]*a[4][4] + a[4][0]*a[0][1]*a[1][4] 

178: *m = NULL; 

274: +a[4][1]*a[1][0]*a[0][4] ) + 

179: } 

275: a[4][0] * (-a[0][1]*a[1][3]*a[3][4] - a[0][3]*a[3][1]*a[1][4] ) + 

180: 

276: a[4][1] * (-a[1][0]*a[0][3]*a[3][4] - a[1][3]*a[3][0]*a[0][4] ) + 

181: /*--------------------------------------------------------------- 277: a[4][3] * (+a[1][0]*a[0][1]*a[3][4] - a[3][0]*a[0][1]*a[1][4] 

182: * free a matrix allocated by fmatrix() 

278: -a[3][1]*a[1][0]*a[0][4] ) 

183: *--------------------------------------------------------------*/ 279: ) + 

184: void 

280: a[3][0] * ( 

185: free_fmatrix( float **m[]) 

281: a[0][1] * (-a[1][2]*a[2][3]*a[4][4] - a[1][3]*a[4][2]*a[2][4] ) + 

186: { 

282: a[0][2] * (-a[2][1]*a[1][3]*a[4][4] - a[2][3]*a[4][1]*a[1][4] ) + 

187: 

283: a[0][3] * (+a[2][1]*a[1][2]*a[4][4] - a[4][1]*a[1][2]*a[2][4] 

188: if (*m != NULL) 

284: -a[4][2]*a[2][1]*a[1][4] ) 

189: { 

285: ) + 

190: if (*m[0] != NULL) 

286: a[3][1] * ( 

191: free( *m[0]); 

287: a[1][0] * (-a[0][2]*a[2][3]*a[4][4] - a[0][3]*a[4][2]*a[2][4] ) + 

192: free( *m); 

288: a[1][2] * (-a[2][0]*a[0][3]*a[4][4] - a[2][3]*a[4][0]*a[0][4] ) + 

193: } 

289: a[1][3] * (+a[2][0]*a[0][2]*a[4][4] - a[4][0]*a[0][2]*a[2][4] 

194: *m = NULL; 

290: -a[4][2]*a[2][0]*a[0][4] ) 

195: } 

291: ) + 

196: 

292: a[3][2] * ( 

197: /*--------------------------------------------------------------- 293: a[2][0] * (-a[0][1]*a[1][3]*a[4][4] - a[0][3]*a[4][1]*a[1][4] ) + 

198: * determinant_2x2() 

294: a[2][1] * (-a[1][0]*a[0][3]*a[4][4] - a[1][3]*a[4][0]*a[0][4] ) + 

199: *--------------------------------------------------------------*/ 295: a[2][3] * (+a[1][0]*a[0][1]*a[4][4] - a[4][0]*a[0][1]*a[1][4] 

200: double 

296: -a[4][1]*a[1][0]*a[0][4] ) 

201: determinant_2x2( double **a) 

297: ) + 

202: { 

298: a[3][3] * ( 

203: return a[0][0] * a[1][1] - a[0][1] * a[1][0]; 

299: a[2][0] * (+a[0][1]*a[1][2]*a[4][4] + a[0][2]*a[4][1]*a[1][4] ) + 

204: } 

300: a[2][1] * (+a[1][0]*a[0][2]*a[4][4] + a[1][2]*a[4][0]*a[0][4] ) + 

205: 

301: a[4][0] * (-a[0][1]*a[1][2]*a[2][4] - a[0][2]*a[2][1]*a[1][4] ) + 

206: /*--------------------------------------------------------------- 302: a[4][1] * (-a[1][0]*a[0][2]*a[2][4] - a[1][2]*a[2][0]*a[0][4] ) + 

207: * determinant_3x3() 

303: a[4][2] * (+a[1][0]*a[0][1]*a[2][4] - a[2][0]*a[0][1]*a[1][4] 

208: *--------------------------------------------------------------*/ 304: -a[2][1]*a[1][0]*a[0][4] ) 

209: double 

305: ) + 

210: determinant_3x3( double **a) 

306: a[4][0] * ( 

211: { 

307: a[0][1] * (+a[1][2]*a[2][3]*a[3][4] + a[1][3]*a[3][2]*a[2][4] ) + 

212: /* The numerical stability depends on the order of operations. 308: a[0][2] * (+a[2][1]*a[1][3]*a[3][4] + a[2][3]*a[3][1]*a[1][4] ) + 

213: * The discrimination below works for the mentioned data sets 309: a[0][3] * (-a[2][1]*a[1][2]*a[3][4] + a[3][1]*a[1][2]*a[2][4] 

214: * in Release mode, but should evaluated in more detail 310: +a[3][2]*a[2][1]*a[1][4] ) 

215: */ 

311: ) + 

216: if (fabs(a[0][0]) < 1) 

312: a[4][1] * ( 

217: return 

313: a[1][0] * (+a[0][2]*a[2][3]*a[3][4] + a[0][3]*a[3][2]*a[2][4] ) + 

218: /* better performance for Eckerle4.dat */ 

314: a[1][2] * (+a[2][0]*a[0][3]*a[3][4] + a[2][3]*a[3][0]*a[0][4] ) + 

219: ( 

315: a[1][3] * (-a[2][0]*a[0][2]*a[3][4] + a[3][0]*a[0][2]*a[2][4] 

220: a[0][0] * (a[1][1] * a[2][2] - a[2][1] * a[1][2]) - 316: +a[3][2]*a[2][0]*a[0][4] ) 

221: a[0][1] * (a[1][0] * a[2][2] + a[2][0] * a[1][2]) 317: ) + 

222: ) + 

318: a[4][2] * ( 

223: a[0][2] * (a[1][0] * a[2][1] - a[2][0] * a[1][1]); 319: a[2][0] * (+a[0][1]*a[1][3]*a[3][4] + a[0][3]*a[3][1]*a[1][4] ) + 

224: else 

320: a[2][1] * (+a[1][0]*a[0][3]*a[3][4] + a[1][3]*a[3][0]*a[0][4] ) + 

225: return 

321: a[2][3] * (-a[1][0]*a[0][1]*a[3][4] + a[3][1]*a[1][0]*a[0][4] 

226: /* better performance for MGH10.dat*/ 

322: +a[3][0]*a[0][1]*a[1][4] ) 

227: a[0][0] * a[1][1] * a[2][2] - a[0][0] * a[2][1] * a[1][2] - 323: ) + 

228: a[0][1] * a[1][0] * a[2][2] + a[0][1] * a[2][0] * a[1][2] + 324: a[4][3] * ( 

229: a[0][2] * a[1][0] * a[2][1] - a[0][2] * a[2][0] * a[1][1]; 325: a[2][0] * (-a[0][1]*a[1][2]*a[3][4] - a[0][2]*a[3][1]*a[1][4] ) + 

230: } 

326: a[2][1] * (-a[1][0]*a[0][2]*a[3][4] - a[1][2]*a[3][0]*a[0][4] ) + 

231: 

327: a[3][0] * (+a[0][1]*a[1][2]*a[2][4] + a[0][2]*a[2][1]*a[1][4] )+ 

232: /*--------------------------------------------------------------- 328: a[3][1] * (+a[1][0]*a[0][2]*a[2][4] + a[1][2]*a[2][0]*a[0][4] )+ 

233: * inverse_5x5() 

329: a[3][2] * (-a[1][0]*a[0][1]*a[2][4] + a[2][0]*a[0][1]*a[1][4] 

234: * get the inverse of a square 5x5 matrix 

330: +a[2][1]*a[1][0]*a[0][4] ) 

235: * returns determinant 

331: ); 

236: *--------------------------------------------------------------*/ 332: 

237: double 

333: b[0][0] = -( 

238: inverse_5x5( double **a, double **b) 

334: a[1][1] * ( 

239: { 

335: a[2][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 


336: a[2][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

241: 

337: a[2][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

242: det = 

338: )+ 

243: a[0][0] * ( 

339: a[1][2] * ( 

244: a[1][1] * (+a[2][2]*a[3][3]*a[4][4] - a[2][2]*a[4][3]*a[3][4] 340: a[2][1] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

245: -a[3][2]*a[2][3]*a[4][4] - a[3][3]*a[4][2]*a[2][4] 341: a[2][3] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

246: +a[4][2]*a[2][3]*a[3][4] + a[4][3]*a[3][2]*a[2][4] ) + 342: a[2][4] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) 

247: a[2][2] * (-a[3][1]*a[1][3]*a[4][4] - a[3][3]*a[4][1]*a[1][4] 343: )+ 

248: +a[4][1]*a[1][3]*a[3][4] + a[4][3]*a[3][1]*a[1][4] ) + 344: a[1][3] * ( 

249: a[3][1] * (+a[1][2]*a[2][3]*a[4][4] + a[1][3]*a[4][2]*a[2][4] ) + 345: a[2][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

250: a[3][2] * (+a[2][1]*a[1][3]*a[4][4] + a[2][3]*a[4][1]*a[1][4] ) + 346: a[2][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

251: a[3][3] * (-a[2][1]*a[1][2]*a[4][4] + a[4][1]*a[1][2]*a[2][4] 347: a[2][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

252: +a[4][2]*a[2][1]*a[1][4] ) + 

348: )+ 

253: a[4][1] * (-a[1][2]*a[2][3]*a[3][4] - a[1][3]*a[3][2]*a[2][4] ) + 349: a[1][4] * ( 

254: a[4][2] * (-a[2][1]*a[1][3]*a[3][4] - a[2][3]*a[3][1]*a[1][4] ) + 350: a[2][1] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

255: a[4][3] * (+a[2][1]*a[1][2]*a[3][4] - a[3][1]*a[1][2]*a[2][4] 351: a[2][2] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

256: -a[3][2]*a[2][1]*a[1][4] ) 

352: a[2][3] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) 

257: ) + 

353: ));


354: 

355: b[0][1] = 

356: a[0][1] * ( 

357: a[2][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

358: a[2][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

359: a[2][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

360: )+ 

361: a[0][2] * ( 

362: a[2][1] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

363: a[2][3] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

364: a[2][4] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) 

365: )+ 

366: a[0][3] * ( 

367: a[2][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

368: a[2][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

369: a[2][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

370: )+ 

371: a[0][4] * ( 

372: a[2][1] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

373: a[2][2] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

374: a[2][3] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) 

375: ); 

376: 

377: b[0][2] = 

378: a[1][1] * ( 

379: a[0][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

380: a[0][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

381: a[0][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

382: )+ 

383: a[1][2] * ( 

384: a[0][1] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

385: a[0][3] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

386: a[0][4] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) 

387: )+ 

388: a[1][3] * ( 

389: a[0][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

390: a[0][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

391: a[0][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

392: )+ 

393: a[1][4] * ( 

394: a[0][1] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

395: a[0][2] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

396: a[0][3] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) 

397: ); 

398: 

399: b[0][3] = +( 

400: a[1][1] * ( 

401: a[2][2] * (-a[0][3]*a[4][4] + a[0][4]*a[4][3]) + 

402: a[2][3] * (+a[0][2]*a[4][4] - a[0][4]*a[4][2]) + 

403: a[2][4] * (-a[0][2]*a[4][3] + a[0][3]*a[4][2]) 

404: )+ 

405: a[1][2] * ( 

406: a[2][1] * (+a[0][3]*a[4][4] - a[0][4]*a[4][3]) + 

407: a[2][3] * (-a[0][1]*a[4][4] + a[0][4]*a[4][1]) + 

408: a[2][4] * (+a[0][1]*a[4][3] - a[0][3]*a[4][1]) 

409: )+ 

410: a[1][3] * ( 

411: a[2][1] * (-a[0][2]*a[4][4] + a[0][4]*a[4][2]) + 

412: a[2][2] * (+a[0][1]*a[4][4] - a[0][4]*a[4][1]) + 

413: a[2][4] * (-a[0][1]*a[4][2] + a[0][2]*a[4][1]) 

414: )+ 

415: a[1][4] * ( 

416: a[2][1] * (+a[0][2]*a[4][3] - a[0][3]*a[4][2]) + 

417: a[2][2] * (-a[0][1]*a[4][3] + a[0][3]*a[4][1]) + 

418: a[2][3] * (+a[0][1]*a[4][2] - a[0][2]*a[4][1]) 

419: )); 

420: 

421: b[0][4] = 

422: a[1][1] * ( 

423: a[2][2] * (-a[3][3]*a[0][4] + a[3][4]*a[0][3]) + 

424: a[2][3] * (+a[3][2]*a[0][4] - a[3][4]*a[0][2]) + 

425: a[2][4] * (-a[3][2]*a[0][3] + a[3][3]*a[0][2]) 

426: )+ 

427: a[1][2] * ( 

428: a[2][1] * (+a[3][3]*a[0][4] - a[3][4]*a[0][3]) + 

429: a[2][3] * (-a[3][1]*a[0][4] + a[3][4]*a[0][1]) + 

430: a[2][4] * (+a[3][1]*a[0][3] - a[3][3]*a[0][1]) 

431: )+ 

432: a[1][3] * ( 

433: a[2][1] * (-a[3][2]*a[0][4] + a[3][4]*a[0][2]) + 

434: a[2][2] * (+a[3][1]*a[0][4] - a[3][4]*a[0][1]) + 

435: a[2][4] * (-a[3][1]*a[0][2] + a[3][2]*a[0][1]) 

436: )+ 

437: a[1][4] * ( 

438: a[2][1] * (+a[3][2]*a[0][3] - a[3][3]*a[0][2]) + 

439: a[2][2] * (-a[3][1]*a[0][3] + a[3][3]*a[0][1]) + 

440: a[2][3] * (+a[3][1]*a[0][2] - a[3][2]*a[0][1]) 

441: ); 

442: /* second row */ 

443: b[1][0] = 

444: a[1][0] * ( 

445: a[2][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

446: a[2][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

447: a[2][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

448: )+ 

449: a[1][2] * ( 

450: a[2][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

451: a[2][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

452: a[2][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

453: )+ 

454: a[1][3] * ( 

455: a[2][0] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

456: a[2][2] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

457: a[2][4] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) 

458: )+ 

459: a[1][4] * ( 

460: a[2][0] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

461: a[2][2] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

462: a[2][3] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

463: ); 

464: 

465: b[1][1] = -( 

466: a[0][0] * ( 

467: a[2][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

468: a[2][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

469: a[2][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

470: )+ 

471: a[0][2] * ( 

472: a[2][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

473: a[2][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

474: a[2][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

475: )+ 

476: a[0][3] * ( 

477: a[2][0] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

478: a[2][2] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

479: a[2][4] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) 

480: )+ 

481: a[0][4] * ( 

482: a[2][0] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

483: a[2][2] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

484: a[2][3] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

485: )); 

486: 

487: b[1][2] = +( 

488: a[0][0] * ( 

489: a[1][2] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

490: a[1][3] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

491: a[1][4] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

492: )+ 

493: a[0][2] * ( 

494: a[1][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

495: a[1][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

496: a[1][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

497: )+ 

498: a[0][3] * ( 

499: a[1][0] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

500: a[1][2] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

501: a[1][4] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) 

502: )+ 

503: a[0][4] * ( 

504: a[1][0] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

505: a[1][2] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

506: a[1][3] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

507: )); 

508: 

509: b[1][3] = -( 

510: a[0][0] * ( 

511: a[1][2] * (-a[2][3]*a[4][4] + a[2][4]*a[4][3]) + 

512: a[1][3] * (+a[2][2]*a[4][4] - a[2][4]*a[4][2]) + 

513: a[1][4] * (-a[2][2]*a[4][3] + a[2][3]*a[4][2]) 

514: )+ 

515: a[0][2] * ( 

516: a[1][0] * (+a[2][3]*a[4][4] - a[2][4]*a[4][3]) + 

517: a[1][3] * (-a[2][0]*a[4][4] + a[2][4]*a[4][0]) + 

518: a[1][4] * (+a[2][0]*a[4][3] - a[2][3]*a[4][0]) 

519: )+ 

520: a[0][3] * ( 

521: a[1][0] * (-a[2][2]*a[4][4] + a[2][4]*a[4][2]) + 

522: a[1][2] * (+a[2][0]*a[4][4] - a[2][4]*a[4][0]) + 

523: a[1][4] * (-a[2][0]*a[4][2] + a[2][2]*a[4][0]) 

524: )+ 

525: a[0][4] * ( 

526: a[1][0] * (+a[2][2]*a[4][3] - a[2][3]*a[4][2]) + 

527: a[1][2] * (-a[2][0]*a[4][3] + a[2][3]*a[4][0]) + 

528: a[1][3] * (+a[2][0]*a[4][2] - a[2][2]*a[4][0]) 

529: )); 

530: 

531: b[1][4] = +( 

532: a[0][0] * ( 

533: a[1][2] * (-a[2][3]*a[3][4] + a[2][4]*a[3][3]) + 

534: a[1][3] * (+a[2][2]*a[3][4] - a[2][4]*a[3][2]) + 

535: a[1][4] * (-a[2][2]*a[3][3] + a[2][3]*a[3][2]) 

536: )+ 

537: a[0][2] * ( 

538: a[1][0] * (+a[2][3]*a[3][4] - a[2][4]*a[3][3]) + 

539: a[1][3] * (-a[2][0]*a[3][4] + a[2][4]*a[3][0]) + 

540: a[1][4] * (+a[2][0]*a[3][3] - a[2][3]*a[3][0]) 

541: )+ 

542: a[0][3] * ( 

543: a[1][0] * (-a[2][2]*a[3][4] + a[2][4]*a[3][2]) + 

544: a[1][2] * (+a[2][0]*a[3][4] - a[2][4]*a[3][0]) + 

545: a[1][4] * (-a[2][0]*a[3][2] + a[2][2]*a[3][0])


546: )+ 

547: a[0][4] * ( 

548: a[1][0] * (+a[2][2]*a[3][3] - a[2][3]*a[3][2]) + 

549: a[1][2] * (-a[2][0]*a[3][3] + a[2][3]*a[3][0]) + 

550: a[1][3] * (+a[2][0]*a[3][2] - a[2][2]*a[3][0]) 

551: )); 

552: /* third row */ 

553: b[2][0] = -( 

554: a[1][0] * ( 

555: a[2][1] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

556: a[2][3] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

557: a[2][4] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) 

558: )+ 

559: a[1][1] * ( 

560: a[2][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

561: a[2][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

562: a[2][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

563: )+ 

564: a[1][3] * ( 

565: a[2][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

566: a[2][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

567: a[2][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

568: )+ 

569: a[1][4] * ( 

570: a[2][0] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) + 

571: a[2][1] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

572: a[2][3] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

573: )); 

574: 

575: b[2][1] = +( 

576: a[0][0] * ( 

577: a[2][1] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

578: a[2][3] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

579: a[2][4] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) 

580: )+ 

581: a[0][1] * ( 

582: a[2][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

583: a[2][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

584: a[2][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

585: )+ 

586: a[0][3] * ( 

587: a[2][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

588: a[2][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

589: a[2][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

590: )+ 

591: a[0][4] * ( 

592: a[2][0] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) + 

593: a[2][1] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

594: a[2][3] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

595: )); 

596: 

597: b[2][2] = -( 

598: a[0][0] * ( 

599: a[1][1] * (-a[3][3]*a[4][4] + a[3][4]*a[4][3]) + 

600: a[1][3] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

601: a[1][4] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) 

602: )+ 

603: a[0][1] * ( 

604: a[1][0] * (+a[3][3]*a[4][4] - a[3][4]*a[4][3]) + 

605: a[1][3] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

606: a[1][4] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) 

607: )+ 

608: a[0][3] * ( 

609: a[1][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

610: a[1][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

611: a[1][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

612: )+ 

613: a[0][4] * ( 

614: a[1][0] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) + 

615: a[1][1] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

616: a[1][3] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

617: )); 

618: 

619: b[2][3] = +( 

620: a[0][0] * ( 

621: a[1][1] * (-a[2][3]*a[4][4] + a[2][4]*a[4][3]) + 

622: a[1][3] * (+a[2][1]*a[4][4] - a[2][4]*a[4][1]) + 

623: a[1][4] * (-a[2][1]*a[4][3] + a[2][3]*a[4][1]) 

624: )+ 

625: a[0][1] * ( 

626: a[1][0] * (+a[2][3]*a[4][4] - a[2][4]*a[4][3]) + 

627: a[1][3] * (-a[2][0]*a[4][4] + a[2][4]*a[4][0]) + 

628: a[1][4] * (+a[2][0]*a[4][3] - a[2][3]*a[4][0]) 

629: )+ 

630: a[0][3] * ( 

631: a[1][0] * (-a[2][1]*a[4][4] + a[2][4]*a[4][1]) + 

632: a[1][1] * (+a[2][0]*a[4][4] - a[2][4]*a[4][0]) + 

633: a[1][4] * (-a[2][0]*a[4][1] + a[2][1]*a[4][0]) 

634: )+ 

635: a[0][4] * ( 

636: a[1][0] * (+a[2][1]*a[4][3] - a[2][3]*a[4][1]) + 

637: a[1][1] * (-a[2][0]*a[4][3] + a[2][3]*a[4][0]) + 

638: a[1][3] * (+a[2][0]*a[4][1] - a[2][1]*a[4][0]) 

639: )); 

640: 

641: b[2][4] = -( 

642: a[0][0] * ( 

643: a[1][1] * (-a[2][3]*a[3][4] + a[2][4]*a[3][3]) + 

644: a[1][3] * (+a[2][1]*a[3][4] - a[2][4]*a[3][1]) + 

645: a[1][4] * (-a[2][1]*a[3][3] + a[2][3]*a[3][1]) 

646: )+ 

647: a[0][1] * ( 

648: a[1][0] * (+a[2][3]*a[3][4] - a[2][4]*a[3][3]) + 

649: a[1][3] * (-a[2][0]*a[3][4] + a[2][4]*a[3][0]) + 

650: a[1][4] * (+a[2][0]*a[3][3] - a[2][3]*a[3][0]) 

651: )+ 

652: a[0][3] * ( 

653: a[1][0] * (-a[2][1]*a[3][4] + a[2][4]*a[3][1]) + 

654: a[1][1] * (+a[2][0]*a[3][4] - a[2][4]*a[3][0]) + 

655: a[1][4] * (-a[2][0]*a[3][1] + a[2][1]*a[3][0]) 

656: )+ 

657: a[0][4] * ( 

658: a[1][0] * (+a[2][1]*a[3][3] - a[2][3]*a[3][1]) + 

659: a[1][1] * (-a[2][0]*a[3][3] + a[2][3]*a[3][0]) + 

660: a[1][3] * (+a[2][0]*a[3][1] - a[2][1]*a[3][0]) 

661: )); 

662: 

663: /* fourth row */ 

664: b[3][0] = +( 

665: a[1][0] * ( 

666: a[2][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

667: a[2][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

668: a[2][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

669: )+ 

670: a[1][1] * ( 

671: a[2][0] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

672: a[2][2] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

673: a[2][4] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

674: )+ 

675: a[1][2] * ( 

676: a[2][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

677: a[2][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

678: a[2][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

679: )+ 

680: a[1][4] * ( 

681: a[2][0] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) + 

682: a[2][1] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) + 

683: a[2][2] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

684: )); 

685: 

686: b[3][1] = -( 

687: a[0][0] * ( 

688: a[2][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

689: a[2][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

690: a[2][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

691: )+ 

692: a[0][1] * ( 

693: a[2][0] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

694: a[2][2] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

695: a[2][4] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

696: )+ 

697: a[0][2] * ( 

698: a[2][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

699: a[2][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

700: a[2][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

701: )+ 

702: a[0][4] * ( 

703: a[2][0] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) + 

704: a[2][1] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) + 

705: a[2][2] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

706: )); 

707: 

708: b[3][2] = +( 

709: a[0][0] * ( 

710: a[1][1] * (-a[3][2]*a[4][4] + a[3][4]*a[4][2]) + 

711: a[1][2] * (+a[3][1]*a[4][4] - a[3][4]*a[4][1]) + 

712: a[1][4] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

713: )+ 

714: a[0][1] * ( 

715: a[1][0] * (+a[3][2]*a[4][4] - a[3][4]*a[4][2]) + 

716: a[1][2] * (-a[3][0]*a[4][4] + a[3][4]*a[4][0]) + 

717: a[1][4] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

718: )+ 

719: a[0][2] * ( 

720: a[1][0] * (-a[3][1]*a[4][4] + a[3][4]*a[4][1]) + 

721: a[1][1] * (+a[3][0]*a[4][4] - a[3][4]*a[4][0]) + 

722: a[1][4] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

723: )+ 

724: a[0][4] * ( 

725: a[1][0] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) + 

726: a[1][1] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) + 

727: a[1][2] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

728: )); 

729: 

730: b[3][3] = -( 

731: a[0][0] * ( 

732: a[1][1] * (-a[2][2]*a[4][4] + a[2][4]*a[4][2]) + 

733: a[1][2] * (+a[2][1]*a[4][4] - a[2][4]*a[4][1]) + 

734: a[1][4] * (-a[2][1]*a[4][2] + a[2][2]*a[4][1]) 

735: )+ 

736: a[0][1] * ( 

737: a[1][0] * (+a[2][2]*a[4][4] - a[2][4]*a[4][2]) +


738: a[1][2] * (-a[2][0]*a[4][4] + a[2][4]*a[4][0]) + 

739: a[1][4] * (+a[2][0]*a[4][2] - a[2][2]*a[4][0]) 

740: )+ 

741: a[0][2] * ( 

742: a[1][0] * (-a[2][1]*a[4][4] + a[2][4]*a[4][1]) + 

743: a[1][1] * (+a[2][0]*a[4][4] - a[2][4]*a[4][0]) + 

744: a[1][4] * (-a[2][0]*a[4][1] + a[2][1]*a[4][0]) 

745: )+ 

746: a[0][4] * ( 

747: a[1][0] * (+a[2][1]*a[4][2] - a[2][2]*a[4][1]) + 

748: a[1][1] * (-a[2][0]*a[4][2] + a[2][2]*a[4][0]) + 

749: a[1][2] * (+a[2][0]*a[4][1] - a[2][1]*a[4][0]) 

750: )); 

751: 

752: b[3][4] = +( 

753: a[0][0] * ( 

754: a[1][1] * (-a[2][2]*a[3][4] + a[2][4]*a[3][2]) + 

755: a[1][2] * (+a[2][1]*a[3][4] - a[2][4]*a[3][1]) + 

756: a[1][4] * (-a[2][1]*a[3][2] + a[2][2]*a[3][1]) 

757: )+ 

758: a[0][1] * ( 

759: a[1][0] * (+a[2][2]*a[3][4] - a[2][4]*a[3][2]) + 

760: a[1][2] * (-a[2][0]*a[3][4] + a[2][4]*a[3][0]) + 

761: a[1][4] * (+a[2][0]*a[3][2] - a[2][2]*a[3][0]) 

762: )+ 

763: a[0][2] * ( 

764: a[1][0] * (-a[2][1]*a[3][4] + a[2][4]*a[3][1]) + 

765: a[1][1] * (+a[2][0]*a[3][4] - a[2][4]*a[3][0]) + 

766: a[1][4] * (-a[2][0]*a[3][1] + a[2][1]*a[3][0]) 

767: )+ 

768: a[0][4] * ( 

769: a[1][0] * (+a[2][1]*a[3][2] - a[2][2]*a[3][1]) + 

770: a[1][1] * (-a[2][0]*a[3][2] + a[2][2]*a[3][0]) + 

771: a[1][2] * (+a[2][0]*a[3][1] - a[2][1]*a[3][0]) 

772: )); 

773: 

774: /* fifth row */ 

775: b[4][0] = +( 

776: a[1][1] * ( 

777: a[2][2] * (-a[3][3]*a[4][0] + a[3][0]*a[4][3]) + 

778: a[2][3] * (+a[3][2]*a[4][0] - a[3][0]*a[4][2]) + 

779: a[2][0] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) 

780: )+ 

781: a[1][2] * ( 

782: a[2][1] * (+a[3][3]*a[4][0] - a[3][0]*a[4][3]) + 

783: a[2][3] * (-a[3][1]*a[4][0] + a[3][0]*a[4][1]) + 

784: a[2][0] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) 

785: )+ 

786: a[1][3] * ( 

787: a[2][1] * (-a[3][2]*a[4][0] + a[3][0]*a[4][2]) + 

788: a[2][2] * (+a[3][1]*a[4][0] - a[3][0]*a[4][1]) + 

789: a[2][0] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

790: )+ 

791: a[1][0] * ( 

792: a[2][1] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

793: a[2][2] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

794: a[2][3] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) 

795: )); 

796: 

797: b[4][1] = +( 

798: a[0][0] * ( 

799: a[2][1] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) + 

800: a[2][2] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) + 

801: a[2][3] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

802: )+ 

803: a[0][1] * ( 

804: a[2][0] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

805: a[2][2] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

806: a[2][3] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

807: )+ 

808: a[0][2] * ( 

809: a[2][0] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

810: a[2][1] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) + 

811: a[2][3] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

812: )+ 

813: a[0][3] * ( 

814: a[2][0] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) + 

815: a[2][1] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) + 

816: a[2][2] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

817: )); 

818: 

819: b[4][2] = -( 

820: a[0][0] * ( 

821: a[1][1] * (-a[3][2]*a[4][3] + a[3][3]*a[4][2]) + 

822: a[1][2] * (+a[3][1]*a[4][3] - a[3][3]*a[4][1]) + 

823: a[1][3] * (-a[3][1]*a[4][2] + a[3][2]*a[4][1]) 

824: )+ 

825: a[0][1] * ( 

826: a[1][0] * (+a[3][2]*a[4][3] - a[3][3]*a[4][2]) + 

827: a[1][2] * (-a[3][0]*a[4][3] + a[3][3]*a[4][0]) + 

828: a[1][3] * (+a[3][0]*a[4][2] - a[3][2]*a[4][0]) 

829: )+ 

830: a[0][2] * ( 

831: a[1][0] * (-a[3][1]*a[4][3] + a[3][3]*a[4][1]) + 

832: a[1][1] * (+a[3][0]*a[4][3] - a[3][3]*a[4][0]) + 

833: a[1][3] * (-a[3][0]*a[4][1] + a[3][1]*a[4][0]) 

834: )+ 

835: a[0][3] * ( 

836: a[1][0] * (+a[3][1]*a[4][2] - a[3][2]*a[4][1]) + 

837: a[1][1] * (-a[3][0]*a[4][2] + a[3][2]*a[4][0]) + 

838: a[1][2] * (+a[3][0]*a[4][1] - a[3][1]*a[4][0]) 

839: )); 

840: 

841: b[4][3] = +( 

842: a[0][0] * ( 

843: a[1][1] * (-a[2][2]*a[4][3] + a[2][3]*a[4][2]) + 

844: a[1][2] * (+a[2][1]*a[4][3] - a[2][3]*a[4][1]) + 

845: a[1][3] * (-a[2][1]*a[4][2] + a[2][2]*a[4][1]) 

846: )+ 

847: a[0][1] * ( 

848: a[1][0] * (+a[2][2]*a[4][3] - a[2][3]*a[4][2]) + 

849: a[1][2] * (-a[2][0]*a[4][3] + a[2][3]*a[4][0]) + 

850: a[1][3] * (+a[2][0]*a[4][2] - a[2][2]*a[4][0]) 

851: )+ 

852: a[0][2] * ( 

853: a[1][0] * (-a[2][1]*a[4][3] + a[2][3]*a[4][1]) + 

854: a[1][1] * (+a[2][0]*a[4][3] - a[2][3]*a[4][0]) + 

855: a[1][3] * (-a[2][0]*a[4][1] + a[2][1]*a[4][0]) 

856: )+ 

857: a[0][3] * ( 

858: a[1][0] * (+a[2][1]*a[4][2] - a[2][2]*a[4][1]) + 

859: a[1][1] * (-a[2][0]*a[4][2] + a[2][2]*a[4][0]) + 

860: a[1][2] * (+a[2][0]*a[4][1] - a[2][1]*a[4][0]) 

861: )); 

862: 

863: b[4][4] = -( 

864: a[0][0] * ( 

865: a[1][1] * (-a[2][2]*a[3][3] + a[2][3]*a[3][2]) + 

866: a[1][2] * (+a[2][1]*a[3][3] - a[2][3]*a[3][1]) + 

867: a[1][3] * (-a[2][1]*a[3][2] + a[2][2]*a[3][1]) 

868: )+ 

869: a[0][1] * ( 

870: a[1][0] * (+a[2][2]*a[3][3] - a[2][3]*a[3][2]) + 

871: a[1][2] * (-a[2][0]*a[3][3] + a[2][3]*a[3][0]) + 

872: a[1][3] * (+a[2][0]*a[3][2] - a[2][2]*a[3][0]) 

873: )+ 

874: a[0][2] * ( 

875: a[1][0] * (-a[2][1]*a[3][3] + a[2][3]*a[3][1]) + 

876: a[1][1] * (+a[2][0]*a[3][3] - a[2][3]*a[3][0]) + 

877: a[1][3] * (-a[2][0]*a[3][1] + a[2][1]*a[3][0]) 

878: )+ 

879: a[0][3] * ( 

880: a[1][0] * (+a[2][1]*a[3][2] - a[2][2]*a[3][1]) + 

881: a[1][1] * (-a[2][0]*a[3][2] + a[2][2]*a[3][0]) + 

882: a[1][2] * (+a[2][0]*a[3][1] - a[2][1]*a[3][0]) 

883: )); 

884: 

885: return det; 

886: 

887: } 

888: 

889: /*--------------------------------------------------------------- 

890: * inverse_4x4() 

891: * get the inverse of a square 4x4 matrix 

892: * returns determinant 

893: *--------------------------------------------------------------*/ 

894: double 

895: inverse_4x4( double **a, double **b) 

896: { 


898: 

899: det = 

900: - a[0][0] * a[1][1] * a[2][2] * a[3][3] 

901: + a[0][0] * a[1][1] * a[2][3] * a[3][2] 

902: + a[0][0] * a[2][1] * a[1][2] * a[3][3] 

903: - a[0][0] * a[2][1] * a[1][3] * a[3][2] 

904: - a[0][0] * a[3][1] * a[1][2] * a[2][3] 

905: + a[0][0] * a[3][1] * a[1][3] * a[2][2] 

906: 

907: + a[1][0] * a[0][1] * a[2][2] * a[3][3] 

908: - a[1][0] * a[0][1] * a[2][3] * a[3][2] 

909: - a[1][0] * a[2][1] * a[0][2] * a[3][3] 

910: + a[1][0] * a[2][1] * a[0][3] * a[3][2] 

911: + a[1][0] * a[3][1] * a[0][2] * a[2][3] 

912: - a[1][0] * a[3][1] * a[0][3] * a[2][2] 

913: 

914: - a[2][0] * a[0][1] * a[1][2] * a[3][3] 

915: + a[2][0] * a[0][1] * a[1][3] * a[3][2] 

916: + a[2][0] * a[1][1] * a[0][2] * a[3][3] 

917: - a[2][0] * a[1][1] * a[0][3] * a[3][2] 

918: - a[2][0] * a[3][1] * a[0][2] * a[1][3] 

919: + a[2][0] * a[3][1] * a[0][3] * a[1][2] 

920: 

921: + a[3][0] * a[0][1] * a[1][2] * a[2][3] 

922: - a[3][0] * a[0][1] * a[1][3] * a[2][2] 

923: - a[3][0] * a[1][1] * a[0][2] * a[2][3] 

924: + a[3][0] * a[1][1] * a[0][3] * a[2][2] 

925: + a[3][0] * a[2][1] * a[0][2] * a[1][3] 

926: - a[3][0] * a[2][1] * a[0][3] * a[1][2] ; 

927: 

928: 

929: b[0][0] = - a[1][1] * (a[2][2]*a[3][3] - a[2][3] * a[3][2])


930: + a[2][1] * (a[1][2]*a[3][3] - a[1][3] * a[3][2]) 

931: - a[3][1] * (a[1][2]*a[2][3] - a[1][3] * a[2][2]); 

932: 

933: b[0][1] = + a[0][1] * (a[2][2]*a[3][3] - a[2][3] * a[3][2]) 

934: - a[2][1] * (a[0][2]*a[3][3] - a[0][3] * a[3][2]) 

935: + a[3][1] * (a[0][2]*a[2][3] - a[0][3] * a[2][2]); 

936: 

937: b[0][2] = - a[0][1] * (a[1][2]*a[3][3] - a[1][3] * a[3][2]) 

938: + a[1][1] * (a[0][2]*a[3][3] - a[0][3] * a[3][2]) 

939: - a[3][1] * (a[0][2]*a[1][3] - a[0][3] * a[1][2]); 

940: 

941: b[0][3] = + a[0][1] * (a[1][2]*a[2][3] - a[1][3] * a[2][2]) 

942: - a[1][1] * (a[0][2]*a[2][3] - a[0][3] * a[2][2]) 

943: + a[2][1] * (a[0][2]*a[1][3] - a[0][3] * a[1][2]); 

944: 

945: 

946: b[1][0] = + a[1][0] * (a[2][2]*a[3][3] - a[2][3] * a[3][2]) 

947: - a[2][0] * (a[1][2]*a[3][3] - a[1][3] * a[3][2]) 

948: + a[3][0] * (a[1][2]*a[2][3] - a[1][3] * a[2][2]); 

949: 

950: b[1][1] = - a[0][0] * (a[2][2]*a[3][3] - a[2][3] * a[3][2]) 

951: + a[2][0] * (a[0][2]*a[3][3] - a[0][3] * a[3][2]) 

952: - a[3][0] * (a[0][2]*a[2][3] - a[0][3] * a[2][2]); 

953: 

954: b[1][2] = + a[0][0] * (a[1][2]*a[3][3] - a[1][3] * a[3][2]) 

955: - a[1][0] * (a[0][2]*a[3][3] - a[0][3] * a[3][2]) 

956: + a[3][0] * (a[0][2]*a[1][3] - a[0][3] * a[1][2]); 

957: 

958: b[1][3] = - a[0][0] * (a[1][2]*a[2][3] - a[1][3] * a[2][2]) 

959: + a[1][0] * (a[0][2]*a[2][3] - a[0][3] * a[2][2]) 

960: - a[2][0] * (a[0][2]*a[1][3] - a[0][3] * a[1][2]); 

961: 

962: 

963: b[2][0] = - a[1][0] * (a[2][1]*a[3][3] - a[2][3] * a[3][1]) 

964: + a[2][0] * (a[1][1]*a[3][3] - a[1][3] * a[3][1]) 

965: - a[3][0] * (a[1][1]*a[2][3] - a[1][3] * a[2][1]); 

966: 

967: b[2][1] = + a[0][0] * (a[2][1]*a[3][3] - a[2][3] * a[3][1]) 

968: - a[2][0] * (a[0][1]*a[3][3] - a[0][3] * a[3][1]) 

969: + a[3][0] * (a[0][1]*a[2][3] - a[0][3] * a[2][1]); 

970: 

971: b[2][2] = - a[0][0] * (a[1][1]*a[3][3] - a[1][3] * a[3][1]) 

972: + a[1][0] * (a[0][1]*a[3][3] - a[0][3] * a[3][1]) 

973: - a[3][0] * (a[0][1]*a[1][3] - a[0][3] * a[1][1]); 

974: 

975: b[2][3] = + a[0][0] * (a[1][1]*a[2][3] - a[1][3] * a[2][1]) 

976: - a[1][0] * (a[0][1]*a[2][3] - a[0][3] * a[2][1]) 

977: + a[2][0] * (a[0][1]*a[1][3] - a[0][3] * a[1][1]); 

978: 

979: 

980: b[3][0] = + a[1][0] * (a[2][1]*a[3][2] - a[2][2] * a[3][1]) 

981: - a[2][0] * (a[1][1]*a[3][2] - a[1][2] * a[3][1]) 

982: + a[3][0] * (a[1][1]*a[2][2] - a[1][2] * a[2][1]); 

983: 

984: b[3][1] = - a[0][0] * (a[2][1]*a[3][2] - a[2][2] * a[3][1]) 

985: + a[2][0] * (a[0][1]*a[3][2] - a[0][2] * a[3][1]) 

986: - a[3][0] * (a[0][1]*a[2][2] - a[0][2] * a[2][1]); 

987: 

988: b[3][2] = + a[0][0] * (a[1][1]*a[3][2] - a[1][2] * a[3][1]) 

989: - a[1][0] * (a[0][1]*a[3][2] - a[0][2] * a[3][1]) 

990: + a[3][0] * (a[0][1]*a[1][2] - a[0][2] * a[1][1]); 

991: 

992: b[3][3] = - a[0][0] * (a[1][1]*a[2][2] - a[1][2] * a[2][1]) 

993: + a[1][0] * (a[0][1]*a[2][2] - a[0][2] * a[2][1]) 

994: - a[2][0] * (a[0][1]*a[1][2] - a[0][2] * a[1][1]); 

995: 

996: return det; 

997: } 

998: 

999: /*--------------------------------------------------------------- 

1000: * coFactor_3x3() 

1001: * Find the coFactor matrix of a square matrix 

1002: *--------------------------------------------------------------*/ 

1003: void 

1004: coFactor_3x3( double **a, double **b) 

1005: { 

1006: b[0][0] = +( a[1][1] * a[2][2] - a[2][1] * a[1][2]); 

1007: b[1][0] = -( a[1][0] * a[2][2] - a[1][2] * a[2][0]); 

1008: b[2][0] = +( a[1][0] * a[2][1] - a[1][1] * a[2][0]); 

1009: b[0][1] = -( a[0][1] * a[2][2] - a[0][2] * a[2][1]); 

1010: b[1][1] = +( a[0][0] * a[2][2] - a[2][0] * a[0][2]); 

1011: b[2][1] = -( a[0][0] * a[2][1] - a[0][1] * a[2][0]); 

1012: b[0][2] = +( a[0][1] * a[1][2] - a[0][2] * a[1][1]); 

1013: b[1][2] = -( a[0][0] * a[1][2] - a[0][2] * a[1][0]); 

1014: b[2][2] = +( a[0][0] * a[1][1] - a[0][1] * a[1][0]); 

1015: } 

1016: 

1017: /*--------------------------------------------------------------- 

1018: * coFactor_2x2() 

1019: * Find the coFactor matrix of a square matrix 

1020: *--------------------------------------------------------------*/ 

1021: void 

1022: coFactor_2x2( double **a, double **b) 

1023: { 

1024: b[0][0] = +a[1][1]; 

1025: b[1][0] = -a[0][1]; 

1026: b[0][1] = -a[1][0]; 

1027: b[1][1] = +a[0][0]; 

1028: } 

1029: 

1030: /*--------------------------------------------------------------- 

1031: * multiplication of squared matrices 

1032: * A = B * C 

1033: *--------------------------------------------------------------*/ 

1034: void 

1035: multmatsq( int M, double **a, double **b, double **c) 

1036: { 

1037: int i, j, n; 

1038: for (i = 0; i < M; i++) 

1039: { 

1040: for (j = 0; j < M; j++) 

1041: { 

1042: a[i][j] = 0; 

1043: for (n = 0; n < M; n++) 

1044: { 

1045: a[i][j] += b[i][n] * c[n][j]; 

1046: } 

1047: } 

1048: } 

1049: } 

1050: 

1051: /*--------------------------------------------------------------- 

1052: * multiplication of squared matrices 

1053: * A = B * C^T 

1054: *--------------------------------------------------------------*/ 

1055: void 

1056: multmatsqT( int M, double **a, double **b, double **c) 

1057: { 

1058: int i, j, n; 

1059: for (i = 0; i < M; i++) 

1060: { 

1061: for (j = 0; j < M; j++) 

1062: { 

1063: a[i][j] = 0; 

1064: for (n = 0; n < M; n++) 

1065: { 

1066: a[i][j] += b[i][n] * c[j][n]; 

1067: } 

1068: } 

1069: } 

1070: } 

0: /***************************************************************** 

1: * 

2: * File........: matrix_utils.h 

3: * Function....: special functions (prototyping) 


5: * last changes: 20.10.2007 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef MATRIX_UTILS_H 

15: #define MATRIX_UTILS_H 

16: 

17: int *ivector( long N); 

18: float *fvector( long N); 

19: double *vector( long N); 

20: double **matrix( long M, long N); 

21: float **fmatrix( long N, long M); 

22: 

23: void free_ivector( int *v[]); 

24: void free_vector( double *v[]); 

25: void free_matrix( double **m[]); 

26: void free_fmatrix( float **m[]); 

27: 

28: 

29: double determinant_2x2( double **a); 

30: double determinant_3x3( double **a); 

31: double inverse_4x4( double **a, double **b); 

32: double inverse_5x5( double **a, double **b); 

33: void coFactor_2x2( double **a, double **b); 

34: void coFactor_3x3( double **a, double **b); 

35: 

36: void multmatsq( int M, double **a, double **b, double **c); 

37: void multmatsqT( int N, double **a, double **b, double **c); 

38: 

39: #endif 

S.6 Command-line parsing 

0: /**************************************************************** 

1: *

S.6 Command-line parsing 47 

2: * File........: get_option.c 

3: * Function....: reading and analysing of 

4: * command-line parameters/options 


6: * last changes: 15.08.2006 

7: * 





12: * 

13: ****************************************************************/ 

14: #include 

15: #include 

16: #include 

17: #include "get_option.h" 

18: 

19: /* contains argument of option, if OptArg != NULL */ 

20: char *OptArg = NULL; 

21: char CheckStr[256]; 

22: /* CheckStr[] will be initialised with NEEDEDOPTIONS 

23: * all used optionen are deleted; if atleast one option remains, 

24: * an error message is output */ 

25: char *optstr; 

26: int opt_num = 1; 

27: 

28: /*--------------------------------------------------------------- 

29: * check_opt() 

30: *---------------------------------------------------------------*/ 

31: int 

32: check_opt( const char *name) 

33: { 

34: char *ptr; 

35: int i, len, err = 0; 

36: 

37: len = strlen( CheckStr); 

38: for (i = 0; i < len; i++) 

39: { 

40: if (( CheckStr[i] != ’:’) && (CheckStr[i] != ’ ’)) 

41: { 

42: ptr = &CheckStr[i]; 

43: ptr = (char*)strpbrk( ptr, ";:"); 

44: ptr[0] = ’\0’; 

45: err = 1; 

46: break; 

47: } 

48: } 

49: if (err) 

50: { 

51: fprintf( stderr, "\n Missing Option for (-%s)!", &CheckStr[i]); 

52: usage( name); 

53: } 


55: } 

56: 

57: /*--------------------------------------------------------------- 

58: * get_option() 

59: * 

60: * opt_num is number of option to be read 

61: * result: option string 

62: * required: global string containing all options 

63: * at first call opt_num must be equal to 1 ! 

64: * 

65: *---------------------------------------------------------------*/ 

66: char * 

67: get_option( int argc, const char *argv[]) 

68: { 

69: char optstring[256], *ptr, c, d, string[256]; 

70: char *gerrstr="#"; 

71: int len, i, num; 

72: 

73: if (opt_num == 1) 

74: { 

75: strcpy( CheckStr, NEEDEDOPTIONS); 

76: } 

77: if (opt_num > (argc - 1)) 

78: { 

79: return (NULL); 

80: } 

81: else if (argv[opt_num][0] == ’+’) 

82: { 

83: /* + signals end of parameter list */ 

84: opt_num++; 

85: return (NULL); 

86: } 

87: else if (argv[opt_num][0] != ’-’) 

88: { 

89: fprintf( stderr, "\n Option-Error !! *********** "); 


91: "\n every Option must start with ’-’ (%s)!", argv[opt_num]); 

92: /* usage( argv[0]); */ 

93: return gerrstr; 

94: } 

95: 

96: /***** copy without ’-’ *****/ 

97: num = opt_num; 

98: strcpy( optstring, argv[num]); 

99: strcpy( string, &optstring[1]); 

100: 

101: len = strlen( string); 

102: if (len == 0) 

103: { 

104: /* single ’-’ */ 


106: fprintf( stderr, "\n lonely dash !"); 

107: /* usage( argv[0]); */ 


109: } 

110: ptr = OPTIONSTRING; 

111: do 

112: { 

113: /* search option string in OPTIONSTRING */ 

114: ptr = (char*)strstr( ptr, string); 

115: if (ptr == NULL) 

116: { 


118: fprintf( stderr, "\n Unknown Option (%s)!", optstring); 

119: /* usage( argv[0]); */ 


121: } 

122: c = ptr[len]; /* remember subsequent character */ 

123: d = ptr[-1]; /* remember predecessor */ 

124: 

125: /* skip this entry by searching for next ’:’ or ’;’ */ 

126: ptr = (char*)strpbrk( ptr, ";:."); 

127: } while (( (c != ’:’) && (c != ’;’) && (c != ’.’)) || (( d != ’:’) 

128: && (d != ’;’)&& (d != ’.’))); 

129: 

130: if (c == ’;’) /* info, whether argument follows */ 

131: { 

132: OptArg = NULL; 

133: opt_num++; 

134: } 

135: else 

136: { 

137: opt_num++; 

138: if (opt_num > (argc - 1)) 

139: { 


141: fprintf( stderr, "\n Missing Argument for (%s)!", optstring); 

142: /* usage( argv[0]); */ 


144: } 

145: else if (argv[opt_num][0] == ’-’ && c == ’:’) 

146: { 


148: fprintf( stderr, "\n Missing Argument for (%s)!", optstring); 

149: /* usage( argv[0]); */ 


151: } 

152: else 

153: { 

154: /* if c == ’.’ then negativ parameter are allowed */ 

155: } 

156: OptArg = (char*)argv[opt_num]; 

157: opt_num++; 

158: } 

159: strcpy( string, ":"); 

160: strcat( string, &optstring[1]); 

161: strcat( string, ":"); 

162: ptr = (char*)strstr( CheckStr, string); 

163: if (ptr != NULL) 

164: for (i = 0; i < len; i++) 

165: ptr[i + 1] = ’ ’; 

166: 

167: return (( char*)argv[num]); 

168: } 

0: /**************************************************************** 

1: * 

2: * File........: get_option.h 

3: * Function....: prototyping etc. for get_option.c 


5: * last changes: 30.03.2006 

6: * 





11: * 

12: ****************************************************************/ 

13: 

14: #ifndef GETOPT_H 

15: #define GETOPT_H 

16: 

17: /* defined in get_option.c */ 

18: extern char *OptArg; 

19: extern char CheckStr[256]; 

20: /* CheckStr will be initialised with NEEDEDOPTIONS, 

21: * all used optionen are deleted; 

22: * if at least one option remains, an error message is output


23: */ 

24: extern char *optstr; 

25: /* can be used in main file to point to filenames */ 

26: extern int opt_num; /* is defined in get_option.c */ 

27: 

28: /* defined in usage.c */ 

29: extern char *title; 

30: extern char *OPTIONSTRING; 

31: extern char *NEEDEDOPTIONS; 

32: 

33: /* Prototyping */ 

34: void usage( const char *name); 

35: int check_opt( const char *name); 

36: char *get_option( int argc, const char **argv); 

37: 

38: #endif 

0: /***************************************************************** 

1: * 

2: * File........: usage.c 

3: * Function....: parameters for Fitting 


5: * last changes: 07.05.2008, 01.10.2009, 6.11.2009, 08.01.2010 

6: * 18.02.2010, 10.03.2010 

7: * 





12: * 

13: *****************************************************************/ 

14: #include 

15: #include 

16: #include 

17: 

18: /* allowed options: must start with ’:’ !! */ 

19: char *OPTIONSTRING = 

20: { ":a:a1.a2.a3.a4.a5.a6.a7.a8.a9.b:c;cc:co:f;H;i:I:L;m:M:n;o:s;t:w:x:" }; 

21: char *NEEDEDOPTIONS = { ":i:o:m:" }; /* required options */ 

22: 

23: char *title = { "Fitting WLS version 1.0 (02/2010)" }; 

24: 

25: /*--------------------------------------------------------------- 

26: * usage() 

27: *---------------------------------------------------------------*/ 

28: void 

29: usage( char *name) 

30: { 

31: fprintf( stderr, "\n\n %s\n", title); 

32: fprintf( stderr, "\n\ 

33: Usage: %s [options]\n\n\ 

34: Legal Options: \n\ 

35: -i %%s ... input data file (compulsory)\n\ 

36: -o %%s ... output file (compulsory)\n\ 

37: -m %%d ... model function (compulsory)\n\ 

38: 0 ... constant\n\ 

39: 1 ... f(x|a) = a1 + SUM_j=2^M a_j * x_(j-1)\n\ 

40: 2 ... f(x|a) = a1 + a2 * cos( x) + a3 * sin( x) [in degrees]\n\ 

41: 3 ... f(x|a) = a1 + x[n-1] + a2 * x[n-1] + a3 * x[n-3]\n\ 

42: 5 ... f(x|a) = a1 + a2 * cos( x - a3) [in degrees]\n\ 

43: 6 ... f(x|a) = a1 + a2 * exp( a3 * x)\n\ 

44: 7 ... f(x|a) = log( a1 * x)\n\ 

45: 8 ... f(x|a) = a1 * exp( (x-a2)^2 * a3) + \n\ 

46: a4 * exp( (x-a5)^2 * a6)\n\ 

47: 9 ... f(x|a) = a1 * exp( a2 * x)\n\ 

48: 10 ... ln(f(x|a)) = ln(a1) + a2 * x\n\ 

49: 11 ... f(x|a) = a1 * exp( -|x|â2 * a3)\n\ 

50: 12 ... f(x|a) = a1 + a2 * x + a3 * cos( x - a4) [in radians]\n\ 

51: 13 ... f(x|a) = a1 * exp( (x-a2)^2 * a3) + \n\ 

52: 16 ... f(x|a) = a1 + a2 * x + a3 * x^2\n\ 

53: 17 ... f(x|a) = a1 + a2 * x + a3 * x^2 + a4 * x^3\n\ 

54: 18 ... f(x|a) = sum_{j=1}^M aj * x^(j-1) (linear)\n\ 

55: 19 ... f(x|a) = sum_{j=1}^M aj * x^(j-1) (nonlinear)\n\ 

56: 20 ... f(x|a) = a1 + a2*x1 + a3*x1^2 + a4*x2 +a5*x2^2\n\ 

57: 21 ... f1(x|a) = a1 + cos(a3) * x1 - sin(a3) * x2 [in radians]\n\ 

58: f2(x|a) = a2 + sin(a3) * x1 + cos(a3) * x2 [in radians]\n\ 

59: 22 ... f(x|a) = a1 + a2*cos(a3*x-a4) [in radians]\n\ 

60: 23 ... f(x|a) = a1 + a2*cos(a3*x-a4) + a5*cos(2*a3*x-a6)\n\ 

61: 24 ... f(x|a) = 0 = (x1 - a1)^2 + (x2 - a2)^2 - a3*a3 (circle)\n\ 

62: 25 ... f(x|a) = x1^2 + x2^2 = a1*x1 + a2*x2 - a3\n\ 

63: (circle, linear)\n\ 

64: 26 ... f(x|a) = 0 = (sqrt[(x1 - a1)^2 + (x2 - a2)^2] - a3)^2\n\ 

65: (circle, TLS)\n\ 

66: 30 ... neural network 3x3x1, feed forward\n\ 

67: 31 ... neural network 3x2x1\n\ 




71: 40 ... f(x|a) =(a1 + a2*x + a3*x*x + a4*x*x*x) /\n\ 

72: (1 + a5*x + a6*x*x + a7*x*x*x) NIST_THURBER\n\ 

73: 41 ... f(x|a) = a1 * (x**2 + a2*x) /\n\ 

74: (x*x + a3*x + a4) NIST_MGH09\n\ 

75: 42 ... f(x|a) = a1 / (1 + exp(a2 - a3*x)) NIST_Rat42\n\ 

76: 43 ... f(x|a) = a1 / [1 + exp(a2 - a3*x)]^(1/a4) NIST_Rat43\n\ 

77: 44 ... f(x|a) = a1 / a2 * exp(-0.5*((x -a3)/ a2)^2) NIST_Eckerle4\n\ 

78: 45 ... f(x|a) = a1 * exp( a2 / (x+a3)) NIST_MGH10\n\ 

79: 46 ... f(x|a) = a1 * (x+a2)^(-1/a3) NIST_Bennett5\n\ 

80: 47 ... f(x|a) = a1 *(1 - exp( -a2 * x) NIST_BoxBOD\n\ 

81: -a %%d ... inversion algorithm (default: 1)\n\ 

82: 0 - cofactor method\n\ 

83: 1 - singular value decomposition\n\ 

84: 2 - LU decomposition\n\ 

85: -a[j] %%f ... provides initial value for a_j (j=1,2,..,9)\n\ 

86: -b %%d ... observations per bin, for ’-w 2’ (default: 50)\n\ 

87: -c ... enable scaling of conditions \n\ 

88: -cc %%s ... comma-separated list of column(s) containing \n\ 

89: conditions x (default: 1,2,...)\n\ 

90: -co %%d ... column containing observations y (default: 2)\n\ 

91: -f ... forget weights after outlier removal\n\ 

92: -H ... enable true Hessian matrix\n\ 

93: -I %%d ... maximum number of iterations (default: 2000)\n\ 

94: -M %%d ... number of parameters (for ’-m 1’ only)\n\ 

95: -n ... force usage of numerical derivation\n\ 

96: -L ... use Gaus-Newton instead of Levenberg-Marquardt \n\ 

97: -s ... use special SVD function for solving linear model\n\ 

98: -t %%f ... target value for chisq (maximum error)\n\ 

99: default: iteration until convergence\n\ 

100: -w %%d ... weighting (default: 0)\n\ 

101: 0 ... no weighting \n\ 

102: 1 ... based on deviates \n\ 

103: 2 ... binning \n\ 

104: -x %%d ... outlier removal (default: 0)\n\ 

105: 0 ... no outlier removal\n\ 

106: 1 ... Chauvenet’s criterion\n\ 

107: 2 ... cluster criterion \n\ 

108: \n\ 

109: ", name); 

110: }

S.8 Other 49 

S.7 Error Handling 

0: /***************************************************************** 

1: * 

2: * File........: errmsg.c 

3: * Function....: error messages 


5: * last changes: 20.10.2007 

6: * 





11: * 

12: *****************************************************************/ 

13: #include 

14: #include 


16: 

17: int 

18: errmsg( int err, char *rtn, char *text, int value) 

19: { 

20: switch (err) 

21: { 

22: case ERR_CALL: 

23: fprintf( stderr, ERR_CALL_MSG, rtn, text); 

24: break; 

25: case ERR_OPEN_READ: 

26: fprintf( stderr, ERR_OPEN_READ_MSG, rtn, text); 


28: break; 

29: case ERR_OPEN_WRITE: 

30: fprintf( stderr, ERR_OPEN_WRITE_MSG, rtn, text); 


32: break; 

33: case ERR_ALLOCATE: 

34: fprintf( stderr, ERR_ALLOCATE_MSG, rtn, text); 


36: break; 

37: case ERR_NOT_DEFINED: 

38: fprintf( stderr, ERR_NOT_DEFINED_MSG, rtn, value, text); 

39: break; 

40: case ERR_IS_ZERO: 

41: fprintf( stderr, ERR_IS_ZERO_MSG, rtn, text); 

42: break; 

43: case ERR_IS_SINGULAR: 

44: fprintf( stderr, ERR_IS_SINGULAR_MSG, rtn, text); 

45: break; 

46: default: 

47: fprintf( stderr, "\nerrmsg: error %d is not defined\n", err); 

48: break; 

49: } 


51: } 

0: /***************************************************************** 

1: * 

2: * File........: errmsg.h 

3: * Function....: error messages 


5: * last changes: 25.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef ERRMSG_H 

15: #define ERRMSG_H 

16: 

17: 

18: #define ERR_CALL 1 

S.8 Other 

0: /***************************************************************** 

1: * 

2: * File........: heap_sort.c 

3: * Function....: sorting of values 


5: * last changes: 20.10.2007 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #include 

15: #include 

16: #include 

17: #include 

18: 

19: /*--------------------------------------------------------------- 

20: * heap_sort_d() 

21: * sorting of values in values[0...N-1] in ascending order 

22: * values[] is replaced on output by sorted values 

23: *--------------------------------------------------------------*/ 

24: void 

25: heap_sort_d( unsigned long N, double values[]) 

26: { 

27: unsigned long i, ir, j, l; 

28: double rvalues; 

29: 

30: if (N < 2) 

31: return; 

32: 

33: l = (N >> 1); 

34: ir = N - 1; 

35: 

36: for (;;) 

37: { 

38: if (l > 0) 

39: { 

40: l--; 

41: rvalues = values[l]; 

42: } 

43: else 

44: { 

45: rvalues = values[ir]; 

46: values[ir] = values[0]; 

47: ir--; 

48: if (ir == 0) 

49: { 

50: values[0] = rvalues; 

51: break; 

52: } 

53: } 

54: i = l; 

55: 

56: j = l + l + 2; 

57: while (j


94: 

95: l = (N >> 1); 

96: ir = N - 1; 

97: 

98: for (;;) 

99: { 

100: if (l > 0) 

101: { 

102: l--; 

103: rvalues = values[l]; iidx = idx[l]; 

104: } 

105: else 

106: { 

107: rvalues = values[ir]; iidx = idx[ir]; 

108: values[ir] = values[0]; idx[ir] = idx[0]; 

109: ir--; 

110: if (ir == 0) 

111: { 

112: values[0] = rvalues; idx[0] = iidx; 

113: break; 

114: } 

115: } 

116: i = l; 

117: 

118: j = l + l + 2; 

119: while (j 2.2 */ 

46: return 1.0 - erfc(x); 

47: } 

48: do 

49: { 

50: term *= xsqr / j; 

51: sum -= term /(2*j+1); 

52: j++; 

53: term *= xsqr / j; 

54: sum += term /(2*j+1); 

55: j++; 

56: } while (fabs(term) / sum > rel_error); 

57: return two_sqrtpi * sum; 

58: } 

59: 

60: /*--------------------------------------------------------------- 

61: * erfc() 

62: * 

63: * erfc(x) = 2/sqrt(pi)*integral(exp(-t^2),t,x,inf) 

64: * = exp(-x^2)/sqrt(pi) * [1/x + (1/2)/x + (2/2)/x + 

65: * (3/2)/x+ (4/2)/x+ ...] 

66: * = 1-erf(x) 

67: * expression inside [] is a continued fraction 

68: * so ’+’ means add to denominator only 

69: *--------------------------------------------------------------*/ 

70: double erfc(double x) 

71: { 

72: /* 1/sqrt(pi)*/ 

73: static const double one_sqrtpi = 0.564189583547756287; 

74: double a = 1, b; /* last two convergent numerators */ 

75: double c, d; /* last two convergent denominators */ 

76: double q1, q2; /* last two convergents (a/c and b/d) */ 

77: double n = 1.0, t; 

78: 

79: b = c = x; 

80: d = x * x + 0.5; 

81: q2 = b / d; 

82: 

83: if (fabs(x) < 2.2) 

84: { 

85: return 1.0 - erf(x); /* use series when fabs(x) < 2.2 */ 

86: } 

87: if (x > 0) 

88: { /* continued fraction only valid for x>0 */ 

89: return 2.0 - erfc(-x); 

90: } 

91: do 

92: { 

93: t = a*n + b*x; 

94: a = b; 

95: b = t; 

96: t = c*n + d*x; 

97: c = d; 

98: d = t; 

99: n += 0.5; 

100: q1 = q2; 

101: q2 = b / d; 

102: } while (fabs(q1-q2) / q2 > rel_error); 

103: return one_sqrtpi * exp(-x*x) * q2; 

104: } 

105: 

106: /*--------------------------------------------------------------- 

107: * erfinv() 

108: * 

109: *--------------------------------------------------------------*/ 

110: int erfinv( double y, double *res ) 

111: { 

112: static double a[] = {0, 0.886226899, -1.645349621, 

113: 0.914624893, -0.140543331 }; 

114: static double b[] = {0, -2.118377725, 1.442710462, 

115: -0.329097515, 0.012229801 }; 

116: static double c[] = {0, -1.970840454, -1.624906493, 

117: 3.429567803, 1.641345311 }; 

118: static double d[] = {0, 3.543889200, 1.637067800 }; 

119: int err = 0; 

120: double x, z; 

121: 

122: if ( y > -1. ) 

123: { 

124: if ( y >= -.7 ) 

125: { 

126: if ( y

S.8 Other 51 

145: z = sqrt(-log((1+y)/2)); 

146: x = -(((c[4]*z+c[3])*z+c[2])*z+c[1]) / ((d[2]*z+d[1])*z+1); 

147: } 

148: } 

149: else 

150: { 

151: err = 3; 

152: x = 0; 

153: } 

154: *res = x; 


156: } 

0: /*************************** 

1: * File........: erf.h 

2: * Function....: prototypes for erf.c 


4: * last changes: 05.02.2008 

5: * 





10: * 

11: ***************************/ 

12: double erf(double x); 

13: double erfc(double x); 

14: int erfinv( double y, double *res ); 

0: /***************************************************************** 

1: * 

2: * File........: macros.h 

3: * Function....: general purpose macros 


5: * last changes: 25.01.2010 

6: * 





11: * 

12: *****************************************************************/ 

13: 

14: #ifndef MACROS_H 

15: #define MACROS_H 

16: 

17: #define MAX(a,b) ((a) > (b) ? (a) : (b)) 

18: #define MIN(a,b) ((a) < (b) ? (a) : (b)) 

19: 

20: #define M_PI 3.14159265358979323846 /* pi */ 

21: #define TOL 1.0e-10 /* for convergence criterion */ 

22: #define TOL_S2 1.0e-14 /* for test of singular values */ 

23: #define TOL_S 1.0e-12 /* for test of singular values */ 

24: /* this small value is required, for example, 

25: for the Bennett5 data set */ 

26: 

27: #endif 

0: /************************************************************* 

1: * File........: defines.h 

2: * Function....: definition of globally used values 


4: * last changes: 03.07.2009 

5: * 





10: * 

11: ***********************************************************/ 

12: 

13: #ifndef DEFINES_H 

14: #define DEFINES_H 

15: 

16: /* for est_weights.c and outlier_detetction.c */ 

17: 

18: #define MAX_LINES_W 500 

19: 

20: 

21: /* for fitting.c */ 

22: 

23: /* maximal number of conditions per model function */ 

24: /* see functions.h */ 

25: #define MAX_CONDITIONS (M_MAX-1) 

26: /* output of maximal 100 lines of resulting values as feedback */ 

27: #define MAX_LINES 100 

28: /* input file may contain maximal 512 characters per line */ 

29: #define MAXLINELENGTH 512 

30: 

31: 

32: /* for functions.c */ 

33: 

34: /* maximal 15 parameters per model function (see f_deriv()) */ 

35: #define M_MAX 16 

36: 

37: /* for ls.c */ 

38: extern long ITERAT_MAX; 

39: 

40: #endif

Data Fitting and Uncertainty

Create successful ePaper yourself

Delete template?

Save as template?