void check_data (void) { static const struct { int a_base; const char *a; const char *b; int want; } data[] = { { 10, "0", "1", -1 }, { 10, "0", "0", 0 }, { 10, "0", "-1", 1 }, { 10, "1", "1", 0 }, { 10, "1", "0", 1 }, { 10, "1", "-1", 1 }, { 10, "-1", "1", -1 }, { 10, "-1", "0", -1 }, { 10, "-1", "-1", 0 }, { 16, "0", "-0x80000000", 1 }, { 16, "80000000", "-0x80000000", 1 }, { 16, "80000001", "-0x80000000", 1 }, { 16, "-80000000", "-0x80000000", 0 }, { 16, "-80000001", "-0x80000000", -1 }, { 16, "-FF0080000001", "-0x80000000", -1 }, { 16, "0", "-0x8000000000000000", 1 }, { 16, "8000000000000000", "-0x8000000000000000", 1 }, { 16, "8000000000000001", "-0x8000000000000000", 1 }, { 16, "-8000000000000000", "-0x8000000000000000", 0 }, { 16, "-8000000000000001", "-0x8000000000000000", -1 }, { 16, "-FF008000000000000001", "-0x8000000000000000", -1 }, }; mpf_t a; mpz_t bz; long b; int got; int i; mpf_init (a); mpz_init (bz); for (i = 0; i < numberof (data); i++) { mpf_set_str_or_abort (a, data[i].a, data[i].a_base); mpz_set_str_or_abort (bz, data[i].b, 0); if (mpz_fits_slong_p (bz)) { b = mpz_get_si (bz); got = mpf_cmp_si (a, b); if (SGN (got) != data[i].want) { printf ("mpf_cmp_si wrong on data[%d]\n", i); printf (" a="); mpf_out_str (stdout, 10, 0, a); printf (" (%s)\n", data[i].a); printf (" b=%ld (%s)\n", b, data[i].b); printf (" got=%d\n", got); printf (" want=%d\n", data[i].want); abort(); } } } mpf_clear (a); mpz_clear (bz); }
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; }
int main (void) { mpf_t x; mpfr_t y, z; unsigned long i; mpfr_exp_t e; int inex; tests_start_mpfr (); mpfr_init (y); mpfr_init (z); mpf_init (x); i = 1; while (i) { mpfr_set_ui (y, i, MPFR_RNDN); if (mpfr_get_f (x, y, MPFR_RNDN) != 0 || mpf_cmp_ui (x, i)) { printf ("Error: mpfr_get_f(%lu) fails\n", i); exit (1); } if (i <= - (unsigned long) LONG_MIN) { long j = i < - (unsigned long) LONG_MIN ? - (long) i : LONG_MIN; mpfr_set_si (y, j, MPFR_RNDN); if (mpfr_get_f (x, y, MPFR_RNDN) != 0 || mpf_cmp_si (x, j)) { printf ("Error: mpfr_get_f(-%lu) fails\n", i); exit (1); } } i *= 2; } /* same tests, but with a larger precision for y, which requires to round it */ mpfr_set_prec (y, 100); i = 1; while (i) { mpfr_set_ui (y, i, MPFR_RNDN); inex = mpfr_get_f (x, y, MPFR_RNDN); if (! SAME_SIGN (inex, - mpfr_cmp_f (y, x)) || mpf_cmp_ui (x, i)) { printf ("Error: mpfr_get_f(%lu) fails\n", i); exit (1); } mpfr_set_si (y, (signed long) -i, MPFR_RNDN); inex = mpfr_get_f (x, y, MPFR_RNDN); if (! SAME_SIGN (inex, - mpfr_cmp_f (y, x)) || mpf_cmp_si (x, (signed long) -i)) { printf ("Error: mpfr_get_f(-%lu) fails\n", i); exit (1); } i *= 2; } /* bug reported by Jim White */ for (e = 0; e <= 2 * GMP_NUMB_BITS; e++) { /* test with 2^(-e) */ mpfr_set_ui (y, 1, MPFR_RNDN); mpfr_div_2exp (y, y, e, MPFR_RNDN); inex = mpfr_get_f (x, y, MPFR_RNDN); mpf_mul_2exp (x, x, e); if (inex != 0 || mpf_cmp_ui (x, 1) != 0) { printf ("Error: mpfr_get_f(x,y,MPFR_RNDN) fails\n"); printf ("y="); mpfr_dump (y); printf ("x="); mpf_div_2exp (x, x, e); mpf_out_str (stdout, 2, 0, x); exit (1); } /* test with 2^(e) */ mpfr_set_ui (y, 1, MPFR_RNDN); mpfr_mul_2exp (y, y, e, MPFR_RNDN); inex = mpfr_get_f (x, y, MPFR_RNDN); mpf_div_2exp (x, x, e); if (inex != 0 || mpf_cmp_ui (x, 1) != 0) { printf ("Error: mpfr_get_f(x,y,MPFR_RNDN) fails\n"); printf ("y="); mpfr_dump (y); printf ("x="); mpf_mul_2exp (x, x, e); mpf_out_str (stdout, 2, 0, x); exit (1); } } /* Bug reported by Yury Lukach on 2006-04-05 */ mpfr_set_prec (y, 32); mpfr_set_prec (z, 32); mpf_set_prec (x, 32); mpfr_set_ui_2exp (y, 0xc1234567, -30, MPFR_RNDN); mpfr_get_f (x, y, MPFR_RNDN); inex = mpfr_set_f (z, x, MPFR_RNDN); if (inex != 0 || ! mpfr_equal_p (y, z)) { printf ("Error in mpfr_get_f:\n inex = %d, y = ", inex); mpfr_dump (z); printf ("Expected:\n inex = 0, y = "); mpfr_dump (y); exit (1); } mpfr_clear (y); mpfr_clear (z); mpf_clear (x); special_test (); prec_test (); ternary_test (); tests_end_mpfr (); return 0; }