summaryrefslogtreecommitdiff
path: root/lib/Numeric/GSL/gsl-aux.c
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Numeric/GSL/gsl-aux.c')
-rw-r--r--lib/Numeric/GSL/gsl-aux.c743
1 files changed, 743 insertions, 0 deletions
diff --git a/lib/Numeric/GSL/gsl-aux.c b/lib/Numeric/GSL/gsl-aux.c
new file mode 100644
index 0000000..c602d5e
--- /dev/null
+++ b/lib/Numeric/GSL/gsl-aux.c
@@ -0,0 +1,743 @@
1#include "gsl-aux.h"
2#include <gsl/gsl_blas.h>
3#include <gsl/gsl_linalg.h>
4#include <gsl/gsl_matrix.h>
5#include <gsl/gsl_math.h>
6#include <gsl/gsl_errno.h>
7#include <gsl/gsl_fft_complex.h>
8#include <gsl/gsl_eigen.h>
9#include <gsl/gsl_integration.h>
10#include <gsl/gsl_deriv.h>
11#include <gsl/gsl_poly.h>
12#include <gsl/gsl_multimin.h>
13#include <gsl/gsl_complex.h>
14#include <gsl/gsl_complex_math.h>
15#include <string.h>
16#include <stdio.h>
17
18#define MACRO(B) do {B} while (0)
19#define ERROR(CODE) MACRO(return CODE;)
20#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})
21#define OK return 0;
22
23#define MIN(A,B) ((A)<(B)?(A):(B))
24#define MAX(A,B) ((A)>(B)?(A):(B))
25
26#ifdef DBG
27#define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M);
28#else
29#define DEBUGMSG(M)
30#endif
31
32#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)
33
34#ifdef DBG
35#define DEBUGMAT(MSG,X) printf(MSG" = \n"); gsl_matrix_fprintf(stdout,X,"%f"); printf("\n");
36#else
37#define DEBUGMAT(MSG,X)
38#endif
39
40#ifdef DBG
41#define DEBUGVEC(MSG,X) printf(MSG" = \n"); gsl_vector_fprintf(stdout,X,"%f"); printf("\n");
42#else
43#define DEBUGVEC(MSG,X)
44#endif
45
46#define DVVIEW(A) gsl_vector_view A = gsl_vector_view_array(A##p,A##n)
47#define DMVIEW(A) gsl_matrix_view A = gsl_matrix_view_array(A##p,A##r,A##c)
48#define CVVIEW(A) gsl_vector_complex_view A = gsl_vector_complex_view_array((double*)A##p,A##n)
49#define CMVIEW(A) gsl_matrix_complex_view A = gsl_matrix_complex_view_array((double*)A##p,A##r,A##c)
50#define KDVVIEW(A) gsl_vector_const_view A = gsl_vector_const_view_array(A##p,A##n)
51#define KDMVIEW(A) gsl_matrix_const_view A = gsl_matrix_const_view_array(A##p,A##r,A##c)
52#define KCVVIEW(A) gsl_vector_complex_const_view A = gsl_vector_complex_const_view_array((double*)A##p,A##n)
53#define KCMVIEW(A) gsl_matrix_complex_const_view A = gsl_matrix_complex_const_view_array((double*)A##p,A##r,A##c)
54
55#define V(a) (&a.vector)
56#define M(a) (&a.matrix)
57
58#define GCVEC(A) int A##n, gsl_complex*A##p
59#define KGCVEC(A) int A##n, const gsl_complex*A##p
60
61#define BAD_SIZE 2000
62#define BAD_CODE 2001
63#define MEM 2002
64#define BAD_FILE 2003
65
66
67void no_abort_on_error() {
68 gsl_set_error_handler_off();
69}
70
71
72int toScalarR(int code, KRVEC(x), RVEC(r)) {
73 REQUIRES(rn==1,BAD_SIZE);
74 DEBUGMSG("toScalarR");
75 KDVVIEW(x);
76 double res;
77 switch(code) {
78 case 0: { res = gsl_blas_dnrm2(V(x)); break; }
79 case 1: { res = gsl_blas_dasum(V(x)); break; }
80 case 2: { res = gsl_vector_max_index(V(x)); break; }
81 case 3: { res = gsl_vector_max(V(x)); break; }
82 case 4: { res = gsl_vector_min_index(V(x)); break; }
83 case 5: { res = gsl_vector_min(V(x)); break; }
84 default: ERROR(BAD_CODE);
85 }
86 rp[0] = res;
87 OK
88}
89
90
91inline double sign(double x) {
92 if(x>0) {
93 return +1.0;
94 } else if (x<0) {
95 return -1.0;
96 } else {
97 return 0.0;
98 }
99}
100
101
102#define OP(C,F) case C: { for(k=0;k<xn;k++) rp[k] = F(xp[k]); OK }
103#define OPV(C,E) case C: { for(k=0;k<xn;k++) rp[k] = E; OK }
104int mapR(int code, KRVEC(x), RVEC(r)) {
105 int k;
106 REQUIRES(xn == rn,BAD_SIZE);
107 DEBUGMSG("mapR");
108 switch (code) {
109 OP(0,sin)
110 OP(1,cos)
111 OP(2,tan)
112 OP(3,fabs)
113 OP(4,asin)
114 OP(5,acos)
115 OP(6,atan) /* atan2 mediante vectorZip */
116 OP(7,sinh)
117 OP(8,cosh)
118 OP(9,tanh)
119 OP(10,asinh)
120 OP(11,acosh)
121 OP(12,atanh)
122 OP(13,exp)
123 OP(14,log)
124 OP(15,sign)
125 OP(16,sqrt)
126 default: ERROR(BAD_CODE);
127 }
128}
129
130int mapCAux(int code, KGCVEC(x), GCVEC(r)) {
131 int k;
132 REQUIRES(xn == rn,BAD_SIZE);
133 DEBUGMSG("mapC");
134 switch (code) {
135 OP(0,gsl_complex_sin)
136 OP(1,gsl_complex_cos)
137 OP(2,gsl_complex_tan)
138
139 OP(4,gsl_complex_arcsin)
140 OP(5,gsl_complex_arccos)
141 OP(6,gsl_complex_arctan)
142 OP(7,gsl_complex_sinh)
143 OP(8,gsl_complex_cosh)
144 OP(9,gsl_complex_tanh)
145 OP(10,gsl_complex_arcsinh)
146 OP(11,gsl_complex_arccosh)
147 OP(12,gsl_complex_arctanh)
148 OP(13,gsl_complex_exp)
149 OP(14,gsl_complex_log)
150
151 OP(16,gsl_complex_sqrt)
152
153 // gsl_complex_arg
154 // gsl_complex_abs
155 default: ERROR(BAD_CODE);
156 }
157}
158
159int mapC(int code, KCVEC(x), CVEC(r)) {
160 return mapCAux(code, xn, (gsl_complex*)xp, rn, (gsl_complex*)rp);
161}
162
163
164/*
165int scaleR(double* alpha, KRVEC(x), RVEC(r)) {
166 REQUIRES(xn == rn,BAD_SIZE);
167 DEBUGMSG("scaleR");
168 KDVVIEW(x);
169 DVVIEW(r);
170 CHECK( gsl_vector_memcpy(V(r),V(x)) , MEM);
171 int res = gsl_vector_scale(V(r),*alpha);
172 CHECK(res,res);
173 OK
174}
175
176int scaleC(gsl_complex *alpha, KCVEC(x), CVEC(r)) {
177 REQUIRES(xn == rn,BAD_SIZE);
178 DEBUGMSG("scaleC");
179 //KCVVIEW(x);
180 CVVIEW(r);
181 gsl_vector_const_view vrx = gsl_vector_const_view_array((double*)xp,xn*2);
182 gsl_vector_view vrr = gsl_vector_view_array((double*)rp,rn*2);
183 CHECK(gsl_vector_memcpy(V(vrr),V(vrx)) , MEM);
184 gsl_blas_zscal(*alpha,V(r)); // void !
185 int res = 0;
186 CHECK(res,res);
187 OK
188}
189
190int addConstantR(double offs, KRVEC(x), RVEC(r)) {
191 REQUIRES(xn == rn,BAD_SIZE);
192 DEBUGMSG("addConstantR");
193 KDVVIEW(x);
194 DVVIEW(r);
195 CHECK(gsl_vector_memcpy(V(r),V(x)), MEM);
196 int res = gsl_vector_add_constant(V(r),offs);
197 CHECK(res,res);
198 OK
199}
200
201*/
202
203
204
205int mapValR(int code, double* pval, KRVEC(x), RVEC(r)) {
206 int k;
207 double val = *pval;
208 REQUIRES(xn == rn,BAD_SIZE);
209 DEBUGMSG("mapValR");
210 switch (code) {
211 OPV(0,val*xp[k])
212 OPV(1,val/xp[k])
213 OPV(2,val+xp[k])
214 OPV(3,val-xp[k])
215 OPV(4,pow(val,xp[k]))
216 OPV(5,pow(xp[k],val))
217 default: ERROR(BAD_CODE);
218 }
219}
220
221int mapValCAux(int code, gsl_complex* pval, KGCVEC(x), GCVEC(r)) {
222 int k;
223 gsl_complex val = *pval;
224 REQUIRES(xn == rn,BAD_SIZE);
225 DEBUGMSG("mapValC");
226 switch (code) {
227 OPV(0,gsl_complex_mul(val,xp[k]))
228 OPV(1,gsl_complex_div(val,xp[k]))
229 OPV(2,gsl_complex_add(val,xp[k]))
230 OPV(3,gsl_complex_sub(val,xp[k]))
231 OPV(4,gsl_complex_pow(val,xp[k]))
232 OPV(5,gsl_complex_pow(xp[k],val))
233 default: ERROR(BAD_CODE);
234 }
235}
236
237int mapValC(int code, gsl_complex* val, KCVEC(x), CVEC(r)) {
238 return mapValCAux(code, val, xn, (gsl_complex*)xp, rn, (gsl_complex*)rp);
239}
240
241
242#define OPZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = E(ap[k],bp[k]); OK }
243#define OPZV(C,msg,E) case C: {DEBUGMSG(msg) res = E(V(r),V(b)); CHECK(res,res); OK }
244int zipR(int code, KRVEC(a), KRVEC(b), RVEC(r)) {
245 REQUIRES(an == bn && an == rn, BAD_SIZE);
246 int k;
247 switch(code) {
248 OPZE(4,"zipR Pow",pow)
249 OPZE(5,"zipR ATan2",atan2)
250 }
251 KDVVIEW(a);
252 KDVVIEW(b);
253 DVVIEW(r);
254 gsl_vector_memcpy(V(r),V(a));
255 int res;
256 switch(code) {
257 OPZV(0,"zipR Add",gsl_vector_add)
258 OPZV(1,"zipR Sub",gsl_vector_sub)
259 OPZV(2,"zipR Mul",gsl_vector_mul)
260 OPZV(3,"zipR Div",gsl_vector_div)
261 default: ERROR(BAD_CODE);
262 }
263}
264
265
266int zipCAux(int code, KGCVEC(a), KGCVEC(b), GCVEC(r)) {
267 REQUIRES(an == bn && an == rn, BAD_SIZE);
268 int k;
269 switch(code) {
270 OPZE(0,"zipC Add",gsl_complex_add)
271 OPZE(1,"zipC Sub",gsl_complex_sub)
272 OPZE(2,"zipC Mul",gsl_complex_mul)
273 OPZE(3,"zipC Div",gsl_complex_div)
274 OPZE(4,"zipC Pow",gsl_complex_pow)
275 //OPZE(5,"zipR ATan2",atan2)
276 }
277 //KCVVIEW(a);
278 //KCVVIEW(b);
279 //CVVIEW(r);
280 //gsl_vector_memcpy(V(r),V(a));
281 //int res;
282 switch(code) {
283 default: ERROR(BAD_CODE);
284 }
285}
286
287
288int zipC(int code, KCVEC(a), KCVEC(b), CVEC(r)) {
289 return zipCAux(code, an, (gsl_complex*)ap, bn, (gsl_complex*)bp, rn, (gsl_complex*)rp);
290}
291
292
293
294
295int luSolveR(KRMAT(a),KRMAT(b),RMAT(r)) {
296 REQUIRES(ar==ac && ac==br && ar==rr && bc==rc,BAD_SIZE);
297 DEBUGMSG("luSolveR");
298 KDMVIEW(a);
299 KDMVIEW(b);
300 DMVIEW(r);
301 int res;
302 gsl_matrix *LU = gsl_matrix_alloc(ar,ar);
303 CHECK(!LU,MEM);
304 int s;
305 gsl_permutation * p = gsl_permutation_alloc (ar);
306 CHECK(!p,MEM);
307 CHECK(gsl_matrix_memcpy(LU,M(a)),MEM);
308 res = gsl_linalg_LU_decomp(LU, p, &s);
309 CHECK(res,res);
310 int c;
311
312 for (c=0; c<bc; c++) {
313 gsl_vector_const_view colb = gsl_matrix_const_column (M(b), c);
314 gsl_vector_view colr = gsl_matrix_column (M(r), c);
315 res = gsl_linalg_LU_solve (LU, p, V(colb), V(colr));
316 CHECK(res,res);
317 }
318 gsl_permutation_free(p);
319 gsl_matrix_free(LU);
320 OK
321}
322
323
324int luSolveC(KCMAT(a),KCMAT(b),CMAT(r)) {
325 REQUIRES(ar==ac && ac==br && ar==rr && bc==rc,BAD_SIZE);
326 DEBUGMSG("luSolveC");
327 KCMVIEW(a);
328 KCMVIEW(b);
329 CMVIEW(r);
330 gsl_matrix_complex *LU = gsl_matrix_complex_alloc(ar,ar);
331 CHECK(!LU,MEM);
332 int s;
333 gsl_permutation * p = gsl_permutation_alloc (ar);
334 CHECK(!p,MEM);
335 CHECK(gsl_matrix_complex_memcpy(LU,M(a)),MEM);
336 int res;
337 res = gsl_linalg_complex_LU_decomp(LU, p, &s);
338 CHECK(res,res);
339 int c;
340 for (c=0; c<bc; c++) {
341 gsl_vector_complex_const_view colb = gsl_matrix_complex_const_column (M(b), c);
342 gsl_vector_complex_view colr = gsl_matrix_complex_column (M(r), c);
343 res = gsl_linalg_complex_LU_solve (LU, p, V(colb), V(colr));
344 CHECK(res,res);
345 }
346 gsl_permutation_free(p);
347 gsl_matrix_complex_free(LU);
348 OK
349}
350
351
352int luRaux(KRMAT(a),RVEC(b)) {
353 REQUIRES(ar==ac && bn==ar*ar+ar+1,BAD_SIZE);
354 DEBUGMSG("luRaux");
355 KDMVIEW(a);
356 //DVVIEW(b);
357 gsl_matrix_view LU = gsl_matrix_view_array(bp,ar,ac);
358 int s;
359 gsl_permutation * p = gsl_permutation_alloc (ar);
360 CHECK(!p,MEM);
361 CHECK(gsl_matrix_memcpy(M(LU),M(a)),MEM);
362 gsl_linalg_LU_decomp(M(LU), p, &s);
363 bp[ar*ar] = s;
364 int k;
365 for (k=0; k<ar; k++) {
366 bp[ar*ar+k+1] = gsl_permutation_get(p,k);
367 }
368 gsl_permutation_free(p);
369 OK
370}
371
372int luCaux(KCMAT(a),CVEC(b)) {
373 REQUIRES(ar==ac && bn==ar*ar+ar+1,BAD_SIZE);
374 DEBUGMSG("luCaux");
375 KCMVIEW(a);
376 //DVVIEW(b);
377 gsl_matrix_complex_view LU = gsl_matrix_complex_view_array((double*)bp,ar,ac);
378 int s;
379 gsl_permutation * p = gsl_permutation_alloc (ar);
380 CHECK(!p,MEM);
381 CHECK(gsl_matrix_complex_memcpy(M(LU),M(a)),MEM);
382 int res;
383 res = gsl_linalg_complex_LU_decomp(M(LU), p, &s);
384 CHECK(res,res);
385 ((double*)bp)[2*ar*ar] = s;
386 ((double*)bp)[2*ar*ar+1] = 0;
387 int k;
388 for (k=0; k<ar; k++) {
389 ((double*)bp)[2*ar*ar+2*k+2] = gsl_permutation_get(p,k);
390 ((double*)bp)[2*ar*ar+2*k+2+1] = 0;
391 }
392 gsl_permutation_free(p);
393 OK
394}
395
396int svd(KRMAT(a),RMAT(u), RVEC(s),RMAT(v)) {
397 REQUIRES(ar==ur && ac==uc && ac==sn && ac==vr && ac==vc,BAD_SIZE);
398 DEBUGMSG("svd");
399 KDMVIEW(a);
400 DMVIEW(u);
401 DVVIEW(s);
402 DMVIEW(v);
403 gsl_vector *workv = gsl_vector_alloc(ac);
404 CHECK(!workv,MEM);
405 gsl_matrix *workm = gsl_matrix_alloc(ac,ac);
406 CHECK(!workm,MEM);
407 CHECK(gsl_matrix_memcpy(M(u),M(a)),MEM);
408 // int res = gsl_linalg_SV_decomp_jacobi (&U.matrix, &V.matrix, &S.vector);
409 // doesn't work
410 //int res = gsl_linalg_SV_decomp (&U.matrix, &V.matrix, &S.vector, workv);
411 int res = gsl_linalg_SV_decomp_mod (M(u), workm, M(v), V(s), workv);
412 CHECK(res,res);
413 //gsl_matrix_transpose(M(v));
414 gsl_vector_free(workv);
415 gsl_matrix_free(workm);
416 OK
417}
418
419
420// for real symmetric matrices
421int eigensystemR(KRMAT(x),RVEC(l),RMAT(v)) {
422 REQUIRES(xr==xc && xr==ln && xr==vr && vr==vc,BAD_SIZE);
423 DEBUGMSG("eigensystemR (gsl_eigen_symmv)");
424 KDMVIEW(x);
425 DVVIEW(l);
426 DMVIEW(v);
427 gsl_matrix *XC = gsl_matrix_alloc(xr,xr);
428 gsl_matrix_memcpy(XC,M(x)); // needed because the argument is destroyed
429 // many thanks to Nico Mahlo for the bug report
430 gsl_eigen_symmv_workspace * w = gsl_eigen_symmv_alloc (xc);
431 int res = gsl_eigen_symmv (XC, V(l), M(v), w);
432 CHECK(res,res);
433 gsl_eigen_symmv_free (w);
434 gsl_matrix_free(XC);
435 gsl_eigen_symmv_sort (V(l), M(v), GSL_EIGEN_SORT_ABS_DESC);
436 OK
437}
438
439// for hermitian matrices
440int eigensystemC(KCMAT(x),RVEC(l),CMAT(v)) {
441 REQUIRES(xr==xc && xr==ln && xr==vr && vr==vc,BAD_SIZE);
442 DEBUGMSG("eigensystemC");
443 KCMVIEW(x);
444 DVVIEW(l);
445 CMVIEW(v);
446 gsl_matrix_complex *XC = gsl_matrix_complex_alloc(xr,xr);
447 gsl_matrix_complex_memcpy(XC,M(x)); // again needed because the argument is destroyed
448 gsl_eigen_hermv_workspace * w = gsl_eigen_hermv_alloc (xc);
449 int res = gsl_eigen_hermv (XC, V(l), M(v), w);
450 CHECK(res,res);
451 gsl_eigen_hermv_free (w);
452 gsl_matrix_complex_free(XC);
453 gsl_eigen_hermv_sort (V(l), M(v), GSL_EIGEN_SORT_ABS_DESC);
454 OK
455}
456
457int QR(KRMAT(x),RMAT(q),RMAT(r)) {
458 REQUIRES(xr==rr && xc==rc && qr==qc && xr==qr,BAD_SIZE);
459 DEBUGMSG("QR");
460 KDMVIEW(x);
461 DMVIEW(q);
462 DMVIEW(r);
463 gsl_matrix * a = gsl_matrix_alloc(xr,xc);
464 gsl_vector * tau = gsl_vector_alloc(MIN(xr,xc));
465 gsl_matrix_memcpy(a,M(x));
466 int res = gsl_linalg_QR_decomp(a,tau);
467 CHECK(res,res);
468 gsl_linalg_QR_unpack(a,tau,M(q),M(r));
469 gsl_vector_free(tau);
470 gsl_matrix_free(a);
471 OK
472}
473
474int cholR(KRMAT(x),RMAT(l)) {
475 REQUIRES(xr==xc && lr==xr && lr==lc,BAD_SIZE);
476 DEBUGMSG("cholR");
477 KDMVIEW(x);
478 DMVIEW(l);
479 gsl_matrix_memcpy(M(l),M(x));
480 int res = gsl_linalg_cholesky_decomp(M(l));
481 CHECK(res,res);
482 int r,c;
483 for (r=0; r<xr-1; r++) {
484 for(c=r+1; c<xc; c++) {
485 lp[r*lc+c] = 0.;
486 }
487 }
488 OK
489}
490
491int cholC(KCMAT(x),CMAT(l)) {
492 REQUIRES(xr==xc && lr==xr && lr==lc,BAD_SIZE);
493 DEBUGMSG("cholC");
494 KCMVIEW(x);
495 CMVIEW(l);
496 gsl_matrix_complex_memcpy(M(l),M(x));
497 int res = 0; // gsl_linalg_complex_cholesky_decomp(M(l));
498 CHECK(res,res);
499 gsl_complex zero = {0.,0.};
500 int r,c;
501 for (r=0; r<xr-1; r++) {
502 for(c=r+1; c<xc; c++) {
503 lp[r*lc+c] = zero;
504 }
505 }
506 OK
507}
508
509int fft(int code, KCVEC(X), CVEC(R)) {
510 REQUIRES(Xn == Rn,BAD_SIZE);
511 DEBUGMSG("fft");
512 int s = Xn;
513 gsl_fft_complex_wavetable * wavetable = gsl_fft_complex_wavetable_alloc (s);
514 gsl_fft_complex_workspace * workspace = gsl_fft_complex_workspace_alloc (s);
515 gsl_vector_const_view X = gsl_vector_const_view_array((double*)Xp, 2*Xn);
516 gsl_vector_view R = gsl_vector_view_array((double*)Rp, 2*Rn);
517 gsl_blas_dcopy(&X.vector,&R.vector);
518 if(code==0) {
519 gsl_fft_complex_forward ((double*)Rp, 1, s, wavetable, workspace);
520 } else {
521 gsl_fft_complex_inverse ((double*)Rp, 1, s, wavetable, workspace);
522 }
523 gsl_fft_complex_wavetable_free (wavetable);
524 gsl_fft_complex_workspace_free (workspace);
525 OK
526}
527
528
529int integrate_qng(double f(double, void*), double a, double b, double prec,
530 double *result, double*error) {
531 DEBUGMSG("integrate_qng");
532 gsl_function F;
533 F.function = f;
534 F.params = NULL;
535 size_t neval;
536 int res = gsl_integration_qng (&F, a,b, 0, prec, result, error, &neval);
537 CHECK(res,res);
538 OK
539}
540
541int integrate_qags(double f(double,void*), double a, double b, double prec, int w,
542 double *result, double* error) {
543 DEBUGMSG("integrate_qags");
544 gsl_integration_workspace * wk = gsl_integration_workspace_alloc (w);
545 gsl_function F;
546 F.function = f;
547 F.params = NULL;
548 int res = gsl_integration_qags (&F, a,b, 0, prec, w,wk, result, error);
549 CHECK(res,res);
550 gsl_integration_workspace_free (wk);
551 OK
552}
553
554int polySolve(KRVEC(a), CVEC(z)) {
555 DEBUGMSG("polySolve");
556 REQUIRES(an>1,BAD_SIZE);
557 gsl_poly_complex_workspace * w = gsl_poly_complex_workspace_alloc (an);
558 int res = gsl_poly_complex_solve ((double*)ap, an, w, (double*)zp);
559 CHECK(res,res);
560 gsl_poly_complex_workspace_free (w);
561 OK;
562}
563
564int matrix_fscanf(char*filename, RMAT(a)) {
565 DEBUGMSG("gsl_matrix_fscanf");
566 //printf(filename); printf("\n");
567 DMVIEW(a);
568 FILE * f = fopen(filename,"r");
569 CHECK(!f,BAD_FILE);
570 int res = gsl_matrix_fscanf(f, M(a));
571 CHECK(res,res);
572 fclose (f);
573 OK
574}
575
576//---------------------------------------------------------------
577
578typedef double Trawfun(int, double*);
579
580double only_f_aux_min(const gsl_vector*x, void *pars) {
581 Trawfun * f = (Trawfun*) pars;
582 double* p = (double*)calloc(x->size,sizeof(double));
583 int k;
584 for(k=0;k<x->size;k++) {
585 p[k] = gsl_vector_get(x,k);
586 }
587 double res = f(x->size,p);
588 free(p);
589 return res;
590}
591
592// this version returns info about intermediate steps
593int minimize(double f(int, double*), double tolsize, int maxit,
594 KRVEC(xi), KRVEC(sz), RMAT(sol)) {
595 REQUIRES(xin==szn && solr == maxit && solc == 3+xin,BAD_SIZE);
596 DEBUGMSG("minimizeList (nmsimplex)");
597 gsl_multimin_function my_func;
598 // extract function from pars
599 my_func.f = only_f_aux_min;
600 my_func.n = xin;
601 my_func.params = f;
602 size_t iter = 0;
603 int status;
604 double size;
605 const gsl_multimin_fminimizer_type *T;
606 gsl_multimin_fminimizer *s = NULL;
607 // Initial vertex size vector
608 KDVVIEW(sz);
609 // Starting point
610 KDVVIEW(xi);
611 // Minimizer nmsimplex, without derivatives
612 T = gsl_multimin_fminimizer_nmsimplex;
613 s = gsl_multimin_fminimizer_alloc (T, my_func.n);
614 gsl_multimin_fminimizer_set (s, &my_func, V(xi), V(sz));
615 do {
616 status = gsl_multimin_fminimizer_iterate (s);
617 size = gsl_multimin_fminimizer_size (s);
618
619 solp[iter*solc+0] = iter;
620 solp[iter*solc+1] = s->fval;
621 solp[iter*solc+2] = size;
622
623 int k;
624 for(k=0;k<xin;k++) {
625 solp[iter*solc+k+3] = gsl_vector_get(s->x,k);
626 }
627 status = gsl_multimin_test_size (size, tolsize);
628 iter++;
629 } while (status == GSL_CONTINUE && iter < maxit);
630 int i,j;
631 for (i=iter; i<solr; i++) {
632 solp[i*solc+0] = iter;
633 for(j=1;j<solc;j++) {
634 solp[i*solc+j]=0.;
635 }
636 }
637 gsl_multimin_fminimizer_free(s);
638 OK
639}
640
641// working with the gradient
642
643typedef struct {double (*f)(int, double*); void (*df)(int, double*, double*);} Tfdf;
644
645double f_aux_min(const gsl_vector*x, void *pars) {
646 Tfdf * fdf = ((Tfdf*) pars);
647 double* p = (double*)calloc(x->size,sizeof(double));
648 int k;
649 for(k=0;k<x->size;k++) {
650 p[k] = gsl_vector_get(x,k);
651 }
652 double res = fdf->f(x->size,p);
653 free(p);
654 return res;
655}
656
657
658void df_aux_min(const gsl_vector * x, void * pars, gsl_vector * g) {
659 Tfdf * fdf = ((Tfdf*) pars);
660 double* p = (double*)calloc(x->size,sizeof(double));
661 double* q = (double*)calloc(x->size,sizeof(double));
662 int k;
663 for(k=0;k<x->size;k++) {
664 p[k] = gsl_vector_get(x,k);
665 }
666
667 fdf->df(x->size,p,q);
668
669 for(k=0;k<x->size;k++) {
670 gsl_vector_set(g,k,q[k]);
671 }
672 free(p);
673 free(q);
674}
675
676void fdf_aux_min(const gsl_vector * x, void * pars, double * f, gsl_vector * g) {
677 *f = f_aux_min(x,pars);
678 df_aux_min(x,pars,g);
679}
680
681// conjugate gradient
682int minimizeWithDeriv(double f(int, double*), void df(int, double*, double*),
683 double initstep, double minimpar, double tolgrad, int maxit,
684 KRVEC(xi), RMAT(sol)) {
685 REQUIRES(solr == maxit && solc == 2+xin,BAD_SIZE);
686 DEBUGMSG("minimizeWithDeriv (conjugate_fr)");
687 gsl_multimin_function_fdf my_func;
688 // extract function from pars
689 my_func.f = f_aux_min;
690 my_func.df = df_aux_min;
691 my_func.fdf = fdf_aux_min;
692 my_func.n = xin;
693 Tfdf stfdf;
694 stfdf.f = f;
695 stfdf.df = df;
696 my_func.params = &stfdf;
697 size_t iter = 0;
698 int status;
699 const gsl_multimin_fdfminimizer_type *T;
700 gsl_multimin_fdfminimizer *s = NULL;
701 // Starting point
702 KDVVIEW(xi);
703 // conjugate gradient fr
704 T = gsl_multimin_fdfminimizer_conjugate_fr;
705 s = gsl_multimin_fdfminimizer_alloc (T, my_func.n);
706 gsl_multimin_fdfminimizer_set (s, &my_func, V(xi), initstep, minimpar);
707 do {
708 status = gsl_multimin_fdfminimizer_iterate (s);
709 solp[iter*solc+0] = iter;
710 solp[iter*solc+1] = s->f;
711 int k;
712 for(k=0;k<xin;k++) {
713 solp[iter*solc+k+2] = gsl_vector_get(s->x,k);
714 }
715 status = gsl_multimin_test_gradient (s->gradient, tolgrad);
716 iter++;
717 } while (status == GSL_CONTINUE && iter < maxit);
718 int i,j;
719 for (i=iter; i<solr; i++) {
720 solp[i*solc+0] = iter;
721 for(j=1;j<solc;j++) {
722 solp[i*solc+j]=0.;
723 }
724 }
725 gsl_multimin_fdfminimizer_free(s);
726 OK
727}
728
729
730int deriv(int code, double f(double, void*), double x, double h, double * result, double * abserr)
731{
732 gsl_function F;
733 F.function = f;
734 F.params = 0;
735
736 if(code==0) return gsl_deriv_central (&F, x, h, result, abserr);
737
738 if(code==1) return gsl_deriv_forward (&F, x, h, result, abserr);
739
740 if(code==2) return gsl_deriv_backward (&F, x, h, result, abserr);
741
742 return 0;
743}