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;
}
