;;; gsl cload timing tests (require libgsl.scm) (require libm.scm) (set! (*s7* 'heap-size) 1024000) (define libgsl:jn (*libgsl* 'gsl_sf_bessel_Jn)) (define libm:jn (*libm* 'jn)) (define (fm-cascade-component-m freq-we-want wc wm1 a wm2 b) (let ((sum 0.0) (mxa (ceiling (* 7 a))) (mxb (ceiling (* 7 b)))) (do ((k (- mxa) (+ k 1))) ((>= k mxa)) (do ((j (- mxb) (+ j 1))) ((>= j mxb)) (set! sum (+ sum (* (libm:jn k a) (libm:jn j (* k b))))))) sum)) (define (fm-cascade-component-g freq-we-want wc wm1 a wm2 b) (let ((sum 0.0) (mxa (ceiling (* 7 a))) (mxb (ceiling (* 7 b)))) (do ((k (- mxa) (+ k 1))) ((>= k mxa)) (do ((j (- mxb) (+ j 1))) ((>= j mxb)) (set! sum (+ sum (* (libgsl:jn k a) (libgsl:jn j (* k b))))))) sum)) (format *stderr* "~A ~A~%" (fm-cascade-component-m 2000 2000 500 1.5 50 1.0) (fm-cascade-component-g 2000 2000 500 1.5 50 1.0)) (define (testfm) (do ((i 0 (+ i 1))) ((= i 1000)) (fm-cascade-component-m 2000 2000 500 1.5 50 1.0) (fm-cascade-component-g 2000 2000 500 1.5 50 1.0))) (testfm) (define (immutable-let L) (with-let L (for-each (lambda (f) (immutable! (car f)) (immutable! (cdr f))) (curlet))) L) (with-let (sublet (immutable-let *libgsl*)) (define (eigenvalues M) (let* ((len (sqrt (length M))) (gm (gsl_matrix_alloc len len)) (m (float-vector->gsl_matrix M gm)) (evl (gsl_vector_complex_alloc len)) (evc (gsl_matrix_complex_alloc len len)) (w (gsl_eigen_nonsymmv_alloc len))) (gsl_eigen_nonsymmv m evl evc w) (gsl_eigen_nonsymmv_free w) (gsl_eigen_nonsymmv_sort evl evc GSL_EIGEN_SORT_ABS_DESC) (let ((vals (make-vector len))) (do ((i 0 (+ i 1))) ((= i len)) (set! (vals i) (gsl_vector_complex_get evl i))) (gsl_matrix_free gm) (gsl_vector_complex_free evl) (gsl_matrix_complex_free evc) vals))) (format *stderr* "~S #(4.0 2.0)~%" (eigenvalues (float-vector 3 1 1 3))) (define testla (let ((fv (float-vector 1 2 4 3))) (lambda () (do ((i 0 (+ i 1))) ((= i 30000)) (eigenvalues fv))))) (testla) (define (num-test expr result) expr) (define (test expr result) expr) (define (testrst) (let ((sfr (gsl_sf_result.make)) (s1 (gsl_sf_result.make)) (s2 (gsl_sf_result.make)) (gs (gsl_cheb_alloc 40)) (g1 (gsl_vector_alloc 3)) (g2 (gsl_vector_alloc 3)) (step_size (gsl_vector_alloc 2)) (v1 (gsl_vector_alloc 2)) (v2 (gsl_vector_alloc 2)) (c1 (gsl_multiset_calloc 4 2)) ) (do ((i 0 (+ i 1))) ((= i 3000)) (num-test (gsl_sf_airy_Ai -500.0 GSL_MODE_DEFAULT) 0.07259012010418163) (num-test (gsl_sf_airy_Bi -500.0 GSL_MODE_DEFAULT) -0.0946885701328829) (num-test (gsl_sf_airy_Ai_scaled -5.0 GSL_MODE_DEFAULT) 0.3507610090241141) (num-test (gsl_sf_airy_Bi_scaled -5.0 GSL_MODE_DEFAULT) -0.1383691349016009) (num-test (gsl_sf_airy_Ai_deriv -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) (num-test (gsl_sf_airy_Bi_deriv -5.0 GSL_MODE_DEFAULT) 0.778411773001899) (num-test (gsl_sf_airy_Ai_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) (num-test (gsl_sf_airy_Bi_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.778411773001899) (num-test (gsl_sf_airy_zero_Ai_deriv 2) -3.248197582179837) (num-test (gsl_sf_airy_zero_Bi_deriv 2) -4.073155089071828) (num-test (gsl_sf_bessel_J0 1.0) 0.7651976865579666) (num-test (begin (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.val sfr)) 0.7651976865579666) (num-test (begin (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.err sfr)) 6.72613016567227e-16) (num-test (gsl_sf_bessel_J0 .1) 0.9975015620660401) (num-test (gsl_sf_bessel_J1 .1) 0.049937526036242) (num-test (gsl_sf_bessel_Jn 45 900.0) 0.02562434700634277) (num-test (gsl_sf_bessel_Y0 .1) -1.534238651350367) (num-test (gsl_sf_bessel_Y1 .1) -6.458951094702027) (num-test (gsl_sf_bessel_Yn 4 .1) -305832.2979335312) (num-test (gsl_sf_bessel_I0_scaled .1) 0.9071009257823011) (num-test (gsl_sf_bessel_I1_scaled .1) 0.04529844680880932) (num-test (gsl_sf_bessel_In_scaled 4 .1) 2.35752586200546e-07) (num-test (gsl_sf_bessel_I0 .1) 1.002501562934096) (num-test (gsl_sf_bessel_I1 .1) 0.05006252604709269) (num-test (gsl_sf_bessel_In 4 .1) 2.605469021299657e-07) (num-test (gsl_sf_bessel_K0_scaled .1) 2.682326102262894) (num-test (gsl_sf_bessel_K1_scaled .1) 10.8901826830497) (num-test (gsl_sf_bessel_Kn_scaled 4 .1) 530040.2483725621) (num-test (gsl_sf_bessel_K0 .1) 2.427069024702016) (num-test (gsl_sf_bessel_K1 .1) 9.853844780870606) (num-test (gsl_sf_bessel_Kn 4 .1) 479600.2497925678) (num-test (gsl_sf_bessel_j0 1.0) 0.8414709848078965) (num-test (gsl_sf_bessel_j1 1.0) 0.3011686789397567) (num-test (gsl_sf_bessel_j2 1.0) 0.06203505201137386) (num-test (gsl_sf_bessel_jl 5 1.0) 9.256115861125814e-05) (num-test (gsl_sf_bessel_zero_J0 1) 2.404825557695771) (num-test (gsl_sf_bessel_zero_Jnu 5 5) 22.21779994656127) (num-test (gsl_sf_hydrogenicR_1 3 2) 0.02575994825614847) (num-test (gsl_sf_dilog -3.0) -1.939375420766708) (gsl_sf_complex_dilog_e 0.99999 (/ pi 2) s1 s2) (num-test (gsl_sf_result.val s1) -0.2056132926277968) (num-test (gsl_sf_result.val s2) 0.9159577401813151) (gsl_sf_complex_spence_xy_e 0.5 0.0 s1 s2) (num-test (gsl_sf_result.val s1) 0.5822405264650126) (num-test (gsl_sf_result.val s2) 0.0) (num-test (gsl_sf_lngamma -0.1) 2.368961332728787) (num-test (gsl_sf_gamma 9.0) 40320.0) (num-test (gsl_sf_gammastar 9.0) 1.009298426421819) (num-test (gsl_sf_gammainv -1.0) 0.0) (gsl_sf_lngamma_complex_e 5.0 2.0 s1 s2) (num-test (gsl_sf_result.val s1) 2.748701756133804) (num-test (gsl_sf_result.val s2) 3.073843410049702) (num-test (gsl_sf_taylorcoeff 10 5) 2.691144455467373) (num-test (gsl_sf_choose 7 3) 35.0) (num-test (gsl_sf_poch 7 3) 504.0000000000001) (num-test (gsl_sf_gamma_inc_P 1.0 10.0) 0.9999546000702381) (num-test (gsl_sf_lnbeta 0.1 1.0) 2.302585092994044) (num-test (gsl_sf_beta 100.1 -1.2) 1203.895236907804) (num-test (gsl_sf_hyperg_0F1 1 0.5) 1.56608292975635) (num-test (gsl_sf_hyperg_1F1 1 1.5 1) 2.030078469278705) (num-test (gsl_sf_hyperg_U_int 100 100 1) 0.009998990209084679) (num-test (gsl_sf_hyperg_2F1 1 1 1 0.5) 2.0) (num-test (gsl_sf_legendre_P1 -0.5) -0.5) (num-test (gsl_sf_legendre_sphPlm 10 0 -0.5) -0.2433270236930014) (num-test (gsl_sf_legendre_Q0 -0.5) -0.5493061443340549) (num-test (gsl_sf_clausen (+ (* 2 pi) (/ pi 3))) 1.014941606409653) (num-test (gsl_sf_coupling_3j 0 1 1 0 1 -1) 0.7071067811865476) (num-test (gsl_sf_dawson 0.5) 0.4244363835020223) (num-test (gsl_sf_multiply -3 2) -6.0) (num-test (gsl_sf_ellint_E (/ pi 2) 0.5 GSL_MODE_DEFAULT) 1.467462209339427) (num-test (gsl_sf_erfc -10) 2.0) (num-test (gsl_sf_exp_mult 10 -2) -44052.93158961344) (num-test (gsl_sf_expm1 -.001) -0.0009995001666250082) (num-test (gsl_sf_Shi -1) -1.057250875375728) (num-test (gsl_sf_fermi_dirac_0 -1) 0.3132616875182229) (num-test (gsl_sf_gegenpoly_1 1.0 1.0) 2.0) (let ((p (float-vector 1.0 -2.0 1.0)) (res (vector 0.0 0.0))) (gsl_poly_complex_solve (wrap-double* p) 3 res) (test res #(1.0 1.0))) (let ((p (float-vector 1 -1 1 -1 1 -1 1 -1 1 -1 1))) (num-test (gsl_poly_eval (wrap-double* p) 11 1.0) 1.0)) (let ((p (float-vector 2.1 -1.34 0.76 0.45))) (num-test (gsl_poly_complex_eval (wrap-double* p) 4 0.49+0.95i) 0.3959142999999998-0.6433305000000001i)) (let ((res (float-vector 0.0 0.0))) (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 26.0 (wrap-double* res)))) (test err 0))) (let ((res (float-vector 0.0 0.0))) (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 21.0 (wrap-double* res)))) (test res (float-vector 1.5 3.5)))) (let ((res (float-vector 0.0 0.0 0.0))) (let ((err (gsl_poly_solve_cubic -51 867 -4913 (wrap-double* res)))) (test res (float-vector 17.0 17.0 17.0)))) (let ((res (vector 0.0 0.0))) (let ((err (gsl_poly_complex_solve_quadratic 4.0 -20.0 26.0 res))) (test res #(2.5-0.5i 2.5+0.5i)))) (let ((res (vector 0.0 0.0 0.0))) ; workspace handling is internal (let ((err (gsl_poly_complex_solve_cubic -51 867 -4913 res))) (test res #(17.0 17.0 17.0)))) (num-test (gsl_hypot3 1.0 1.0 1.0) (sqrt 3)) (num-test (gsl_hypot 1.0 1.0) (sqrt 2)) (test (nan? (gsl_nan)) #t) (test (infinite? (gsl_posinf)) #t) (test (gsl_frexp 2.0) '(0.5 2)) (num-test (gsl_pow_2 4) 16.0) (num-test (gsl_cdf_ugaussian_P 0.0) 0.5) (num-test (gsl_cdf_ugaussian_P 0.5) 0.691462461274013) (num-test (gsl_cdf_ugaussian_Q 0.5) 0.3085375387259869) (num-test (gsl_cdf_ugaussian_Pinv 0.5) 0.0) (num-test (gsl_cdf_ugaussian_Qinv 0.5) 0.0) (num-test (gsl_cdf_exponential_P 0.1 0.7) 0.1331221002498184) (num-test (gsl_cdf_exponential_Q 0.1 0.7) 0.8668778997501816) (num-test (gsl_cdf_exponential_Pinv 0.13 0.7) 0.09748344713345537) (num-test (gsl_cdf_exponential_Qinv 0.86 0.7) 0.1055760228142086) (num-test (gsl_cdf_exppow_P -0.1 0.7 1.8) 0.4205349082867516) (num-test (gsl_cdf_exppow_Q -0.1 0.7 1.8) 0.5794650917132484) (num-test (gsl_cdf_tdist_P 0.0 1.0) 0.5) (num-test (gsl_cdf_tdist_Q 0.0 1.0) 0.5) (num-test (gsl_cdf_fdist_P 0.0 1.0 1.3) 0.0) (num-test (gsl_cdf_fdist_Q 0.0 1.0 1.3) 1.0) (num-test (gsl_cdf_fdist_Pinv 0.0 1.0 1.3) 0.0) (num-test (gsl_cdf_fdist_Qinv 1.0 1.0 1.3) 0.0) (num-test (gsl_cdf_gamma_P 0 1 1) 0.0) (num-test (gsl_cdf_gamma_Q 0 1 1) 1.0) (num-test (gsl_cdf_chisq_P 0 13) 0.0) (num-test (gsl_cdf_chisq_Q 0 13) 1.0) (num-test (gsl_cdf_beta_P 0 1.2 1.3) 0.0) (num-test (gsl_cdf_beta_Q 0 1.2 1.3) 1.0) (num-test (gsl_stats_mean (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 2.5) (num-test (gsl_stats_skew (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 0.0) (num-test (gsl_stats_max (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 4.0) (let ((rng (gsl_rng_alloc gsl_rng_default))) (test (real? (gsl_ran_exponential rng 1.0)) #t) (gsl_rng_free rng)) (num-test (gsl_complex_log 1+i) (log 1+i)) (num-test (gsl_complex_abs 1+i) (magnitude 1+i)) (num-test (gsl_complex_sin 1+i) (sin 1+i)) (gsl_cheb_init gs (lambda (x) x) -1.0 1.0) (num-test (gsl_cheb_eval gs -1.0) -1.0) (num-test (gsl_cheb_eval gs 0.0) 0.0) (num-test (gsl_cheb_eval gs 1.0) 1.0) (let ((x (float-vector 0.0)) (y (float-vector 0.0))) (gsl_deriv_central (lambda (x) (expt x 1.5)) 2.0 1e-8 (wrap-double* x) (wrap-double* y)) (num-test (x 0) (* 1.5 (sqrt 2))) (gsl_deriv_forward (lambda (x) (expt x 1.5)) 0.0 1e-8 (wrap-double* x) (wrap-double* y)) (test (< (x 0) 1e-5) #t)) (let ((f (float-vector -1 3 0 4 2 6))) (gsl_sort (wrap-double* f) 1 6) (test f (float-vector -1 0 2 3 4 6))) (let ((f1 (make-float-vector 3))) (gsl_vector_add (float-vector->gsl_vector (float-vector 0 1 2) g1) (float-vector->gsl_vector (float-vector 3 4 5) g2)) (gsl_vector->float-vector g1 f1) (test f1 (float-vector 3 5 7))) (let ((f (make-float-vector '(3 3)))) (let ((g (gsl_matrix_alloc 3 3))) (gsl_matrix_set_identity g) (do ((i 0 (+ i 1))) ((= i 3) (gsl_matrix_free g)) (do ((j 0 (+ j 1))) ((= j 3)) (set! (f i j) (gsl_matrix_get g i j))))) (test (equivalent? f #2d((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))) #t)) (let ((f (make-vector '(3 3)))) (let ((g (gsl_matrix_complex_alloc 3 3))) (gsl_matrix_complex_set_identity g) (gsl_matrix_complex_scale g 1+i) (do ((i 0 (+ i 1))) ((= i 3) (gsl_matrix_complex_free g)) (do ((j 0 (+ j 1))) ((= j 3)) (set! (f i j) (gsl_matrix_complex_get g i j))))) (test (equivalent? f #2d((1+i 0.0 0.0) (0.0 1+i 0.0) (0.0 0.0 1+i))) #t)) (let ((Y (float-vector 0.554)) (A (float-vector -0.047)) (X (float-vector 0.672))) (cblas_dgemv 101 111 1 1 -0.3 (wrap-double* A) 1 (wrap-double* X) -1 -1 (wrap-double* Y) -1) (num-test (Y 0) -0.5445248)) (let ((Y (float-vector 0.348 0.07)) (A (float-vector 0.932 -0.724)) (X (float-vector 0.334 -0.317)) (alpha (float-vector 0 .1)) (beta (float-vector 1 0))) (cblas_zgemv 101 111 1 1 (wrap-double* alpha) (wrap-double* A) 1 (wrap-double* X) -1 (wrap-double* beta) (wrap-double* Y) -1) (num-test (Y 0) 0.401726) (num-test (Y 1) 0.078178)) (test (let ((f (float-vector 0 1 2 3 4))) (gsl_interp_bsearch (wrap-double* f) 1.5 0 4)) 1) (let ((x (make-float-vector 10)) (y (make-float-vector 10))) (do ((i 0 (+ i 1))) ((= i 10)) (set! (x i) (+ i (* 0.5 (sin i)))) (set! (y i) (+ i (cos (* i i))))) (let ((acc (gsl_interp_accel_alloc)) (spline (gsl_spline_alloc gsl_interp_cspline 10))) (gsl_spline_init spline (wrap-double* x) (wrap-double* y) 10) (let ((res (gsl_spline_eval spline (x 5) acc))) (gsl_spline_free spline) (gsl_interp_accel_free acc) (num-test res 5.991202811863474)))) (let ((c (gsl_combination_alloc 6 3)) (data #2d((0 1 2) (0 1 3) (0 1 4) (0 1 5) (0 2 3) (0 2 4) (0 2 5) (0 3 4) (0 3 5) (0 4 5) (1 2 3) (1 2 4) (1 2 5) (1 3 4) (1 3 5) (1 4 5) (2 3 4) (2 3 5) (2 4 5) (3 4 5))) (iv (make-int-vector 3 0))) (gsl_combination_init_first c) (do ((i 0 (+ i 1))) ((= i 20)) ((*libgsl* 'gsl_combination->int-vector) c iv) (if (not (equivalent? iv (data i))) (format *stderr* ";gsl_combination: ~A ~A~%" iv (data i))) (gsl_combination_next c)) (gsl_combination_free c)) (let ((p (gsl_permutation_alloc 3)) (data (make-int-vector 18 0))) (gsl_permutation_init p) (do ((pp GSL_SUCCESS (gsl_permutation_next p)) (i 0 (+ i 3))) ((not (= pp GSL_SUCCESS))) (set! (data i) (gsl_permutation_get p 0)) (set! (data (+ i 1)) (gsl_permutation_get p 1)) (set! (data (+ i 2)) (gsl_permutation_get p 2))) (gsl_permutation_free p) (test (equivalent? data #(0 1 2 0 2 1 1 0 2 1 2 0 2 0 1 2 1 0)) #t)) (let ((N 50)) (let ((t (make-float-vector N 0.0))) (do ((i 0 (+ i 1))) ((= i N)) (set! (t i) (/ 1.0 (* (+ i 1) (+ i 1))))) (let ((zeta_2 (/ (* pi pi) 6.0))) (let ((accel (float-vector 0.0)) (err (float-vector 0.0)) (w (gsl_sum_levin_u_alloc N))) (gsl_sum_levin_u_accel (wrap-double* t) N w (wrap-double* accel) (wrap-double* err)) (num-test zeta_2 (accel 0)) (gsl_sum_levin_u_free w))))) (let ((data (float-vector 0 0 1 0 1 1 0 -1)) ; complex data as rl+im coming and going (output (make-float-vector 8 0.0))) (gsl_dft_complex_forward (wrap-double* data) 1 4 (wrap-double* output)) ;; = -1 in snd terminology: (cfft! (vector 0 1 1+i 0-i) 4 -1): #(2.0 0-2i 0+2i -2.0) (test (equivalent? output (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) (let ((data (float-vector 0 0 1 0 1 1 0 -1))) ; complex data as rl+im coming and going (gsl_fft_complex_radix2_forward (wrap-double* data) 1 4) (test (equivalent? data (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) (let ((data (make-float-vector 256)) (w (gsl_wavelet_alloc gsl_wavelet_daubechies 4)) (work (gsl_wavelet_workspace_alloc 256))) (do ((i 0 (+ i 1))) ((= i 256)) (set! (data i) (sin (* i (/ pi 128))))) (gsl_wavelet_transform_forward w (wrap-double* data) 1 256 work) (gsl_wavelet_transform_inverse w (wrap-double* data) 1 256 work) (gsl_wavelet_free w) (gsl_wavelet_workspace_free work) data) (let ((h (gsl_histogram_alloc 10)) (data (make-int-vector 10))) (gsl_histogram_set_ranges_uniform h 0.0 1.0) (do ((i 0 (+ i 1))) ((= i 50)) (gsl_histogram_increment h (random 1.0))) (do ((i 0 (+ i 1))) ((= i 10)) (set! (data i) (round (gsl_histogram_get h i)))) (gsl_histogram_free h) data) (let ((a_data (float-vector 0.18 0.60 0.57 0.96 0.41 0.24 0.99 0.58 0.14 0.30 0.97 0.66 0.51 0.13 0.19 0.85)) (b_data (float-vector 1 2 3 4))) (let ((m (gsl_matrix_alloc 4 4)) (b (gsl_vector_alloc 4))) (let ((x (gsl_vector_alloc 4)) (p (gsl_permutation_alloc 4))) (do ((i 0 (+ i 1))) ((= i 4)) (do ((j 0 (+ j 1))) ((= j 4)) (gsl_matrix_set m i j (a_data (+ j (* i 4)))))) (do ((i 0 (+ i 1))) ((= i 4)) (gsl_vector_set b i (b_data i))) (gsl_linalg_LU_decomp m p) ; int-by-ref is internal (gsl_linalg_LU_solve m p b x) (do ((i 0 (+ i 1))) ((= i 4)) (set! (b_data i) (gsl_vector_get x i))) (gsl_permutation_free p) (gsl_vector_free x) (gsl_matrix_free m) (gsl_vector_free b) b_data))) (when (>= gsl-version 1.16) (let () (define (dofit T X y c cov) (let ((work (gsl_multifit_robust_alloc T (car (gsl_matrix_size X)) (cdr (gsl_matrix_size X))))) (let ((s (gsl_multifit_robust X y c cov work))) (gsl_multifit_robust_free work) s))) (let* ((n 30) (p 2) (a 1.45) (b 3.88) (X (gsl_matrix_alloc n p)) (x (gsl_vector_alloc n)) (y (gsl_vector_alloc n)) (c (gsl_vector_alloc p)) (c_ols (gsl_vector_alloc p)) (cov (gsl_matrix_alloc p p)) (gv (gsl_vector_alloc p)) (r (gsl_rng_alloc gsl_rng_default))) (do ((i 0 (+ i 1))) ((= i (- n 3))) (let* ((dx (/ 10.0 (- n 1.0))) (ei (gsl_rng_uniform r)) (xi (+ -5.0 (* i dx))) (yi (+ b (* a xi)))) (gsl_vector_set x i xi) (gsl_vector_set y i (+ yi ei)))) (gsl_vector_set x (- n 3) 4.7) (gsl_vector_set y (- n 3) -8.3) (gsl_vector_set x (- n 2) 3.5) (gsl_vector_set y (- n 2) -6.7) (gsl_vector_set x (- n 1) 4.1) (gsl_vector_set y (- n 1) -6.0) (do ((i 0 (+ i 1))) ((= i n)) (let ((xi (gsl_vector_get x i))) (gsl_matrix_set X i 0 1.0) (gsl_matrix_set X i 1 xi))) (dofit gsl_multifit_robust_ols X y c_ols cov) (dofit gsl_multifit_robust_bisquare X y c cov) (do ((i 0 (+ i 1))) ((= i n)) (let ((xi (gsl_vector_get x i)) (yi (gsl_vector_get y i)) (y_ols (float-vector 0.0)) (y_rob (float-vector 0.0)) (y_err (float-vector 0.0))) (gsl_vector_set gv 0 (gsl_matrix_get X i 0)) (gsl_vector_set gv 1 (gsl_matrix_get X i 1)) (gsl_multifit_robust_est gv c cov (wrap-double* y_rob) (wrap-double* y_err)) (gsl_multifit_robust_est gv c_ols cov (wrap-double* y_ols) (wrap-double* y_err)))) (gsl_matrix_free X) (gsl_matrix_free cov) (gsl_vector_free x) (gsl_vector_free y) (gsl_vector_free c) (gsl_vector_free gv) (gsl_vector_free c_ols) (gsl_rng_free r)))) (let () (gsl_rng_env_setup) (let* ((T gsl_rng_default) (r (gsl_rng_alloc T)) (x 0) (y 0) (dx (float-vector 0.0)) (dy (float-vector 0.0))) (do ((i 0 (+ i 1))) ((= i 10)) (gsl_ran_dir_2d r (wrap-double* dx) (wrap-double* dy)) (set! x (+ x (dx 0))) (set! y (+ y (dy 0)))) (gsl_rng_free r))) (let ((T gsl_multimin_fminimizer_nmsimplex)) (define (simple-abs x) (let ((u (gsl_vector_get x 0)) (v (gsl_vector_get x 1))) (let ((a (- u 1)) (b (- v 2))) (+ (abs a) (abs b))))) (let ((s3 (gsl_multimin_fminimizer_alloc T 2))) (gsl_vector_set v2 0 1.0) (gsl_vector_set v2 1 2.0) (gsl_vector_set step_size 0 1) (gsl_vector_set step_size 1 1) (gsl_multimin_fminimizer_set s3 simple-abs v2 step_size) (do ((i 0 (+ i 1))) ((= i 10)) (gsl_multimin_fminimizer_iterate s3)) (let ((result (abs (gsl_multimin_fminimizer_fval s3)))) (gsl_multimin_fminimizer_free s3) (num-test result 0.0)))) (let ((n 4) (x (float-vector 1970 1980 1990 2000)) (y (float-vector 12 11 14 13)) (w (float-vector 0.1 0.2 0.3 0.4)) (c0 (float-vector 0.0)) (c1 (float-vector 0.0)) (cov00 (float-vector 0.0)) (cov01 (float-vector 0.0)) (cov11 (float-vector 0.0)) (chisq (float-vector 0.0))) (gsl_fit_wlinear (wrap-double* x) 1 (wrap-double* w) 1 (wrap-double* y) 1 n (wrap-double* c0) (wrap-double* c1) (wrap-double* cov00) (wrap-double* cov01) (wrap-double* cov11) (wrap-double* chisq)) (num-test (+ (c0 0) (c1 0)) -106.54)) (test (list (gsl_multiset_n c1) (gsl_multiset_k c1)) '(4 2)) (let ((factor 1.0) (T gsl_multiroot_fsolver_dnewton)) (define (rosenb x f) (let ((x0 (gsl_vector_get x 0)) (x1 (gsl_vector_get x 1))) (let ((y0 (- 1 x0)) (y1 (* 10 (- x1 (* x0 x0))))) (gsl_vector_set f 0 y0) (gsl_vector_set f 1 y1) GSL_SUCCESS))) (gsl_vector_set v1 0 -1.2) (gsl_vector_set v1 1 1.0) (let ((s (gsl_multiroot_fsolver_alloc T 2))) (gsl_multiroot_fsolver_set s rosenb v1) (do ((i 0 (+ i 1))) ((= i 10)) (gsl_multiroot_fsolver_iterate s)) (let ((residual (abs (gsl_vector_get (gsl_multiroot_fsolver_f s) 0)))) (gsl_multiroot_fsolver_free s) (test residual 0.0))))) (gsl_sf_result.free sfr) (gsl_sf_result.free s1) (gsl_sf_result.free s2) (gsl_cheb_free gs) (gsl_vector_free g1) (gsl_vector_free g2) (gsl_vector_free v1) (gsl_multiset_free c1) (gsl_vector_free v2) (gsl_vector_free step_size) )) (testrst)) (require libm.scm) (define jn (*libm* 'jn)) ; coverage tests for opt_d_id* (define (f v) (do ((i 0 (+ i 1))) ((= i 1) v) (float-vector-set! v 0 (jn 0 1.0)))) (let ((val (f (float-vector 0.0)))) (unless (equivalent? val #r(0.7651976865579666)) (format *stderr* "jn 1: ~S ~S~%" val (f (float-vector 0.0))))) (define (f1 v) (do ((i 0 (+ i 1))) ((= i 1) v) (float-vector-set! v 0 (jn (+ i 1) 1.0)))) (let ((val (f1 (float-vector 0.0)))) (unless (equivalent? val #r(0.4400505857449335)) (format *stderr* "jn 2: ~S ~S~%" val (f (float-vector 0.0))))) (define (f2 v) (do ((i 0 (+ i 1))) ((= i 1) v) (float-vector-set! v 0 (jn i 1.0)))) (let ((val (f2 (float-vector 0.0)))) (unless (equivalent? val #r(0.7651976865579666)) (format *stderr* "jn 3: ~S ~S~%" val (f (float-vector 0.0))))) (when (provided? 'debugging) (display ((*s7* 'memory-usage) :wrappers)) (newline)) (exit)