max/iphreeqc
1
0
Fork 0
mirror of https://git.gfz-potsdam.de/naaice/iphreeqc.git synced 2025-12-15 16:18:22 +01:00
Code Issues Packages Projects Releases Wiki Activity
iphreeqc/phreeqcpp/cl1mp.cpp
Darth Vader 622bc5fb4c Squashed 'src/' changes from ac393756..d6a74675 
d6a74675 Merge commit '4e80a54467a084df3b666c7d6fc56a4798fd3301'
4e80a544 Squashed 'phreeqcpp/' changes from 7c7fafd..c876219
0209fdf9 Merge commit 'b537589773f4819fe97ff8e5322bcd38c54b63f7'
b5375897 Squashed 'phreeqcpp/' changes from e317dd0..7c7fafd

git-subtree-dir: src
git-subtree-split: d6a74675d73985977ceac1601b57463c1ee8c331
2024-10-08 20:05:43 +00:00

1142 lines
26 KiB
C++
Raw Blame History

#ifdef INVERSE_CL1MP
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <stdlib.h>
#include <gmp.h>
#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
Reference in New Issue View Git Blame Copy Permalink