int gsl_sf_multiply_e(const double x, const double y, gsl_sf_result * result) { const double ax = fabs(x); const double ay = fabs(y); if(x == 0.0 || y == 0.0) { /* It is necessary to eliminate this immediately. */ result->val = 0.0; result->err = 0.0; return GSL_SUCCESS; } else if((ax <= 1.0 && ay >= 1.0) || (ay <= 1.0 && ax >= 1.0)) { /* Straddling 1.0 is always safe. */ result->val = x*y; result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val); return GSL_SUCCESS; } else { const double f = 1.0 - 2.0 * GSL_DBL_EPSILON; const double min = GSL_MIN_DBL(fabs(x), fabs(y)); const double max = GSL_MAX_DBL(fabs(x), fabs(y)); if(max < 0.9 * GSL_SQRT_DBL_MAX || min < (f * DBL_MAX)/max) { result->val = GSL_COERCE_DBL(x*y); result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val); CHECK_UNDERFLOW(result); return GSL_SUCCESS; } else { OVERFLOW_ERROR(result); } } }
static int qag (const gsl_function * f, const double a, const double b, const double epsabs, const double epsrel, const size_t limit, gsl_integration_workspace * workspace, double *result, double *abserr, gsl_integration_rule * q) { double area, errsum; double result0, abserr0, resabs0, resasc0; double tolerance; size_t iteration = 0; int roundoff_type1 = 0, roundoff_type2 = 0, error_type = 0; double round_off; /* Initialize results */ initialise (workspace, a, b); *result = 0; *abserr = 0; if (limit > workspace->limit) { GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ; } if (epsabs <= 0 && (epsrel < 50 * GSL_DBL_EPSILON || epsrel < 0.5e-28)) { GSL_ERROR ("tolerance cannot be acheived with given epsabs and epsrel", GSL_EBADTOL); } /* perform the first integration */ q (f, a, b, &result0, &abserr0, &resabs0, &resasc0); set_initial_result (workspace, result0, abserr0); /* Test on accuracy */ tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (result0)); /* need IEEE rounding here to match original quadpack behavior */ round_off = GSL_COERCE_DBL (50 * GSL_DBL_EPSILON * resabs0); if (abserr0 <= round_off && abserr0 > tolerance) { *result = result0; *abserr = abserr0; GSL_ERROR ("cannot reach tolerance because of roundoff error " "on first attempt", GSL_EROUND); } else if ((abserr0 <= tolerance && abserr0 != resasc0) || abserr0 == 0.0) { *result = result0; *abserr = abserr0; return GSL_SUCCESS; } else if (limit == 1) { *result = result0; *abserr = abserr0; GSL_ERROR ("a maximum of one iteration was insufficient", GSL_EMAXITER); } area = result0; errsum = abserr0; iteration = 1; do { double a1, b1, a2, b2; double a_i, b_i, r_i, e_i; double area1 = 0, area2 = 0, area12 = 0; double error1 = 0, error2 = 0, error12 = 0; double resasc1, resasc2; double resabs1, resabs2; /* Bisect the subinterval with the largest error estimate */ retrieve (workspace, &a_i, &b_i, &r_i, &e_i); a1 = a_i; b1 = 0.5 * (a_i + b_i); a2 = b1; b2 = b_i; q (f, a1, b1, &area1, &error1, &resabs1, &resasc1); q (f, a2, b2, &area2, &error2, &resabs2, &resasc2); area12 = area1 + area2; error12 = error1 + error2; errsum += (error12 - e_i); area += area12 - r_i; if (resasc1 != error1 && resasc2 != error2) { double delta = r_i - area12; if (fabs (delta) <= 1.0e-5 * fabs (area12) && error12 >= 0.99 * e_i) { roundoff_type1++; } if (iteration >= 10 && error12 > e_i) { roundoff_type2++; } } tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (area)); if (errsum > tolerance) { if (roundoff_type1 >= 6 || roundoff_type2 >= 20) { error_type = 2; /* round off error */ } /* set error flag in the case of bad integrand behaviour at a point of the integration range */ if (subinterval_too_small (a1, a2, b2)) { error_type = 3; } } update (workspace, a1, b1, area1, error1, a2, b2, area2, error2); retrieve (workspace, &a_i, &b_i, &r_i, &e_i); iteration++; } while (iteration < limit && !error_type && errsum > tolerance); *result = sum_results (workspace); *abserr = errsum; if (errsum <= tolerance) { return GSL_SUCCESS; } else if (error_type == 2) { GSL_ERROR ("roundoff error prevents tolerance from being achieved", GSL_EROUND); } else if (error_type == 3) { GSL_ERROR ("bad integrand behavior found in the integration interval", GSL_ESING); } else if (iteration == limit) { GSL_ERROR ("maximum number of subdivisions reached", GSL_EMAXITER); } else { GSL_ERROR ("could not integrate function", GSL_EFAILED); } }
/* Evolution framework method. * * Uses an adaptive step control object */ int gsl_odeiv_evolve_apply (gsl_odeiv_evolve * e, gsl_odeiv_control * con, gsl_odeiv_step * step, const gsl_odeiv_system * dydt, double *t, double t1, double *h, double y[]) { const double t0 = *t; double h0 = *h; int step_status; int final_step = 0; double dt = t1 - t0; /* remaining time, possibly less than h */ if (e->dimension != step->dimension) { GSL_ERROR ("step dimension must match evolution size", GSL_EINVAL); } if ((dt < 0.0 && h0 > 0.0) || (dt > 0.0 && h0 < 0.0)) { GSL_ERROR ("step direction must match interval direction", GSL_EINVAL); } /* No need to copy if we cannot control the step size. */ if (con != NULL) { DBL_MEMCPY (e->y0, y, e->dimension); } /* Calculate initial dydt once if the method can benefit. */ if (step->type->can_use_dydt_in) { int status = GSL_ODEIV_FN_EVAL (dydt, t0, y, e->dydt_in); if (status) { return status; } } try_step: if ((dt >= 0.0 && h0 > dt) || (dt < 0.0 && h0 < dt)) { h0 = dt; final_step = 1; } else { final_step = 0; } if (step->type->can_use_dydt_in) { step_status = gsl_odeiv_step_apply (step, t0, h0, y, e->yerr, e->dydt_in, e->dydt_out, dydt); } else { step_status = gsl_odeiv_step_apply (step, t0, h0, y, e->yerr, NULL, e->dydt_out, dydt); } /* Check for stepper internal failure */ if (step_status != GSL_SUCCESS) { *h = h0; /* notify user of step-size which caused the failure */ return step_status; } e->count++; e->last_step = h0; if (final_step) { *t = t1; } else { *t = t0 + h0; } if (con != NULL) { /* Check error and attempt to adjust the step. */ double h_old = h0; const int hadjust_status = gsl_odeiv_control_hadjust (con, step, y, e->yerr, e->dydt_out, &h0); if (hadjust_status == GSL_ODEIV_HADJ_DEC) { /* Check that the reported status is correct (i.e. an actual decrease in h0 occured) and the suggested h0 will change the time by at least 1 ulp */ double t_curr = GSL_COERCE_DBL(*t); double t_next = GSL_COERCE_DBL((*t) + h0); if (fabs(h0) < fabs(h_old) && t_next != t_curr) { /* Step was decreased. Undo step, and try again with new h0. */ DBL_MEMCPY (y, e->y0, dydt->dimension); e->failed_steps++; goto try_step; } else { h0 = h_old; /* keep current step size */ } } } *h = h0; /* suggest step size for next time-step */ return step_status; }
int gsl_linalg_SV_decomp_jacobi (gsl_matrix * A, gsl_matrix * Q, gsl_vector * S) { if (A->size1 < A->size2) { /* FIXME: only implemented M>=N case so far */ GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL); } else if (Q->size1 != A->size2) { GSL_ERROR ("square matrix Q must match second dimension of matrix A", GSL_EBADLEN); } else if (Q->size1 != Q->size2) { GSL_ERROR ("matrix Q must be square", GSL_ENOTSQR); } else if (S->size != A->size2) { GSL_ERROR ("length of vector S must match second dimension of matrix A", GSL_EBADLEN); } else { const size_t M = A->size1; const size_t N = A->size2; size_t i, j, k; /* Initialize the rotation counter and the sweep counter. */ int count = 1; int sweep = 0; int sweepmax = 5*N; double tolerance = 10 * M * GSL_DBL_EPSILON; /* Always do at least 12 sweeps. */ sweepmax = GSL_MAX (sweepmax, 12); /* Set Q to the identity matrix. */ gsl_matrix_set_identity (Q); /* Store the column error estimates in S, for use during the orthogonalization */ for (j = 0; j < N; j++) { gsl_vector_view cj = gsl_matrix_column (A, j); double sj = gsl_blas_dnrm2 (&cj.vector); gsl_vector_set(S, j, GSL_DBL_EPSILON * sj); } /* Orthogonalize A by plane rotations. */ while (count > 0 && sweep <= sweepmax) { /* Initialize rotation counter. */ count = N * (N - 1) / 2; for (j = 0; j < N - 1; j++) { for (k = j + 1; k < N; k++) { double a = 0.0; double b = 0.0; double p = 0.0; double q = 0.0; double cosine, sine; double v; double abserr_a, abserr_b; int sorted, orthog, noisya, noisyb; gsl_vector_view cj = gsl_matrix_column (A, j); gsl_vector_view ck = gsl_matrix_column (A, k); gsl_blas_ddot (&cj.vector, &ck.vector, &p); p *= 2.0 ; /* equation 9a: p = 2 x.y */ a = gsl_blas_dnrm2 (&cj.vector); b = gsl_blas_dnrm2 (&ck.vector); q = a * a - b * b; v = hypot(p, q); /* test for columns j,k orthogonal, or dominant errors */ abserr_a = gsl_vector_get(S,j); abserr_b = gsl_vector_get(S,k); sorted = (GSL_COERCE_DBL(a) >= GSL_COERCE_DBL(b)); orthog = (fabs (p) <= tolerance * GSL_COERCE_DBL(a * b)); noisya = (a < abserr_a); noisyb = (b < abserr_b); if (sorted && (orthog || noisya || noisyb)) { count--; continue; } /* calculate rotation angles */ if (v == 0 || !sorted) { cosine = 0.0; sine = 1.0; } else { cosine = sqrt((v + q) / (2.0 * v)); sine = p / (2.0 * v * cosine); } /* apply rotation to A */ for (i = 0; i < M; i++) { const double Aik = gsl_matrix_get (A, i, k); const double Aij = gsl_matrix_get (A, i, j); gsl_matrix_set (A, i, j, Aij * cosine + Aik * sine); gsl_matrix_set (A, i, k, -Aij * sine + Aik * cosine); } gsl_vector_set(S, j, fabs(cosine) * abserr_a + fabs(sine) * abserr_b); gsl_vector_set(S, k, fabs(sine) * abserr_a + fabs(cosine) * abserr_b); /* apply rotation to Q */ for (i = 0; i < N; i++) { const double Qij = gsl_matrix_get (Q, i, j); const double Qik = gsl_matrix_get (Q, i, k); gsl_matrix_set (Q, i, j, Qij * cosine + Qik * sine); gsl_matrix_set (Q, i, k, -Qij * sine + Qik * cosine); } } } /* Sweep completed. */ sweep++; } /* * Orthogonalization complete. Compute singular values. */ { double prev_norm = -1.0; for (j = 0; j < N; j++) { gsl_vector_view column = gsl_matrix_column (A, j); double norm = gsl_blas_dnrm2 (&column.vector); /* Determine if singular value is zero, according to the criteria used in the main loop above (i.e. comparison with norm of previous column). */ if (norm == 0.0 || prev_norm == 0.0 || (j > 0 && norm <= tolerance * prev_norm)) { gsl_vector_set (S, j, 0.0); /* singular */ gsl_vector_set_zero (&column.vector); /* annihilate column */ prev_norm = 0.0; } else { gsl_vector_set (S, j, norm); /* non-singular */ gsl_vector_scale (&column.vector, 1.0 / norm); /* normalize column */ prev_norm = norm; } } } if (count > 0) { /* reached sweep limit */ GSL_ERROR ("Jacobi iterations did not reach desired tolerance", GSL_ETOL); } return GSL_SUCCESS; } }
/* Evolution framework method. * * Uses an adaptive step control object */ int gsl_odeiv2_evolve_apply (gsl_odeiv2_evolve * e, gsl_odeiv2_control * con, gsl_odeiv2_step * step, const gsl_odeiv2_system * dydt, double *t, double t1, double *h, double y[]) { const double t0 = *t; double h0 = *h; int step_status; int final_step = 0; double dt = t1 - t0; /* remaining time, possibly less than h */ if (e->dimension != step->dimension) { GSL_ERROR ("step dimension must match evolution size", GSL_EINVAL); } if ((dt < 0.0 && h0 > 0.0) || (dt > 0.0 && h0 < 0.0)) { GSL_ERROR ("step direction must match interval direction", GSL_EINVAL); } /* Save y in case of failure in a step */ DBL_MEMCPY (e->y0, y, e->dimension); /* Calculate initial dydt once or reuse previous value if the method can benefit. */ if (step->type->can_use_dydt_in) { if (e->count == 0) { int status = GSL_ODEIV_FN_EVAL (dydt, t0, y, e->dydt_in); if (status) { return status; } } else { DBL_MEMCPY (e->dydt_in, e->dydt_out, e->dimension); } } try_step: if ((dt >= 0.0 && h0 > dt) || (dt < 0.0 && h0 < dt)) { h0 = dt; final_step = 1; } else { final_step = 0; } if (step->type->can_use_dydt_in) { step_status = gsl_odeiv2_step_apply (step, t0, h0, y, e->yerr, e->dydt_in, e->dydt_out, dydt); } else { step_status = gsl_odeiv2_step_apply (step, t0, h0, y, e->yerr, NULL, e->dydt_out, dydt); } /* Return if stepper indicates a pointer or user function failure */ if (step_status == GSL_EFAULT || step_status == GSL_EBADFUNC) { return step_status; } /* Check for stepper internal failure */ if (step_status != GSL_SUCCESS) { /* Stepper was unable to calculate step. Try decreasing step size. */ double h_old = h0; h0 *= 0.5; #ifdef DEBUG printf ("-- gsl_odeiv2_evolve_apply h0=%.5e\n", h0); #endif /* Check that an actual decrease in h0 occured and the suggested h0 will change the time by at least 1 ulp */ { double t_curr = GSL_COERCE_DBL (*t); double t_next = GSL_COERCE_DBL ((*t) + h0); if (fabs (h0) < fabs (h_old) && t_next != t_curr) { /* Step was decreased. Undo step, and try again with new h0. */ DBL_MEMCPY (y, e->y0, dydt->dimension); e->failed_steps++; goto try_step; } else { #ifdef DEBUG printf ("-- gsl_odeiv2_evolve_apply h0=%.5e, t0=%.5e, step_status=%d\n", h0, t0, step_status); #endif *h = h0; /* notify user of step-size which caused the failure */ *t = t0; /* restore original t value */ return step_status; } } } e->count++; e->last_step = h0; if (final_step) { *t = t1; } else { *t = t0 + h0; } if (con != NULL) { /* Check error and attempt to adjust the step. */ double h_old = h0; const int hadjust_status = gsl_odeiv2_control_hadjust (con, step, y, e->yerr, e->dydt_out, &h0); if (hadjust_status == GSL_ODEIV_HADJ_DEC) { /* Check that the reported status is correct (i.e. an actual decrease in h0 occured) and the suggested h0 will change the time by at least 1 ulp */ double t_curr = GSL_COERCE_DBL (*t); double t_next = GSL_COERCE_DBL ((*t) + h0); if (fabs (h0) < fabs (h_old) && t_next != t_curr) { /* Step was decreased. Undo step, and try again with new h0. */ DBL_MEMCPY (y, e->y0, dydt->dimension); e->failed_steps++; goto try_step; } else { /* Can not obtain required error tolerance, and can not decrease step-size any further, so give up and return GSL_FAILURE. */ *h = h0; /* notify user of step-size which caused the failure */ return GSL_FAILURE; } } } /* Suggest step size for next time-step. Change of step size is not suggested in the final step, because that step can be very small compared to previous step, to reach t1. */ if (final_step == 0) { *h = h0; } return step_status; }