diff options
Diffstat (limited to 'lib/Numeric/GSL/gsl-aux.c')
-rw-r--r-- | lib/Numeric/GSL/gsl-aux.c | 743 |
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 | |||
67 | void no_abort_on_error() { | ||
68 | gsl_set_error_handler_off(); | ||
69 | } | ||
70 | |||
71 | |||
72 | int 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 | |||
91 | inline 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 } | ||
104 | int 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 | |||
130 | int 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 | |||
159 | int mapC(int code, KCVEC(x), CVEC(r)) { | ||
160 | return mapCAux(code, xn, (gsl_complex*)xp, rn, (gsl_complex*)rp); | ||
161 | } | ||
162 | |||
163 | |||
164 | /* | ||
165 | int 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 | |||
176 | int 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 | |||
190 | int 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 | |||
205 | int 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 | |||
221 | int 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 | |||
237 | int 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 } | ||
244 | int 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 | |||
266 | int 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 | |||
288 | int 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 | |||
295 | int 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 | |||
324 | int 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 | |||
352 | int 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 | |||
372 | int 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 | |||
396 | int 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 | ||
421 | int 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 | ||
440 | int 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 | |||
457 | int 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 | |||
474 | int 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 | |||
491 | int 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 | |||
509 | int 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 | |||
529 | int 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 | |||
541 | int 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 | |||
554 | int 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 | |||
564 | int 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 | |||
578 | typedef double Trawfun(int, double*); | ||
579 | |||
580 | double 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 | ||
593 | int 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 | |||
643 | typedef struct {double (*f)(int, double*); void (*df)(int, double*, double*);} Tfdf; | ||
644 | |||
645 | double 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 | |||
658 | void 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 | |||
676 | void 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 | ||
682 | int 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 | |||
730 | int 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 | } | ||