float evaluateFitness(float position[]) { char stringFitness[28]; mpf_t mpfFitness, one; float ris; float fitness = formulae(position); if (fitness >= 0) { sprintf(stringFitness, "%.20f", fitness); mpf_init(mpfFitness); mpf_init(one); mpf_set_str (one, "1.0", 10); mpf_set_str(mpfFitness, stringFitness, 10); mpf_add(mpfFitness, mpfFitness, one); //printf("fitness: %.20e\t", fitness); //mpf_out_str (stdout, 10, 256, mpfFitness); mpf_div(mpfFitness, one, mpfFitness); printf("\nris %.20e\t", (float) mpf_get_d(mpfFitness)); ris = (float) mpf_get_d(mpfFitness); mpf_out_str (stdout, 10, 256, mpfFitness); printf("\n"); return ris; //return 1 / (1 + fitness); } return 1 + fabs(fitness); }
//------------------------------------------------------------------------------ // Name: //------------------------------------------------------------------------------ knumber_base *knumber_float::pow(knumber_base *rhs) { if(knumber_integer *const p = dynamic_cast<knumber_integer *>(rhs)) { mpf_pow_ui(mpf_, mpf_, mpz_get_ui(p->mpz_)); if(p->sign() < 0) { return reciprocal(); } else { return this; } } else if(knumber_float *const p = dynamic_cast<knumber_float *>(rhs)) { return execute_libc_func< ::pow>(mpf_get_d(mpf_), mpf_get_d(p->mpf_)); } else if(knumber_fraction *const p = dynamic_cast<knumber_fraction *>(rhs)) { knumber_float f(p); return execute_libc_func< ::pow>(mpf_get_d(mpf_), mpf_get_d(f.mpf_)); } else if(knumber_error *const p = dynamic_cast<knumber_error *>(rhs)) { if(p->sign() > 0) { knumber_error *e = new knumber_error(knumber_error::ERROR_POS_INFINITY); delete this; return e; } else if(p->sign() < 0) { knumber_integer *n = new knumber_integer(0); delete this; return n; } else { knumber_error *e = new knumber_error(knumber_error::ERROR_UNDEFINED); delete this; return e; } } Q_ASSERT(0); return 0; }
// r = sqrt(x) void my_sqrt(mpf_t r, mpf_t x) { unsigned prec, bits, prec0; prec0 = mpf_get_prec(r); if (prec0 <= DOUBLE_PREC) { mpf_set_d(r, sqrt(mpf_get_d(x))); return; } bits = 0; for (prec = prec0; prec > DOUBLE_PREC;) { int bit = prec & 1; prec = (prec + bit) / 2; bits = bits * 2 + bit; } mpf_set_prec_raw(t1, DOUBLE_PREC); mpf_set_d(t1, 1 / sqrt(mpf_get_d(x))); while (prec < prec0) { prec *= 2; /*printf("prec=%d, prec0=%d\n", prec, prec0); */ if (prec < prec0) { /* t1 = t1+t1*(1-x*t1*t1)/2; */ mpf_set_prec_raw(t2, prec); mpf_mul(t2, t1, t1); mpf_set_prec_raw(x, prec/2); mpf_mul(t2, t2, x); mpf_ui_sub(t2, 1, t2); mpf_set_prec_raw(t2, prec/2); mpf_div_2exp(t2, t2, 1); mpf_mul(t2, t2, t1); mpf_set_prec_raw(t1, prec); mpf_add(t1, t1, t2); } else { prec = prec0; /* t2=x*t1, t1 = t2+t1*(x-t2*t2)/2; */ mpf_set_prec_raw(t2, prec/2); mpf_set_prec_raw(x, prec/2); mpf_mul(t2, t1, x); mpf_mul(r, t2, t2); mpf_set_prec_raw(x, prec); mpf_sub(r, x, r); mpf_mul(t1, t1, r); mpf_div_2exp(t1, t1, 1); mpf_add(r, t1, t2); break; } prec -= (bits & 1); bits /= 2; } }
static void print_ks_results (mpf_t f_p, mpf_t f_p_prob, mpf_t f_m, mpf_t f_m_prob, FILE *fp) { double p, pp, m, mp; p = mpf_get_d (f_p); m = mpf_get_d (f_m); pp = mpf_get_d (f_p_prob); mp = mpf_get_d (f_m_prob); fprintf (fp, "%.4f (%.0f%%)\t", p, pp * 100.0); fprintf (fp, "%.4f (%.0f%%)\n", m, mp * 100.0); }
// r = y/x WARNING: r cannot be the same as y. void my_div(mpf_t r, mpf_t y, mpf_t x) { unsigned long prec, bits, prec0; prec0 = mpf_get_prec(r); if (prec0<=DOUBLE_PREC) { mpf_set_d(r, mpf_get_d(y)/mpf_get_d(x)); return; } bits = 0; for (prec=prec0; prec>DOUBLE_PREC;) { int bit = prec&1; prec = (prec+bit)/2; bits = bits*2+bit; } mpf_set_prec_raw(t1, DOUBLE_PREC); mpf_ui_div(t1, 1, x); while (prec<prec0) { prec *=2; if (prec<prec0) { /* t1 = t1+t1*(1-x*t1); */ mpf_set_prec_raw(t2, prec); mpf_mul(t2, x, t1); // full x half -> full mpf_ui_sub(t2, 1, t2); mpf_set_prec_raw(t2, prec/2); mpf_mul(t2, t2, t1); // half x half -> half mpf_set_prec_raw(t1, prec); mpf_add(t1, t1, t2); } else { prec = prec0; /* t2=y*t1, t1 = t2+t1*(y-x*t2); */ mpf_set_prec_raw(t2, prec/2); mpf_mul(t2, t1, y); // half x half -> half mpf_mul(r, x, t2); // full x half -> full mpf_sub(r, y, r); mpf_mul(t1, t1, r); // half x half -> half mpf_add(r, t1, t2); break; } prec -= (bits&1); bits /=2; } }
void test_denorms (int prc) { #ifdef _GMP_IEEE_FLOATS double d1, d2; mpf_t f; int i; mpf_set_default_prec (prc); mpf_init (f); d1 = 1.9; for (i = 0; i < 820; i++) { mpf_set_d (f, d1); d2 = mpf_get_d (f); if (d1 != d2) abort (); d1 *= 0.4; } mpf_clear (f); #endif }
int main (int argc, char * argv[]) { mpf_t a_k; int prec, nbits; prec = 120; /* Set the precision (number of binary bits) */ /* We need more bits than what what is available, for intermediate calcs */ nbits = 3.3*prec; mpf_set_default_prec (nbits+200); mpf_init(a_k); printf("#\n# The topsin series a_k\n#\n"); int k; double akprev=0.0; for (k=0; k<95001; k++) { topsin_series(a_k, k, prec); double ak = mpf_get_d(a_k); printf("%d %20.16g %20.16g\n", k, ak, ak+akprev); akprev = ak; } return 0; }
double getDouble(Real real){ if (no_reals) return 0.0; #ifdef USE_MPFR return mpfr_get_d(real->mpfr_val, MPFR_RNDN); #else return mpf_get_d(real->mpf_val); #endif }
libmaus2::math::GmpFloat::operator double() const { #if defined(LIBMAUS2_HAVE_GMP) return mpf_get_d(decode(v)); #else return 0; #endif }
int main (int argc, char * argv[]) { mpf_t a_k; int prec, nbits; prec = 50; /* Set the precision (number of binary bits) */ /* We need more bits than what what is available, for intermediate calcs */ nbits = 3.3*prec; mpf_set_default_prec (nbits+200); mpf_init(a_k); // a_1 should be -2pi topsin_series(a_k, 1, prec); double twopi = mpf_get_d(a_k); twopi += 2.0*M_PI; if (fabs(twopi) > 1.0e-16) printf("Error at k=1: %g\n", twopi); // a_2 should be +2pi topsin_series(a_k, 2, prec); twopi = mpf_get_d(a_k); twopi -= 2.0*M_PI; if (fabs(twopi) > 1.0e-16) printf("Error at k=2: %g\n", twopi); // a_3 should be 2pi (3-2pi^2) / 3 = -35.05851693322 double x; bool fail = false; for (x=0.95; x>-0.95; x -= 0.018756) { bool result = sum_test(x, prec); fail = fail || result; printf("."); fflush(stdout); } printf("\n"); if (fail) printf("Error: test failed\n"); else printf("Success: test worked\n"); return 0; }
/* * Function: compute_bbp * -------------------- * Computes the generic BBP formula. * * d: digit to be calculated * base: the base * c: a fixed positive integer * p: a simple polynomial like x or x^2 * * returns: the value of the BBP formula */ long double compute_bbp(int digit, int base, int c, void (*p)(mpz_t, mpz_t), bool start_at_0) { int d = digit - 1; mpf_t mpf_first_sum; mpf_init(mpf_first_sum); compute_bbp_first_sum_gmp(mpf_first_sum, d, base, c, p, start_at_0); double first_sum = mpf_get_d(mpf_first_sum); mpf_clear(mpf_first_sum); mpf_t mpf_second_sum; mpf_init(mpf_second_sum); compute_bbp_second_sum_gmp(mpf_second_sum, d, base, c, p); double second_sum = mpf_get_d(mpf_second_sum); mpf_clear(mpf_second_sum); long double sum = mod_one(first_sum + second_sum); return sum; }
int sg_big_float_get_c_float(sg_big_float_t *src, void *float_ptr, enum sg_c_float_type type) { if (!src || !float_ptr) return -1; if (type != SGCFLOATTYPE_SFLOAT && type != SGCFLOATTYPE_SDOUBLE) return -1; double d = mpf_get_d(src->mpf); (type == SGCFLOATTYPE_SFLOAT) ? (*((float*) float_ptr) = (float) d) : (*((double*) float_ptr) = d); return 0; }
double merit_u (unsigned int t, mpf_t v, mpz_t m) { mpf_t rop; double res; mpf_init (rop); merit (rop, t, v, m); res = mpf_get_d (rop); mpf_clear (rop); return res; }
//------------------------------------------------------------------------------ // Name: //------------------------------------------------------------------------------ knumber_base *knumber_float::atanh() { #ifdef KNUMBER_USE_MPFR mpfr_t mpfr; mpfr_init_set_f(mpfr, mpf_, rounding_mode); mpfr_atanh(mpfr, mpfr, rounding_mode); mpfr_get_f(mpf_, mpfr, rounding_mode); mpfr_clear(mpfr); return this; #else const double x = mpf_get_d(mpf_); return execute_libc_func< ::atanh>(x); #endif }
void ks_table (mpf_t p, mpf_t val, const unsigned int n) { /* We use Eq. (27), Knuth p.58, skipping O(1/n) for simplicity. This shortcut will result in too high probabilities, especially when n is small. Pr(Kp(n) <= s) = 1 - pow(e, -2*s^2) * (1 - 2/3*s/sqrt(n) + O(1/n)) */ /* We have 's' in variable VAL and store the result in P. */ mpf_t t1, t2; mpf_init (t1); mpf_init (t2); /* t1 = 1 - 2/3 * s/sqrt(n) */ mpf_sqrt_ui (t1, n); mpf_div (t1, val, t1); mpf_mul_ui (t1, t1, 2); mpf_div_ui (t1, t1, 3); mpf_ui_sub (t1, 1, t1); /* t2 = pow(e, -2*s^2) */ #ifndef OLDGMP mpf_pow_ui (t2, val, 2); /* t2 = s^2 */ mpf_set_d (t2, exp (-(2.0 * mpf_get_d (t2)))); #else /* hmmm, gmp doesn't have pow() for floats. use doubles. */ mpf_set_d (t2, pow (M_E, -(2 * pow (mpf_get_d (val), 2)))); #endif /* p = 1 - t1 * t2 */ mpf_mul (t1, t1, t2); mpf_ui_sub (p, 1, t1); mpf_clear (t1); mpf_clear (t2); }
int sg_big_float_get_c_int(sg_big_float_t *src, void *int_ptr, enum sg_c_int_type type) { double d; if (!src || !int_ptr) return -1; d = mpf_get_d(src->mpf); switch (type) { case SGCINTTYPE_SCHAR: *(char*) int_ptr = (char) d; break; case SGCINTTYPE_SSHORT: *(short*) int_ptr = (short) d; break; case SGCINTTYPE_SINT: *(int*) int_ptr = (int) d; break; case SGCINTTYPE_SINT32: *(uint32_t*) int_ptr = (uint32_t) d; break; case SGCINTTYPE_SLONG: *(long*) int_ptr = (long) d; break; case SGCINTTYPE_SINT64: *(int64_t*) int_ptr = (int64_t) d; break; case SGCINTTYPE_UCHAR: *(unsigned char*) int_ptr = (unsigned char) d; break; case SGCINTTYPE_USHORT: *(unsigned short*) int_ptr = (unsigned short) d; break; case SGCINTTYPE_UINT: *(unsigned int*) int_ptr = (unsigned int) d; break; case SGCINTTYPE_UINT32: *(uint32_t*) int_ptr = (uint32_t) d; break; case SGCINTTYPE_ULONG: *(unsigned long*) int_ptr = (unsigned long) d; break; case SGCINTTYPE_UINT64: *(uint64_t*) int_ptr = (uint64_t) d; break; } return 0; }
static void Pks (mpf_t p, mpf_t x) { double dt; /* temp double */ mpf_set (p, x); mpf_mul (p, p, p); /* p = x^2 */ mpf_mul_ui (p, p, 2); /* p = 2*x^2 */ mpf_neg (p, p); /* p = -2*x^2 */ /* No pow() in gmp. Use doubles. */ /* FIXME: Use exp()? */ dt = pow (M_E, mpf_get_d (p)); mpf_set_d (p, dt); mpf_ui_sub (p, 1, p); }
unsigned char matrix_sub_d_d_mpf(double***** omatrix, unsigned long long* omsize, double**** imatrix, unsigned long long* imsize, double t) { unsigned long long n,m,p; unsigned char flag; mpf_t z1,tmp1,tmp2; unsigned char prec=21; if (imsize[1]==2) { mpf_init2(z1,prec); mpf_set_d(z1,t); omsize[1]=imsize[1]-1; } else { printf("ERROR: No free variables to use for substitution\n"); return 3; } omsize[0]=imsize[0]; flag = matrix_alloc_d(omatrix,omsize,1); //allocate each row to previous row allocation if (flag!=0) { mpf_clear(z1); return flag; } mpf_init2(tmp1,prec); mpf_init2(tmp2,prec); for (n=0ULL;n<omsize[0];n++) { for (m=0ULL;m<omsize[0];m++) { (*omatrix)[n][m][0][0]=1; for (p=0;p<imatrix[n][m][0][0];p++) { mpf_pow_ui(tmp1,z1,(unsigned long int)imatrix[n][m][1][imsize[1]*p]); mpf_set_d(tmp2,imatrix[n][m][1][imsize[1]*p+1]); mpf_mul(tmp1,tmp1,tmp2); (*omatrix)[n][m][1][0] = (*omatrix)[n][m][1][0] + mpf_get_d(tmp1); } } } mpf_clears(z1,tmp1,tmp2,NULL); return 0; }
/** * Convert a Ruby function value into a long double * * Parameters:: * * *iValBD* (_Rational_): The value to convert * Return:: * * <em>long double</em>: The equivalent long double */ inline long double value2ld( VALUE iValBD) { long double rResult; mpf_t lDenominator; mpf_init_set_str(lDenominator, RSTRING_PTR(rb_funcall(rb_funcall(iValBD, gID_denominator, 0), gID_to_s, 0)), 10); mpf_t lDivResult; mpf_init_set_str(lDivResult, RSTRING_PTR(rb_funcall(rb_funcall(iValBD, gID_numerator, 0), gID_to_s, 0)), 10); mpf_div(lDivResult, lDivResult, lDenominator); // TODO: Find a way to round correctly lDivResult. It is currently truncated. rResult = mpf_get_d(lDivResult); mpf_clear(lDivResult); mpf_clear(lDenominator); return rResult; }
/** * rasqal_xsd_decimal_get_double: * @dec: XSD Decimal * * Get an XSD Decimal as a double (may lose precision) * * Return value: double value. **/ double rasqal_xsd_decimal_get_double(rasqal_xsd_decimal* dec) { double result=0e0; #if defined(RASQAL_DECIMAL_C99) || defined(RASQAL_DECIMAL_NONE) result=(double)dec->raw; #endif #ifdef RASQAL_DECIMAL_MPFR result = mpfr_get_d(dec->raw, dec->rounding); #endif #ifdef RASQAL_DECIMAL_GMP result=mpf_get_d(dec->raw); #endif return result; }
//------------------------------------------------------------------------------ // Name: //------------------------------------------------------------------------------ knumber_base *knumber_float::exp() { #ifdef KNUMBER_USE_MPFR mpfr_t mpfr; mpfr_init_set_f(mpfr, mpf_, rounding_mode); mpfr_exp(mpfr, mpfr, rounding_mode); mpfr_get_f(mpf_, mpfr, rounding_mode); mpfr_clear(mpfr); return this; #else const double x = mpf_get_d(mpf_); if(isinf(x)) { delete this; return new knumber_error(knumber_error::ERROR_POS_INFINITY); } else { return execute_libc_func< ::exp>(x); } #endif }
double poly_eval_mult_using_mpf(double x, size_t nterms, double* coef) { if (nterms==0 || coef==NULL) return 1.0; size_t ntemp = NTEMP(poly_eval_mult_using_mpf); mpf_t *temp = mpf_array_alloc(ntemp); mpf_array_init(temp,ntemp); mpf_t *px = GET_NEXT_TEMP(temp); mpf_t *tmp = GET_NEXT_TEMP(temp); mpf_set_d(*px,1.0); for (size_t i=0; i<nterms; i++) { mpf_set_d(*tmp,x+coef[i]); mpf_mul(*px,*px,*tmp); } double pval = mpf_get_d(*px); mpf_array_clear(temp,ntemp); free(temp); return pval; }
double vanilla::float_object_to_double(object::ptr const& obj) { if(obj->type_id() != OBJECT_ID_FLOAT) { BOOST_THROW_EXCEPTION(error::bad_cast_error() << error::first_operand(obj) << error::cast_target_name("float")); } mpf_t& mpf = static_cast<float_object const*>(obj.get())->value().mpf(); double result = mpf_get_d(mpf); if(std::numeric_limits<double>::has_infinity && result == std::numeric_limits<double>::infinity()) { BOOST_THROW_EXCEPTION(error::float_conversion_overflow_error() << error::first_operand(obj) << error::float_conversion_target_type("double")); } return result; }
R gaunt(Int lp, Int l1, Int l2, Int mp, Int m1, Int m2) { R gg; mpf_t g,h; if((lp+l1+l2)%Int(2)==Int(1)) return R(0); if(NewGaunt::iabs(mp)>lp || NewGaunt::iabs(m1)>l1 || NewGaunt::iabs(m2)>l2) return R(0); mpf_init(g); mpf_init(h); NewGaunt::w3j(g,lp,l1,l2,0,0,0); NewGaunt::w3j(h,lp,l1,l2,-mp,m1,m2); mpf_mul(g,g,h); mpf_set_si(h,(2*lp+1)*(2*l1+1)*(2*l2+1)); mpf_sqrt(h,h); mpf_mul(g,g,h); gg=mpf_get_d(g)/sqrt(4.0*M_PI); if(NewGaunt::iabs(mp)%Int(2)==Int(1)) gg=-gg; mpf_clear(g); mpf_clear(h); return gg; }
int main (int argc, char **argv) { double d, e, r; mpf_t u, v; tests_start (); mpf_init (u); mpf_init (v); mpf_set_d (u, LOW_BOUND); for (d = 2.0 * LOW_BOUND; d < HIGH_BOUND; d *= 1.01) { mpf_set_d (v, d); if (mpf_cmp (u, v) >= 0) abort (); e = mpf_get_d (v); r = e/d; if (r < 0.99999999999999 || r > 1.00000000000001) { fprintf (stderr, "should be one ulp from 1: %.16f\n", r); abort (); } mpf_set (u, v); } mpf_clear (u); mpf_clear (v); test_denorms (10); test_denorms (32); test_denorms (64); test_denorms (100); test_denorms (200); tests_end (); exit (0); }
/* z_freq(l1runs, l2runs, zvec, n, max) -- frequency test on integers 0<=z<=MAX */ static void z_freq (const unsigned l1runs, const unsigned l2runs, mpz_t zvec[], const unsigned long n, unsigned int max) { mpf_t V; /* result */ double d_V; /* result as a double */ mpf_init (V); printf ("\nEquidistribution/Frequency test on integers (0<=X<=%u):\n", max); print_x2_table (max, stdout); mpz_freqt (V, zvec, max, n); d_V = mpf_get_d (V); printf ("V = %.2f (n = %lu)\n", d_V, n); mpf_clear (V); }
//------------------------------------------------------------------------------ // Name: //------------------------------------------------------------------------------ knumber_base *knumber_float::cbrt() { #ifdef KNUMBER_USE_MPFR mpfr_t mpfr; mpfr_init_set_f(mpfr, mpf_, rounding_mode); mpfr_cbrt(mpfr, mpfr, rounding_mode); mpfr_get_f(mpf_, mpfr, rounding_mode); mpfr_clear(mpfr); #else const double x = mpf_get_d(mpf_); if(isinf(x)) { delete this; return new knumber_error(knumber_error::ERROR_POS_INFINITY); } else { #ifdef Q_CC_MSVC return execute_libc_func< ::pow>(x, 1.0 / 3.0); #else return execute_libc_func< ::cbrt>(x); #endif } #endif return this; }
/* * Function: compute_bbp_second_sum_gmp * -------------------- * Computes the second summand in the BBP formula. * * d: digit to be calculated * base: the base * c: a fixed positive integer * p: a simple polynomial like x or x^2 * * returns: the value of the second sum */ void compute_bbp_second_sum_gmp(mpf_t sum, int d, int base, int c, void (*p)(mpz_t, mpz_t)) { mpf_set_d(sum, 0.0); mpz_t k; mpz_init_set_si(k, floor((double) d / (double) c) + 1); mpf_t prev_sum; mpf_init(prev_sum); mpf_set(prev_sum, sum); mpf_t base_gmp; mpf_init(base_gmp); mpf_set_si(base_gmp, base); double d_diff = 0.0; do { mpf_set(prev_sum, sum); mpz_t poly_result; mpz_init(poly_result); (*p)(poly_result, k); mpf_t num; mpf_init(num); mpz_t exponent; mpz_init_set(exponent, k); mpz_mul_si(exponent, exponent, c); mpz_mul_si(exponent, exponent, -1); mpz_add_ui(exponent, exponent, d); signed long int exp = mpz_get_si(exponent); unsigned long int neg_exp = -1 * exp; mpf_pow_ui(num, base_gmp, neg_exp); mpf_ui_div(num, 1, num); mpz_clear(exponent); mpf_t denom; mpf_init_set_d(denom, mpz_get_d(poly_result)); mpz_clear(poly_result); mpf_t quotient; mpf_init(quotient); mpf_div(quotient, num, denom); mpf_clear(num); mpf_clear(denom); mpf_add(sum, sum, quotient); mpf_clear(quotient); mpz_add_ui(k, k, 1); mpf_t diff; mpf_init(diff); mpf_sub(diff, prev_sum, sum); d_diff = mpf_get_d(diff); d_diff = fabs(d_diff); mpf_clear(diff); } while (d_diff > 0.00000001); mpz_clear(k); mpf_clear(base_gmp); mpf_clear(prev_sum); }
int cl1mp (int k, int l, int m, int n, int nklmd, int n2d, LDBLE * q_arg, int *kode_arg, LDBLE toler_arg, int *iter, LDBLE * x_arg, LDBLE * res_arg, LDBLE * error_arg, LDBLE * cu_arg, int *iu, int *s, int check, LDBLE censor_arg) { /* System generated locals */ union double_or_int { int ival; mpf_t dval; } *q2; /* Local variables */ static int nklm; static int iout, i, j; static int maxit, n1, n2; static int ia, ii, kk, in, nk, js; static int iphase, kforce; static int klm, jmn, nkl, jpn; static int klm1; static int *kode; int q_dim, cu_dim; int iswitch; mpf_t *q; mpf_t *x; mpf_t *res; mpf_t error; mpf_t *cu; mpf_t dummy, dummy1, sum, z, zu, zv, xmax, minus_one, toler, check_toler; /*mpf_t *scratch; */ mpf_t pivot, xmin, cuv, tpivot, sn; mpf_t zero; int censor; mpf_t censor_tol; /* THIS SUBROUTINE USES A MODIFICATION OF THE SIMPLEX */ /* METHOD OF LINEAR PROGRAMMING TO CALCULATE AN L1 SOLUTION */ /* TO A K BY N SYSTEM OF LINEAR EQUATIONS */ /* AX=B */ /* SUBJECT TO L LINEAR EQUALITY CONSTRAINTS */ /* CX=D */ /* AND M LINEAR INEQUALITY CONSTRAINTS */ /* EX.LE.F. */ /* DESCRIPTION OF PARAMETERS */ /* K NUMBER OF ROWS OF THE MATRIX A (K.GE.1). */ /* L NUMBER OF ROWS OF THE MATRIX C (L.GE.0). */ /* M NUMBER OF ROWS OF THE MATRIX E (M.GE.0). */ /* N NUMBER OF COLUMNS OF THE MATRICES A,C,E (N.GE.1). */ /* KLMD SET TO AT LEAST K+L+M FOR ADJUSTABLE DIMENSIONS. */ /* KLM2D SET TO AT LEAST K+L+M+2 FOR ADJUSTABLE DIMENSIONS. */ /* NKLMD SET TO AT LEAST N+K+L+M FOR ADJUSTABLE DIMENSIONS. */ /* N2D SET TO AT LEAST N+2 FOR ADJUSTABLE DIMENSIONS */ /* Q TWO DIMENSIONAL REAL ARRAY WITH KLM2D ROWS AND */ /* AT LEAST N2D COLUMNS. */ /* ON ENTRY THE MATRICES A,C AND E, AND THE VECTORS */ /* B,D AND F MUST BE STORED IN THE FIRST K+L+M ROWS */ /* AND N+1 COLUMNS OF Q AS FOLLOWS */ /* A B */ /* Q = C D */ /* E F */ /* THESE VALUES ARE DESTROYED BY THE SUBROUTINE. */ /* KODE A CODE USED ON ENTRY TO, AND EXIT */ /* FROM, THE SUBROUTINE. */ /* ON ENTRY, THIS SHOULD NORMALLY BE SET TO 0. */ /* HOWEVER, IF CERTAIN NONNEGATIVITY CONSTRAINTS */ /* ARE TO BE INCLUDED IMPLICITLY, RATHER THAN */ /* EXPLICITLY IN THE CONSTRAINTS EX.LE.F, THEN KODE */ /* SHOULD BE SET TO 1, AND THE NONNEGATIVITY */ /* CONSTRAINTS INCLUDED IN THE ARRAYS X AND */ /* RES (SEE BELOW). */ /* ON EXIT, KODE HAS ONE OF THE */ /* FOLLOWING VALUES */ /* 0- OPTIMAL SOLUTION FOUND, */ /* 1- NO FEASIBLE SOLUTION TO THE */ /* CONSTRAINTS, */ /* 2- CALCULATIONS TERMINATED */ /* PREMATURELY DUE TO ROUNDING ERRORS, */ /* 3- MAXIMUM NUMBER OF ITERATIONS REACHED. */ /* TOLER A SMALL POSITIVE TOLERANCE. EMPIRICAL */ /* EVIDENCE SUGGESTS TOLER = 10**(-D*2/3), */ /* WHERE D REPRESENTS THE NUMBER OF DECIMAL */ /* DIGITS OF ACCURACY AVAILABLE. ESSENTIALLY, */ /* THE SUBROUTINE CANNOT DISTINGUISH BETWEEN ZERO */ /* AND ANY QUANTITY WHOSE MAGNITUDE DOES NOT EXCEED */ /* TOLER. IN PARTICULAR, IT WILL NOT PIVOT ON ANY */ /* NUMBER WHOSE MAGNITUDE DOES NOT EXCEED TOLER. */ /* ITER ON ENTRY ITER MUST CONTAIN AN UPPER BOUND ON */ /* THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. */ /* A SUGGESTED VALUE IS 10*(K+L+M). ON EXIT ITER */ /* GIVES THE NUMBER OF SIMPLEX ITERATIONS. */ /* X ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST N2D. */ /* ON EXIT THIS ARRAY CONTAINS A */ /* SOLUTION TO THE L1 PROBLEM. IF KODE=1 */ /* ON ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE */ /* SIMPLE NONNEGATIVITY CONSTRAINTS ON THE */ /* VARIABLES. THE VALUES -1, 0, OR 1 */ /* FOR X(J) INDICATE THAT THE J-TH VARIABLE */ /* IS RESTRICTED TO BE .LE.0, UNRESTRICTED, */ /* OR .GE.0 RESPECTIVELY. */ /* RES ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST KLMD. */ /* ON EXIT THIS CONTAINS THE RESIDUALS B-AX */ /* IN THE FIRST K COMPONENTS, D-CX IN THE */ /* NEXT L COMPONENTS (THESE WILL BE =0),AND */ /* F-EX IN THE NEXT M COMPONENTS. IF KODE=1 ON */ /* ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE SIMPLE */ /* NONNEGATIVITY CONSTRAINTS ON THE RESIDUALS */ /* B-AX. THE VALUES -1, 0, OR 1 FOR RES(I) */ /* INDICATE THAT THE I-TH RESIDUAL (1.LE.I.LE.K) IS */ /* RESTRICTED TO BE .LE.0, UNRESTRICTED, OR .GE.0 */ /* RESPECTIVELY. */ /* ERROR ON EXIT, THIS GIVES THE MINIMUM SUM OF */ /* ABSOLUTE VALUES OF THE RESIDUALS. */ /* CU A TWO DIMENSIONAL REAL ARRAY WITH TWO ROWS AND */ /* AT LEAST NKLMD COLUMNS USED FOR WORKSPACE. */ /* IU A TWO DIMENSIONAL INTEGER ARRAY WITH TWO ROWS AND */ /* AT LEAST NKLMD COLUMNS USED FOR WORKSPACE. */ /* S INTEGER ARRAY OF SIZE AT LEAST KLMD, USED FOR */ /* WORKSPACE. */ /* DOUBLE PRECISION DBLE */ /* REAL */ /* INITIALIZATION. */ if (svnid == NULL) fprintf (stderr, " "); /* * mp variables */ censor = 1; if (censor_arg == 0.0) censor = 0; mpf_set_default_prec (96); mpf_init (zero); mpf_init (dummy); mpf_init (dummy1); mpf_init_set_d (censor_tol, censor_arg); q = (mpf_t *) PHRQ_malloc ((size_t) (max_row_count * max_column_count * sizeof (mpf_t))); if (q == NULL) malloc_error (); for (i = 0; i < max_row_count * max_column_count; i++) { mpf_init_set_d (q[i], q_arg[i]); if (censor == 1) { if (mpf_cmp (q[i], zero) != 0) { mpf_abs (dummy1, q[i]); if (mpf_cmp (dummy1, censor_tol) <= 0) { mpf_set_si (q[i], 0); } } } } x = (mpf_t *) PHRQ_malloc ((size_t) (n2d * sizeof (mpf_t))); if (x == NULL) malloc_error (); for (i = 0; i < n2d; i++) { mpf_init_set_d (x[i], x_arg[i]); } res = (mpf_t *) PHRQ_malloc ((size_t) ((k + l + m) * sizeof (mpf_t))); if (res == NULL) malloc_error (); for (i = 0; i < k + l + m; i++) { mpf_init_set_d (res[i], res_arg[i]); } cu = (mpf_t *) PHRQ_malloc ((size_t) (2 * nklmd * sizeof (mpf_t))); if (cu == NULL) malloc_error (); for (i = 0; i < 2 * nklmd; i++) { mpf_init_set_d (cu[i], cu_arg[i]); } kode = (int *) PHRQ_malloc (sizeof (int)); if (kode == NULL) malloc_error (); *kode = *kode_arg; mpf_init (sum); mpf_init (error); mpf_init (z); mpf_init (zu); mpf_init (zv); mpf_init (xmax); mpf_init_set_si (minus_one, -1); mpf_init_set_d (toler, toler_arg); mpf_init_set_d (check_toler, toler_arg); mpf_init (pivot); mpf_init (xmin); mpf_init (cuv); mpf_init (tpivot); mpf_init (sn); /* Parameter adjustments */ q_dim = n2d; q2 = (union double_or_int *) q; cu_dim = nklmd; /* Function Body */ maxit = *iter; n1 = n + 1; n2 = n + 2; nk = n + k; nkl = nk + l; klm = k + l + m; klm1 = klm + 1; nklm = n + klm; kforce = 1; *iter = 0; js = 0; ia = -1; /* Make scratch space */ /* scratch = (LDBLE *) PHRQ_malloc( (size_t) nklmd * sizeof(LDBLE)); if (scratch == NULL) malloc_error(); for (i=0; i < nklmd; i++) { scratch[i] = 0.0; } */ /* scratch = (mpf_t *) PHRQ_malloc( (size_t) nklmd * sizeof(mpf_t)); if (scratch == NULL) malloc_error(); for (i=0; i < nklmd; i++) { mpf_init(scratch[i]); } */ /* SET UP LABELS IN Q. */ for (j = 0; j < n; ++j) { q2[klm1 * q_dim + j].ival = j + 1; } /* L10: */ for (i = 0; i < klm; ++i) { q2[i * q_dim + n1].ival = n + i + 1; if (mpf_cmp_d (q2[i * q_dim + n].dval, 0.0) < 0) { for (j = 0; j < n1; ++j) { /* q2[ i * q_dim + j ].dval = -q2[ i * q_dim + j ].dval; */ mpf_neg (q2[i * q_dim + j].dval, q2[i * q_dim + j].dval); } q2[i * q_dim + n1].ival = -q2[i * q_dim + n1].ival; /* L20: */ } } /* L30: */ /* SET UP PHASE 1 COSTS. */ iphase = 2; #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "Set up phase 1 costs\n"); #endif /* Zero first row of cu and iu */ /*memcpy( (void *) &(cu[0]), (void *) &(scratch[0]), (size_t) nklm * sizeof(mpf_t) ); */ for (j = 0; j < nklm; ++j) { mpf_set_si (cu[j], 0); iu[j] = 0; } /* L40: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L40\n"); #endif if (l != 0) { for (j = nk; j < nkl; ++j) { mpf_set_si (cu[j], 1); /*cu[ j ] = 1.; */ iu[j] = 1; } /* L50: */ iphase = 1; } /* Copy first row of cu and iu to second row */ /*memcpy( (void *) &(cu[cu_dim]), (void *) &(cu[0]), (size_t) nklm * sizeof(mpf_t) ); */ for (i = 0; i < nklm; i++) { mpf_set (cu[cu_dim + i], cu[i]); } memcpy ((void *) &(iu[cu_dim]), (void *) &(iu[0]), (size_t) nklm * sizeof (int)); /* L60: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L60\n"); #endif if (m != 0) { for (j = nkl; j < nklm; ++j) { /* cu[ cu_dim + j ] = 1.; */ mpf_set_si (cu[cu_dim + j], 1); iu[cu_dim + j] = 1; jmn = j - n; if (q2[jmn * q_dim + n1].ival < 0) { iphase = 1; } } /* L70: */ } /* L80: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L80\n"); #endif if (*kode != 0) { for (j = 0; j < n; ++j) { /* if ( x[j] < 0.) { */ if (mpf_cmp_si (x[j], 0) < 0) { /* L90: */ /* cu[ j ] = 1.; */ mpf_set_si (cu[j], 1); iu[j] = 1; /* } else if (x[j] > 0.) { */ } else if (mpf_cmp_si (x[j], 0) > 0) { /* cu[ cu_dim + j ] = 1.; */ mpf_set_si (cu[cu_dim + j], 1); iu[cu_dim + j] = 1; } } /* L110: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L110\n"); #endif for (j = 0; j < k; ++j) { jpn = j + n; /* if (res[j] < 0.) { */ if (mpf_cmp_si (res[j], 0) < 0) { /* L120: */ /* cu[ jpn ] = 1.; */ mpf_set_si (cu[jpn], 1); iu[jpn] = 1; if (q2[j * q_dim + n1].ival > 0) { iphase = 1; } /* } else if (res[j] > 0.) { */ } else if (mpf_cmp_si (res[j], 0) > 0) { /* L130: */ /* cu[ cu_dim + jpn ] = 1.; */ mpf_set_si (cu[cu_dim + jpn], 1); iu[cu_dim + jpn] = 1; if (q2[j * q_dim + n1].ival < 0) { iphase = 1; } } } /* L140: */ } /* L150: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L150\n"); #endif if (iphase == 2) { goto L500; } /* COMPUTE THE MARGINAL COSTS. */ L160: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L160\n"); #endif for (j = js; j < n1; ++j) { mpf_set_si (sum, 0); for (i = 0; i < klm; ++i) { ii = q2[i * q_dim + n1].ival; if (ii < 0) { /* z = cu[ cu_dim - ii - 1 ]; */ mpf_set (z, cu[cu_dim - ii - 1]); } else { /*z = cu[ ii - 1 ]; */ mpf_set (z, cu[ii - 1]); } /*sum += q2[ i * q_dim + j ].dval * z; */ mpf_mul (dummy, q2[i * q_dim + j].dval, z); mpf_add (sum, sum, dummy); } /*q2[ klm * q_dim + j ].dval = sum; */ mpf_set (q2[klm * q_dim + j].dval, sum); } for (j = js; j < n; ++j) { ii = q2[klm1 * q_dim + j].ival; if (ii < 0) { /*z = cu[ cu_dim - ii - 1 ]; */ mpf_set (z, cu[cu_dim - ii - 1]); } else { /*z = cu[ ii - 1 ]; */ mpf_set (z, cu[ii - 1]); } /*q2[ klm * q_dim + j ].dval -= z; */ mpf_sub (q2[klm * q_dim + j].dval, q2[klm * q_dim + j].dval, z); } /* DETERMINE THE VECTOR TO ENTER THE BASIS. */ L240: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L240, xmax %e\n", mpf_get_d (xmax)); #endif /*xmax = 0.; */ mpf_set_si (xmax, 0); if (js >= n) { goto L490; /* test for optimality */ } for (j = js; j < n; ++j) { /*zu = q2[ klm * q_dim + j ].dval; */ mpf_set (zu, q2[klm * q_dim + j].dval); ii = q2[klm1 * q_dim + j].ival; if (ii > 0) { /*zv = -zu - cu[ ii - 1 ] - cu[ cu_dim + ii - 1 ]; */ mpf_mul (dummy, cu[cu_dim + ii - 1], minus_one); mpf_sub (dummy, dummy, cu[ii - 1]); mpf_sub (zv, dummy, zu); } else { ii = -ii; /* zv = zu; */ mpf_set (zv, zu); /* zu = -zu - cu[ ii - 1 ] - cu[ cu_dim + ii - 1 ]; */ mpf_mul (dummy, cu[cu_dim + ii - 1], minus_one); mpf_sub (dummy, dummy, cu[ii - 1]); mpf_sub (zu, dummy, zu); } /* L260 */ if (kforce == 1 && ii > n) { continue; } /*if (iu[ ii - 1 ] != 1 && zu > xmax){ */ if ((iu[ii - 1] != 1) && (mpf_cmp (zu, xmax) > 0)) { /*xmax = zu; */ mpf_set (xmax, zu); in = j; } /* L270 */ /*if (iu[ cu_dim + ii - 1 ] != 1 && zv > xmax ) { */ if ((iu[cu_dim + ii - 1] != 1) && (mpf_cmp (zv, xmax) > 0)) { /*xmax = zv; */ mpf_set (xmax, zv); in = j; } } /* L280 */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L280 xmax %e, toler %e\n", mpf_get_d (xmax), mpf_get_d (toler)); #endif /*if (xmax <= toler) { */ if (mpf_cmp (xmax, toler) <= 0) { #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "xmax before optimality test %e\n", mpf_get_d (xmax)); #endif goto L490; /* test for optimality */ } /*if (q2[ klm * q_dim + in ].dval != xmax) { */ if (mpf_cmp (q2[klm * q_dim + in].dval, xmax) != 0) { for (i = 0; i < klm1; ++i) { /*q2[ i * q_dim + in ].dval = -q2[ i * q_dim + in ].dval; */ mpf_neg (q2[i * q_dim + in].dval, q2[i * q_dim + in].dval); } q2[klm1 * q_dim + in].ival = -q2[klm1 * q_dim + in].ival; /* L290: */ /*q2[ klm * q_dim + in ].dval = xmax; */ mpf_set (q2[klm * q_dim + in].dval, xmax); } /* DETERMINE THE VECTOR TO LEAVE THE BASIS. */ if (iphase != 1 && ia != -1) { /*xmax = 0.; */ mpf_set_si (xmax, 0); /* find maximum absolute value in column "in" */ for (i = 0; i <= ia; ++i) { /*z = fabs(q2[ i * q_dim + in ].dval); */ mpf_abs (z, q2[i * q_dim + in].dval); /*if (z > xmax) { */ if (mpf_cmp (z, xmax) > 0) { /*xmax = z; */ mpf_set (xmax, z); iout = i; } } /* L310: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L310, xmax %e\n", mpf_get_d (xmax)); #endif /* switch row ia with row iout, use memcpy */ /*if (xmax > toler) { */ if (mpf_cmp (xmax, toler) > 0) { /* memcpy( (void *) &(scratch[0]), (void *) &(q2[ ia * q_dim]), (size_t) n2 * sizeof(mpf_t) ); memcpy( (void *) &(q2[ ia * q_dim ]), (void *) &(q2[ iout * q_dim]), (size_t) n2 * sizeof(mpf_t) ); memcpy( (void *) &(q2[ iout * q_dim ]), (void *) &(scratch[ 0 ]), (size_t) n2 * sizeof(mpf_t) ); */ for (i = 0; i < n1; i++) { mpf_set (dummy, q2[ia * q_dim + i].dval); mpf_set (q2[ia * q_dim + i].dval, q2[iout * q_dim + i].dval); mpf_set (q2[iout * q_dim + i].dval, dummy); } j = q2[ia * q_dim + n1].ival; q2[ia * q_dim + n1].ival = q2[iout * q_dim + n1].ival; q2[iout * q_dim + n1].ival = j; /* L320: */ /* set pivot to row ia, column in */ iout = ia; --ia; /*pivot = q2[ iout * q_dim + in ].dval; */ mpf_set (pivot, q2[iout * q_dim + in].dval); goto L420; /* Gauss Jordan */ } } /* L330: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L330, xmax %e\n", mpf_get_d (xmax)); #endif kk = -1; /* divide column n1 by positive value in column "in" greater than toler */ for (i = 0; i < klm; ++i) { /*z = q2[ i * q_dim + in ].dval; */ mpf_set (z, q2[i * q_dim + in].dval); /*if (z > toler) { */ if (mpf_cmp (z, toler) > 0) { ++kk; /*res[kk] = q2[ i * q_dim + n ].dval / z; */ mpf_div (res[kk], q2[i * q_dim + n].dval, z); s[kk] = i; } } /* L340: */ if (kk < 0) { output_msg (OUTPUT_MESSAGE, "kode = 2 in loop 340.\n"); } L350: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L350, xmax %e\n", mpf_get_d (xmax)); #endif if (kk < 0) { /* no positive value found in L340 or bypass intermediate verticies */ *kode = 2; goto L590; } /* L360: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L360, xmax %e\n", mpf_get_d (xmax)); #endif /* find minimum residual */ /*xmin = res[ 0 ]; */ mpf_set (xmin, res[0]); iout = s[0]; j = 0; if (kk != 0) { for (i = 1; i <= kk; ++i) { /*if (res[i] < xmin) { */ if (mpf_cmp (res[i], xmin) < 0) { j = i; /*xmin = res[i]; */ mpf_set (xmin, res[i]); iout = s[i]; } } /* L370: */ /* put kk in position j */ /*res[j] = res[kk]; */ mpf_set (res[j], res[kk]); s[j] = s[kk]; } /* L380: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L380 iout %d, xmin %e, xmax %e\n", iout, mpf_get_d (xmin), mpf_get_d (xmax)); #endif --kk; /*pivot = q2[ iout * q_dim + in ].dval; */ mpf_set (pivot, q2[iout * q_dim + in].dval); ii = q2[iout * q_dim + n1].ival; if (iphase != 1) { if (ii < 0) { /* L390: */ if (iu[-ii - 1] == 1) { goto L420; } } else { if (iu[cu_dim + ii - 1] == 1) { goto L420; } } } /* L400: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L400\n"); #endif ii = abs (ii); /*cuv = cu[ ii - 1 ] + cu[ cu_dim + ii - 1]; */ mpf_add (cuv, cu[ii - 1], cu[cu_dim + ii - 1]); /*if (q2[ klm * q_dim + in ].dval - pivot * cuv > toler) { */ mpf_mul (dummy, pivot, cuv); mpf_sub (dummy, q2[klm * q_dim + in].dval, dummy); if (mpf_cmp (dummy, toler) > 0) { /* BYPASS INTERMEDIATE VERTICES. */ for (j = js; j < n1; ++j) { /*z = q2[ iout * q_dim + j ].dval; */ mpf_set (z, q2[iout * q_dim + j].dval); /*q2[ klm * q_dim + j ].dval -= z * cuv; */ mpf_mul (dummy1, z, cuv); mpf_sub (q2[klm * q_dim + j].dval, q2[klm * q_dim + j].dval, dummy1); if (censor == 1) { if (mpf_cmp (q2[klm * q_dim + j].dval, zero) != 0) { mpf_abs (dummy1, q2[klm * q_dim + j].dval); if (mpf_cmp (dummy1, censor_tol) <= 0) { mpf_set_si (q2[klm * q_dim + j].dval, 0); } } } /*q2[ iout * q_dim + j ].dval = -z; */ mpf_neg (q2[iout * q_dim + j].dval, z); } /* L410: */ q2[iout * q_dim + n1].ival = -q2[iout * q_dim + n1].ival; goto L350; } /* GAUSS-JORDAN ELIMINATION. */ L420: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "Gauss Jordon %d\n", *iter); #endif if (*iter >= maxit) { *kode = 3; goto L590; } /* L430: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L430\n"); #endif ++(*iter); for (j = js; j < n1; ++j) { if (j != in) { /*q2[ iout * q_dim + j ].dval /= pivot; */ mpf_div (q2[iout * q_dim + j].dval, q2[iout * q_dim + j].dval, pivot); } } /* L440: */ for (j = js; j < n1; ++j) { if (j != in) { /*z = -q2[ iout * q_dim + j ].dval; */ mpf_neg (z, q2[iout * q_dim + j].dval); for (i = 0; i < klm1; ++i) { if (i != iout) { /*q2[ i * q_dim + j ].dval += z * q2[ i * q_dim + in ].dval; */ mpf_mul (dummy, z, q2[i * q_dim + in].dval); mpf_add (q2[i * q_dim + j].dval, q2[i * q_dim + j].dval, dummy); if (censor == 1) { if (mpf_cmp (q2[i * q_dim + j].dval, zero) != 0) { mpf_abs (dummy1, q2[i * q_dim + j].dval); if (mpf_cmp (dummy1, censor_tol) <= 0) { mpf_set_si (q2[i * q_dim + j].dval, 0); } } } } } /* L450: */ } } /* L460: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L460\n"); #endif /*tpivot = -pivot; */ mpf_neg (tpivot, pivot); for (i = 0; i < klm1; ++i) { if (i != iout) { /*q2[ i * q_dim + in ].dval /= tpivot; */ mpf_div (q2[i * q_dim + in].dval, q2[i * q_dim + in].dval, tpivot); } } /* L470: */ /*q2[ iout * q_dim + in ].dval = 1. / pivot; */ mpf_set_si (dummy, 1); mpf_div (q2[iout * q_dim + in].dval, dummy, pivot); ii = q2[iout * q_dim + n1].ival; q2[iout * q_dim + n1].ival = q2[klm1 * q_dim + in].ival; q2[klm1 * q_dim + in].ival = ii; ii = abs (ii); if (iu[ii - 1] == 0 || iu[cu_dim + ii - 1] == 0) { goto L240; } /* switch column */ for (i = 0; i < klm1; ++i) { /*z = q2[ i * q_dim + in ].dval; */ mpf_set (z, q2[i * q_dim + in].dval); /*q2[ i * q_dim + in ].dval = q2[ i * q_dim + js ].dval; */ mpf_set (q2[i * q_dim + in].dval, q2[i * q_dim + js].dval); /*q2[ i * q_dim + js ].dval = z; */ mpf_set (q2[i * q_dim + js].dval, z); } i = q2[klm1 * q_dim + in].ival; q2[klm1 * q_dim + in].ival = q2[klm1 * q_dim + js].ival; q2[klm1 * q_dim + js].ival = i; /* L480: */ ++js; goto L240; /* TEST FOR OPTIMALITY. */ L490: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L490\n"); #endif if (kforce == 0) { if (iphase == 1) { /*if (q2[ klm * q_dim + n ].dval <= toler) { */ if (mpf_cmp (q2[klm * q_dim + n].dval, toler) <= 0) { goto L500; } #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "q2[klm1-1, n1-1] > *toler. %e\n", mpf_get_d (q2[(klm1 - 1) * q_dim + n1 - 1].dval)); #endif *kode = 1; goto L590; } *kode = 0; goto L590; } /*if (iphase != 1 || q2[ klm * q_dim + n ].dval > toler) { */ if ((iphase != 1) || (mpf_cmp (q2[klm * q_dim + n].dval, toler) > 0)) { kforce = 0; goto L240; } /* SET UP PHASE 2 COSTS. */ L500: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "Set up phase 2 costs %d\n", *iter); #endif iphase = 2; for (j = 0; j < nklm; ++j) { /*cu[ j ] = 0.; */ mpf_set_si (cu[j], 0); } /* L510: */ for (j = n; j < nk; ++j) { /*cu[ j ] = 1.; */ mpf_set_si (cu[j], 1); } /* memcpy( (void *) &(cu[cu_dim]), (void *) &(cu[0]), (size_t) nklm * sizeof(LDBLE) ); */ for (i = 0; i < nklm; i++) { mpf_set (cu[cu_dim + i], cu[i]); } /* L520: */ for (i = 0; i < klm; ++i) { ii = q2[i * q_dim + n1].ival; if (ii <= 0) { if (iu[cu_dim - ii - 1] == 0) { continue; } /*cu[ cu_dim - ii - 1 ] = 0.; */ mpf_set_si (cu[cu_dim - ii - 1], 0); } else { /* L530: */ if (iu[ii - 1] == 0) { continue; } /*cu[ ii - 1 ] = 0.; */ mpf_set_si (cu[ii - 1], 0); } /* L540: */ ++ia; /* switch row */ /* memcpy( (void *) &(scratch[0]), (void *) &(q2[ ia * q_dim]), (size_t) n2 * sizeof(LDBLE) ); memcpy( (void *) &(q2[ ia * q_dim ]), (void *) &(q2[ i * q_dim]), (size_t) n2 * sizeof(LDBLE) ); memcpy( (void *) &(q2[ i * q_dim ]), (void *) &(scratch[ 0 ]), (size_t) n2 * sizeof(LDBLE) ); */ for (iswitch = 0; iswitch < n1; iswitch++) { mpf_set (dummy, q2[ia * q_dim + iswitch].dval); mpf_set (q2[ia * q_dim + iswitch].dval, q2[i * q_dim + iswitch].dval); mpf_set (q2[i * q_dim + iswitch].dval, dummy); } iswitch = q2[ia * q_dim + n1].ival; q2[ia * q_dim + n1].ival = q2[i * q_dim + n1].ival; q2[i * q_dim + n1].ival = iswitch; /* L550: */ } /* L560: */ goto L160; /* PREPARE OUTPUT. */ L590: #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L590\n"); #endif /*sum = 0.; */ mpf_set_si (sum, 0); for (j = 0; j < n; ++j) { /*x[j] = 0.; */ mpf_set_si (x[j], 0); } /* L600: */ for (i = 0; i < klm; ++i) { /*res[i] = 0.; */ mpf_set_si (res[i], 0); } /* L610: */ for (i = 0; i < klm; ++i) { ii = q2[i * q_dim + n1].ival; /*sn = 1.; */ mpf_set_si (sn, 1); if (ii < 0) { ii = -ii; /*sn = -1.; */ mpf_set_si (sn, -1); } if (ii <= n) { /* L620: */ /*x[ii - 1] = sn * q2[ i * q_dim + n ].dval; */ mpf_mul (x[ii - 1], sn, q2[i * q_dim + n].dval); } else { /* L630: */ /*res[ii - n - 1] = sn * q2[ i * q_dim + n ].dval; */ mpf_mul (res[ii - n - 1], sn, q2[i * q_dim + n].dval); if (ii >= n1 && ii <= nk) { /* * DBLE(Q(I,N1)) */ /*sum += q2[ i * q_dim + n ].dval; */ mpf_add (sum, sum, q2[i * q_dim + n].dval); } } } /* L640: */ #ifdef DEBUG_CL1 output_msg (OUTPUT_MESSAGE, "L640\n"); #endif /* * Check calculation */ mpf_set_si (dummy, 100); mpf_mul (check_toler, toler, dummy); if (check && *kode == 0) { /* * Check optimization constraints */ if (*kode_arg == 1) { for (i = 0; i < k; i++) { if (res_arg[i] < 0.0) { mpf_sub (dummy, res[i], check_toler); mpf_set_si (dummy1, 0); if (mpf_cmp (dummy, dummy1) > 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: optimization constraint not satisfied row %d, res %e, constraint %f.\n", i, mpf_get_d (res[i]), res_arg[i]); #endif *kode = 1; } } else if (res_arg[i] > 0.0) { mpf_add (dummy, res[i], check_toler); mpf_set_si (dummy1, 0); if (mpf_cmp (dummy, dummy1) < 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: optimization constraint not satisfied row %d, res %e, constraint %f.\n", i, mpf_get_d (res[i]), res_arg[i]); #endif *kode = 1; } } } } /* * Check equalities */ for (i = k; i < k + l; i++) { mpf_abs (dummy, res[i]); if (mpf_cmp (dummy, check_toler) > 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: equality constraint not satisfied row %d, res %e, tolerance %e.\n", i, mpf_get_d (res[i]), mpf_get_d (check_toler)); #endif *kode = 1; } } /* * Check inequalities */ for (i = k + l; i < k + l + m; i++) { mpf_neg (dummy, check_toler); if (mpf_cmp (res[i], dummy) < 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: inequality constraint not satisfied row %d, res %e, tolerance %e.\n", i, mpf_get_d (res[i]), mpf_get_d (check_toler)); #endif *kode = 1; } } /* * Check dissolution/precipitation constraints */ if (*kode_arg == 1) { for (i = 0; i < n; i++) { if (x_arg[i] < 0.0) { mpf_sub (dummy, x[i], check_toler); mpf_set_si (dummy1, 0); if (mpf_cmp (dummy, dummy1) > 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: dis/pre constraint not satisfied column %d, x %e, constraint %f.\n", i, mpf_get_d (x[i]), x_arg[i]); #endif *kode = 1; } } else if (x_arg[i] > 0.0) { mpf_add (dummy, x[i], check_toler); mpf_set_si (dummy1, 0); if (mpf_cmp (dummy, dummy1) < 0) { #ifdef CHECK_ERRORS output_msg (OUTPUT_MESSAGE, "\tCL1MP: dis/pre constraint not satisfied column %d, x %e, constraint %f.\n", i, mpf_get_d (x[i]), x_arg[i]); #endif *kode = 1; } } } } if (*kode == 1) { output_msg (OUTPUT_MESSAGE, "\n\tCL1MP: Roundoff errors in optimization.\n\t Deleting model.\n"); } } /* * set return variables */ /**error = sum;*/ mpf_set (error, sum); *error_arg = mpf_get_d (error); *kode_arg = *kode; for (i = 0; i < n2d; i++) { x_arg[i] = mpf_get_d (x[i]); } for (i = 0; i < k + l + m; i++) { res_arg[i] = mpf_get_d (res[i]); } /*scratch = free_check_null (scratch); */ for (i = 0; i < max_row_count * max_column_count; i++) { mpf_clear (q[i]); } q = (mpf_t *) free_check_null (q); for (i = 0; i < n2d; i++) { mpf_clear (x[i]); } x = (mpf_t *) free_check_null (x); for (i = 0; i < k + l + m; i++) { mpf_clear (res[i]); } res = (mpf_t *) free_check_null (res); for (i = 0; i < 2 * nklmd; i++) { mpf_clear (cu[i]); } cu = (mpf_t *) free_check_null (cu); mpf_clear (dummy); mpf_clear (dummy1); mpf_clear (sum); mpf_clear (error); mpf_clear (z); mpf_clear (zu); mpf_clear (zv); mpf_clear (xmax); mpf_clear (minus_one); mpf_clear (toler); mpf_clear (check_toler); mpf_clear (pivot); mpf_clear (xmin); mpf_clear (cuv); mpf_clear (tpivot); mpf_clear (sn); mpf_clear (censor_tol); kode = (int *) free_check_null (kode); return 0; }
long int julia(const mpf_t x, const mpf_t xr, long int xres, const mpf_t y, const mpf_t yr, long int yres, mpf_t *c, int flag, long int max_iteration, float *iterations, int my_rank, int p, MPI_Comm comm) { double t0 = MPI_Wtime(); int i,j; //------------julia gmp const double maxRadius = 4.0; // double xi, yi, savex, savex2, savey, radius; mpf_t xi, yi, x_min, x_max, y_min, y_max, savex, savex2, savey, radius, xgap, ygap, savex_a, savex_b, savey_a, savey_b, tmp, tmp1; mpf_init(xi); mpf_init(yi); mpf_init(x_min); mpf_init(x_max); mpf_init(y_min); mpf_init(y_max); mpf_init(savex); mpf_init(savex2); mpf_init(savey); mpf_init(radius); mpf_init(xgap); mpf_init(ygap); mpf_init(savex_a); mpf_init(savex_b); mpf_init(savey_a); mpf_init(savey_b); mpf_init(tmp); mpf_init(tmp1); //double x_min = x - xr; mpf_sub(x_min, x, xr); //double x_max = x + xr; mpf_add(x_max, x, xr); //double y_min = y - yr; mpf_sub(y_min, y, yr); //double y_max = y + yr; mpf_add(y_max, y, yr); // spaceing between x and y points //double xgap = (x_max - x_min) / xres; mpf_sub(xgap, x_max, x_min); mpf_div_ui(xgap, xgap, xres); //double ygap = (y_max - y_min) / yres; mpf_sub(ygap, y_max, y_min); mpf_div_ui(ygap, ygap, yres); //---------------------------- long long int iteration; long long int total_number_iterations = 0; int k = 0; for (j = 0; j < yres; j++){ for (i = 0; i < xres; i++){ //xi = x_min + i * xgap; mpf_mul_ui(tmp, xgap, i); mpf_add(xi, x_min, tmp); //yi = y_min + j * ygap; mpf_mul_ui(tmp, ygap, j); mpf_add(yi, y_min, tmp); //flag betwee[n julia or mandelbrot //savex = flag * c[0] + (1 - flag) * xi; mpf_mul_ui(savex_a, c[0], flag); mpf_mul_ui(savex_b, xi, (1-flag)); mpf_add(savex, savex_a, savex_b); //savey = flag * c[1] + (1 - flag) * yi; mpf_mul_ui(savey_a, c[1], flag); mpf_mul_ui(savey_b, yi, (1-flag)); mpf_add(savey, savey_a, savey_b); //radius = 0; mpf_set_ui(radius, 0); iteration = 0; //while ((radius <= maxRadius) && (iteration < max_iteration)){ while ((mpf_cmp_d(radius, maxRadius)<=0) && (iteration < max_iteration)){ //savex2 = xi; mpf_add_ui(savex2, xi, 0); //xi = xi * xi - yi * yi + savex; mpf_mul(xi, xi, xi); mpf_mul(tmp, yi, yi); mpf_sub(xi, xi, tmp); mpf_add(xi, xi, savex); //yi = 2.0f * savex2 * yi + savey; mpf_mul_ui(tmp, savex2, 2); mpf_mul(yi, yi, tmp); mpf_add(yi, yi, savey); //radius = xi * xi + yi * yi; mpf_mul(tmp, xi, xi); mpf_mul(tmp1, yi, yi); mpf_add(radius, tmp, tmp1); iteration++; } total_number_iterations += iteration; float *p = iterations + k*xres + i; //if (radius > maxRadius){ if (mpf_cmp_d(radius, maxRadius)>0){ //float zn = sqrt(xi*xi + yi*yi); mpf_t zn; mpf_init(zn); mpf_mul(tmp, xi, xi); mpf_mul(tmp1, yi, yi); mpf_add(zn, tmp, tmp1); mpf_sqrt(zn, zn); double n = mpf_get_d(zn); //float nu = log(log(zn) / log(2))/log(2); double nu = log(log(n) / log(2))/log(2); //the point has escaped at iteration at any of the iterations 0,1,2,3... *p = iteration + 1 - nu; } else // zij stays within the region up to max_iteration { assert(iteration==max_iteration); *p = -1; } } k++; } //reduce max iteration count long long int total_reduced_iterations = -1; //printf("rank: %i, total_reduced_iterations: %i\n", my_rank, total_number_iterations); MPI_Reduce(&total_number_iterations, &total_reduced_iterations, 1, MPI_LONG_LONG_INT, MPI_SUM, 0, comm); double t4 = MPI_Wtime(); double max_reduced_time = -1; double total_time = t4 - t0; MPI_Reduce(&total_time, &max_reduced_time, 1, MPI_DOUBLE, MPI_MAX, 0, comm); printf("np: %i, time: %f , iterations: %lld\n",p, max_reduced_time, total_reduced_iterations); //clear //printf("proc: %i, total time: %lf sec, init: %lf sec, calc: %lf sec, collect: %lf\n", my_rank, t4-t0, t1-t0, t2-t1, t3-t2); return total_reduced_iterations; }