/* R_mpc - Create an MPC S3 object for arbitrary precision complex numbers. * * We currently use external pointers for performance reasons, which * means that we can't allocVector a list of length(n) MPC objects, * and instead must instantiate them one at a time, that a caller can * put into a list if they want, but not a vector. * * Args: * n - An integer, numeric, or complex number to convert to an MPC. * sprec - The number of bits of precision to use, e.g. 52 for doubles. */ SEXP R_mpc(SEXP n, SEXP sprec) { /* TODO: INTEGER returns 32bit integer but mpfr_prec_t may be * 64bit. This is based on how mpfr was compiled. Therefore we * could add this as a configure check? */ mpfr_prec_t prec = INTEGER(sprec)[0]; mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t)); if (z == NULL) { Rf_error("Could not allocate memory for MPC type."); } mpc_init2(*z, prec); if (Rf_isInteger(n)) { mpc_set_d(*z, INTEGER(n)[0], Rmpc_get_rounding()); } else if (Rf_isNumeric(n)) { mpc_set_d(*z, REAL(n)[0], Rmpc_get_rounding()); } else if (Rf_isComplex(n)) { mpc_set_d_d(*z, COMPLEX(n)[0].r, COMPLEX(n)[0].i, Rmpc_get_rounding()); } else if (Rf_isString(n)) { mpc_set_str(*z, CHAR(STRING_ELT(n, 0)), 10, Rmpc_get_rounding()); } else { Rf_error("Unsupported type conversion to MPC."); } return(MakeMPC(z)); }
static MPC_Object * GMPy_MPC_From_PyFloat(PyObject *obj, mpfr_prec_t rprec, mpfr_prec_t iprec, CTXT_Object *context) { MPC_Object *result; CHECK_CONTEXT(context); assert(PyFloat_Check(obj)); if (rprec == 0) rprec = GET_REAL_PREC(context); else if (rprec == 1) rprec = DBL_MANT_DIG; if (iprec == 0) iprec = GET_IMAG_PREC(context); else if (iprec == 1) rprec = DBL_MANT_DIG; if ((result = GMPy_MPC_New(rprec, iprec, context))) { result->rc = mpc_set_d(result->c, PyFloat_AS_DOUBLE(obj), GET_MPC_ROUND(context)); if (rprec != 1) { GMPY_MPC_CHECK_RANGE(result, context); } GMPY_MPC_SUBNORMALIZE(result, context); GMPY_MPC_EXCEPTIONS(result, context); } return result; }
END_TEST START_TEST (determinant_mhessenberg_example1) { /* Custom 8 by 8 example. The matrix is defined as: * A(i,j) = sin(i) * cos(j) + 1e-3 * i*j . * Its determinant should be*/ mpc_t *hessenberg_matrix = mps_newv (mpc_t, 64); mpc_t det, t; rdpe_t diff, mod, error; int i, j; mpc_vinit2 (hessenberg_matrix, 64, DBL_MANT_DIG); mpc_init2 (det, DBL_MANT_DIG); mpc_init2 (t, DBL_MANT_DIG); mps_context *ctx = mps_context_new (); for (i = 0; i < 8; i++) for (j = MAX (0, i - 1); j < 8; j++) { mpc_set_d (hessenberg_matrix[i * 8 + j], sin (1.0 * (i + 1)) * cos (1.0 * (j + 1)) + 1e-3 * (i + 1) * (j + 1), 0.0); } mps_mhessenberg_determinant (ctx, hessenberg_matrix, 8, det, error); mpc_vclear (hessenberg_matrix, 64); free (hessenberg_matrix); mpc_set_d (t, 6.14427105181099e-06, 0.0); mpc_sub_eq (det, t); mpc_rmod (diff, det); mpc_rmod (mod, t); fail_unless (rdpe_get_d (diff) < rdpe_get_d (mod) * 10.0 * 8 * DBL_EPSILON || rdpe_lt (diff, error), "The error on determinant_hessenberg_example1 is bigger than n * DBL_EPSILON"); mps_context_free (ctx); }
int mpc_pow_d (mpc_ptr z, mpc_srcptr x, double y, mpc_rnd_t rnd) { mpc_t yy; int inex; MPC_ASSERT(FLT_RADIX == 2); mpc_init3 (yy, DBL_MANT_DIG, MPFR_PREC_MIN); mpc_set_d (yy, y, MPC_RNDNN); /* exact */ inex = mpc_pow (z, x, yy, rnd); mpc_clear (yy); return inex; }
END_TEST START_TEST (determinant_shifted_mhessenberg_example1) { /* Custom 8 by 8 example. The matrix is defined as: * A(i,j) = sin(i) * cos(j) + 1e-3 * i*j . * Its determinant should be*/ mpc_t *hessenberg_matrix = mps_newv (mpc_t, 64); mpc_t det, t; int i, j; mpc_t shifts[3]; mpc_t results[3]; mpc_vinit2 (hessenberg_matrix, 64, DBL_MANT_DIG); mpc_init2 (det, DBL_MANT_DIG); mpc_init2 (t, DBL_MANT_DIG); mpc_vinit2 (shifts, 3, DBL_MANT_DIG); mpc_vinit2 (results, 3, DBL_MANT_DIG); mpc_set_d (shifts[0], 0.403815598068559, 0.754480932782281); mpc_set_d (results[0], -0.2755152414594506, 0.0732925950505913); mpc_set_d (shifts[1], 0.0590780603923638, 0.9236523504901163); mpc_set_d (results[1], 0.5885575152394473, -0.0800261442305445); mpc_set_d (shifts[2], 0.0534877455734864, 0.1853972552409148); mpc_set_d (results[2], -4.28682106680713e-05, -4.18995301563591e-05); mps_context *ctx = mps_context_new (); for (i = 0; i < 8; i++) for (j = MAX (0, i - 1); j < 8; j++) { mpc_set_d (hessenberg_matrix[i * 8 + j], sin (1.0 * (i + 1)) * cos (1.0 * (j + 1)) + 1e-3 * (i + 1) * (j + 1), 0.0); } for (i = 0; i < 2; i++) { rdpe_t diff, mod, error; mps_mhessenberg_shifted_determinant (ctx, hessenberg_matrix, shifts[i], 8, det, error); mpc_sub_eq (det, results[i]); mpc_rmod (diff, det); mpc_rmod (mod, results[i]); printf ("%d: ", i); mpc_out_str_2 (stdout, 10, 15, 15, det); printf ("\n"); fail_unless (rdpe_get_d (diff) < rdpe_get_d (mod) * 10.0 * 8 * DBL_EPSILON || rdpe_lt (diff, error), "The error on shifted Hessenberg determinant example1 is bigger than n * DBL_EPSILON"); } mpc_vclear (shifts, 3); mpc_vclear (results, 3); mpc_vclear (hessenberg_matrix, 64); mpc_clear (t); mpc_clear (det); free (hessenberg_matrix); mps_context_free (ctx); }
void Lib_Mpcr_Set_D(MpcrPtr x, double d, long rnd) { mpc_set_d( (mpc_ptr) x, d, (mpc_rnd_t) rnd); }
static void check_set (void) { long int lo; mpz_t mpz; mpq_t mpq; mpf_t mpf; mpfr_t fr; mpc_t x, z; mpfr_prec_t prec; mpz_init (mpz); mpq_init (mpq); mpf_init2 (mpf, 1000); mpfr_init2 (fr, 1000); mpc_init2 (x, 1000); mpc_init2 (z, 1000); mpz_set_ui (mpz, 0x4217); mpq_set_si (mpq, -1, 0x4321); mpf_set_q (mpf, mpq); for (prec = 2; prec <= 1000; prec++) { unsigned long int u = (unsigned long int) prec; mpc_set_prec (z, prec); mpfr_set_prec (fr, prec); lo = -prec; mpfr_set_d (fr, 1.23456789, GMP_RNDN); mpc_set_d (z, 1.23456789, MPC_RNDNN); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_si (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_d", prec, z); #if defined _MPC_H_HAVE_COMPLEX mpc_set_dc (z, I*1.23456789+1.23456789, MPC_RNDNN); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0) PRINT_ERROR ("mpc_set_c", prec, z); #endif mpc_set_ui (z, u, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_ui", prec, z); mpc_set_d_d (z, 1.23456789, 1.23456789, MPC_RNDNN); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0) PRINT_ERROR ("mpc_set_d_d", prec, z); mpc_set_si (z, lo, MPC_RNDNN); if (mpfr_cmp_si (MPC_RE(z), lo) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_si", prec, z); mpfr_set_ld (fr, 1.23456789L, GMP_RNDN); mpc_set_ld_ld (z, 1.23456789L, 1.23456789L, MPC_RNDNN); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0) PRINT_ERROR ("mpc_set_ld_ld", prec, z); #if defined _MPC_H_HAVE_COMPLEX mpc_set_ldc (z, I*1.23456789L+1.23456789L, MPC_RNDNN); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0) PRINT_ERROR ("mpc_set_lc", prec, z); #endif mpc_set_ui_ui (z, u, u, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), u) != 0) PRINT_ERROR ("mpc_set_ui_ui", prec, z); mpc_set_ld (z, 1.23456789L, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_ld", prec, z); mpc_set_prec (x, prec); mpfr_set_ui(fr, 1, GMP_RNDN); mpfr_div_ui(fr, fr, 3, GMP_RNDN); mpfr_set(MPC_RE(x), fr, GMP_RNDN); mpfr_set(MPC_IM(x), fr, GMP_RNDN); mpc_set (z, x, MPC_RNDNN); mpfr_clear_flags (); /* mpc_cmp set erange flag when an operand is a NaN */ if (mpc_cmp (z, x) != 0 || mpfr_erangeflag_p()) { printf ("Error in mpc_set for prec = %lu\n", (unsigned long int) prec); MPC_OUT(z); MPC_OUT(x); exit (1); } mpc_set_si_si (z, lo, lo, MPC_RNDNN); if (mpfr_cmp_si (MPC_RE(z), lo) != 0 || mpfr_cmp_si (MPC_IM(z), lo) != 0) PRINT_ERROR ("mpc_set_si_si", prec, z); mpc_set_fr (z, fr, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_fr", prec, z); mpfr_set_z (fr, mpz, GMP_RNDN); mpc_set_z_z (z, mpz, mpz, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_z_z", prec, z); mpc_set_fr_fr (z, fr, fr, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_fr_fr", prec, z); mpc_set_z (z, mpz, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_z", prec, z); mpfr_set_q (fr, mpq, GMP_RNDN); mpc_set_q_q (z, mpq, mpq, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_q_q", prec, z); mpc_set_ui_fr (z, u, fr, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp_ui (MPC_RE (z), u) != 0 || mpfr_cmp (MPC_IM (z), fr) != 0 || mpfr_erangeflag_p ()) PRINT_ERROR ("mpc_set_ui_fr", prec, z); mpc_set_fr_ui (z, fr, u, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE (z), fr) != 0 || mpfr_cmp_ui (MPC_IM (z), u) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_fr_ui", prec, z); mpc_set_q (z, mpq, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_q", prec, z); mpfr_set_f (fr, mpf, GMP_RNDN); mpc_set_f_f (z, mpf, mpf, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp (MPC_IM(z), fr) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_f_f", prec, z); mpc_set_f (z, mpf, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE(z), fr) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0 || mpfr_erangeflag_p()) PRINT_ERROR ("mpc_set_f", prec, z); mpc_set_f_si (z, mpf, lo, MPC_RNDNN); mpfr_clear_flags (); if (mpfr_cmp (MPC_RE (z), fr) != 0 || mpfr_cmp_si (MPC_IM (z), lo) != 0 || mpfr_erangeflag_p ()) PRINT_ERROR ("mpc_set_f", prec, z); mpc_set_nan (z); if (!mpfr_nan_p (MPC_RE(z)) || !mpfr_nan_p (MPC_IM(z))) PRINT_ERROR ("mpc_set_nan", prec, z); #ifdef _MPC_H_HAVE_INTMAX_T { uintmax_t uim = (uintmax_t) prec; intmax_t im = (intmax_t) prec; mpc_set_uj (z, uim, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_uj", prec, z); mpc_set_sj (z, im, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_sj (1)", prec, z); mpc_set_uj_uj (z, uim, uim, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), u) != 0) PRINT_ERROR ("mpc_set_uj_uj", prec, z); mpc_set_sj_sj (z, im, im, MPC_RNDNN); if (mpfr_cmp_ui (MPC_RE(z), u) != 0 || mpfr_cmp_ui (MPC_IM(z), u) != 0) PRINT_ERROR ("mpc_set_sj_sj (1)", prec, z); im = LONG_MAX; if (sizeof (intmax_t) == 2 * sizeof (unsigned long)) im = 2 * im * im + 4 * im + 1; /* gives 2^(2n-1)-1 from 2^(n-1)-1 */ mpc_set_sj (z, im, MPC_RNDNN); if (mpfr_get_sj (MPC_RE(z), GMP_RNDN) != im || mpfr_cmp_ui (MPC_IM(z), 0) != 0) PRINT_ERROR ("mpc_set_sj (2)", im, z); mpc_set_sj_sj (z, im, im, MPC_RNDNN); if (mpfr_get_sj (MPC_RE(z), GMP_RNDN) != im || mpfr_get_sj (MPC_IM(z), GMP_RNDN) != im) PRINT_ERROR ("mpc_set_sj_sj (2)", im, z); } #endif /* _MPC_H_HAVE_INTMAX_T */ #if defined _MPC_H_HAVE_COMPLEX { double _Complex c = 1.0 - 2.0*I; long double _Complex lc = c; mpc_set_dc (z, c, MPC_RNDNN); if (mpc_get_dc (z, MPC_RNDNN) != c) PRINT_ERROR ("mpc_get_c", prec, z); mpc_set_ldc (z, lc, MPC_RNDNN); if (mpc_get_ldc (z, MPC_RNDNN) != lc) PRINT_ERROR ("mpc_get_lc", prec, z); } #endif } mpz_clear (mpz); mpq_clear (mpq); mpf_clear (mpf); mpfr_clear (fr); mpc_clear (x); mpc_clear (z); }