#ifdef INVERSE_CL1MP #include #include #include #include #include #include "Phreeqc.h" #include "phqalloc.h" #include "phrqtype.h" /* debug #define DEBUG_CL1 #define CHECK_ERRORS */ #if defined(PHREEQCI_GUI) #ifdef _DEBUG #define new DEBUG_NEW #undef THIS_FILE static char THIS_FILE[] = __FILE__; #endif #endif int Phreeqc:: 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) { mpf_set_default_prec(256); /* System generated locals */ union double_or_int { int ival; mpf_t dval; } *q2; /* Local variables */ int nklm; int iout = 0; // static i runs faster int i, j; int maxit, n1; //, n2; int ia, ii, kk, nk, js; int in = 0; int iphase, kforce; int klm, jmn, nkl, jpn; int klm1; 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. */ /* * 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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "L150\n")); #endif if (iphase == 2) { goto L500; } /* COMPUTE THE MARGINAL COSTS. */ L160: #ifdef DEBUG_CL1 output_msg(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "kode = 2 in loop 340.\n")); } L350: #ifdef DEBUG_CL1 output_msg(sformatf( "L350, xmax %e\n", mpf_get_d(xmax))); #endif if (kk < 0) { /* no positive value found in L340 or bypass intermediate vertices */ *kode = 2; goto L590; } /* L360: */ #ifdef DEBUG_CL1 output_msg(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "Gauss Jordon %d\n", *iter)); #endif if (*iter >= maxit) { *kode = 3; goto L590; } /* L430: */ #ifdef DEBUG_CL1 output_msg(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "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(sformatf( "\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(sformatf( "\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(sformatf( "\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(sformatf( "\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(sformatf( "\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(sformatf( "\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(sformatf( "\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(zero); 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; } #endif // INVERSE_CL1MP