static real
Conival1(ASL_fg *asl, int i, real *X, fint *nerror)
{
cgrad *gr;
int j1, kv, *vmi;
real f, *vscale;
if (i < asl->i.n_con0)
f = cival(asl, i, X, nerror);
else
f = 0.;
kv = 0;
vmi = 0;
if ((vscale = asl->i.vscale))
kv = 2;
if (asl->i.vmap) {
vmi = get_vminv_ASL((ASL*)asl);
++kv;
}
gr = asl->i.Cgrad0[i];
switch(kv) {
case 3:
for(; gr; gr = gr->next) {
j1 = vmi[gr->varno];
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 2:
for(; gr; gr = gr->next) {
j1 = gr->varno;
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 1:
for(; gr; gr = gr->next)
f += X[vmi[gr->varno]] * gr->coef;
break;
case 0:
for(; gr; gr = gr->next)
f += X[gr->varno] * gr->coef;
}
return f;
}
real
con2ival_ASL(ASL *a, int i, real *X, fint *nerror)
{
ASL_fgh *asl;
cgrad *gr;
int j1, kv, *vmi;
real f, *vscale;
INchk(a, "con2ival", i, a->i.n_con0);
asl = (ASL_fgh*)a;
f = c2ival(asl, i, X, nerror);
kv = 0;
vmi = 0;
if ((vscale = asl->i.vscale))
kv = 2;
if (asl->i.vmap) {
vmi = get_vminv_ASL(a);
++kv;
}
gr = asl->i.Cgrad0[i];
switch(kv) {
case 3:
for(; gr; gr = gr->next) {
j1 = vmi[gr->varno];
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 2:
for(; gr; gr = gr->next) {
j1 = gr->varno;
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 1:
for(; gr; gr = gr->next)
f += X[vmi[gr->varno]] * gr->coef;
break;
case 0:
for(; gr; gr = gr->next)
f += X[gr->varno] * gr->coef;
}
return f;
}
static void
objgrd_adj(ASL *asl, int no, real *X, real *G, fint *nerror)
{
Objrep *od;
cgrad *gr;
int k, *vmi;
real c;
if (!(od = asl->i.Or[no])) {
asl->p.Objgrd_nomap(asl, no, X, G, nerror);
return;
}
if (od->nxval != asl->i.nxval)
objval_adj(asl, no, X, nerror);
if ((k = asl->i.congrd_mode))
asl->i.congrd_mode = 0;
asl->p.Congrd_nomap(asl, od->ico, X, G, nerror);
asl->i.congrd_mode = k;
if ((c = od->c12) != 1. && (!nerror || !*nerror)) {
vmi = get_vminv_ASL(asl);
for(gr = asl->i.Cgrad0[od->ico]; gr; gr = gr->next)
G[vmi[gr->varno]] *= c;
}
}
void
mpec_auxvars_ASL(ASL *asl, real *c, real *x)
{
/* Adjust variables added by mpec_adjust_ASL() so the constraints */
/* added by mpec_adjust_ASL() are satisfied. */
MPEC_Adjust *mpa;
cgrad **Cg, **Cga, *cg;
int *cc, *cce, *ck, *cv, i, incc, incv, j, m0, n0, *vmi;
real *Lc, *Lc0, *Lc1, *Lv0, *ca, t;
mpa = asl->i.mpa;
cv = cvar;
cc = mpa->cc;
cce = mpa->cce;
ck = mpa->ck;
Cga = mpa->Cgrda;
m0 = mpa->m0;
n0 = mpa->n0;
Cg = Cgrad + m0;
ca = c + m0;
Lc0 = LUrhs;
Lc1 = mpa->rhs1;
Lv0 = LUv;
incc = mpa->incc;
incv = mpa->incv;
vmi = get_vminv_ASL(asl);
do {
t = c[i = *cc++];
c[i] = 0.;
j = cv[i] - 1;
for(cg = *Cga++; cg->varno < n0; cg = cg->next);
Lc = Lc0 + i*incc;
if (!*ck++) {
if (t >= 0.)
x[vmi[cg->varno]] = t;
else {
cg = cg->next;
x[vmi[cg->varno]] = -t;
}
cg = (*Cg++)->next;
x[vmi[cg->varno]] = x[j] - *Lc1;
*ca++ = *Lc1;
Lc1 += incc;
cg = (*Cg++)->next;
x[vmi[cg->varno]] = *Lc1 - x[j];
*ca++ = *Lc1;
Lc1 += incc;
}
else {
x[vmi[cg->varno]] = cg->coef*(*Lc - t);
c[i] = *Lc;
if (Lv0[incv*j] != 0.) {
cg = (*Cg++)->next;
x[vmi[cg->varno]] = cg->coef*(*Lc1 - x[j]);
*ca++ = *Lc1;
Lc1 += incc;
}
}
} while(cc < cce);
}
void
con2grd_ASL(ASL *a, int i, real *X, real *G, fint *nerror)
{
ASL_fgh *asl;
Jmp_buf err_jmp0;
cde *d;
cgrad *gr, *gr1;
int i0, ij, j, *vmi, xksave;
real *Adjoints, *vscale;
size_t L;
static char who[] = "con2grd";
INchk(a, who, i, a->i.n_con0);
asl = (ASL_fgh*)a;
if (!want_derivs)
No_derivs_ASL(who);
if (nerror && *nerror >= 0) {
err_jmp = &err_jmp0;
ij = setjmp(err_jmp0.jb);
if ((*nerror = ij))
return;
}
errno = 0; /* in case f77 set errno opening files */
if (!asl->i.x_known)
x2_check_ASL(asl,X);
if ((!asl->i.ncxval || asl->i.ncxval[i] != asl->i.nxval)
&& (!(x0kind & ASL_have_conval)
|| i < n_conjac[0] || i >= n_conjac[1])) {
xksave = asl->i.x_known;
asl->i.x_known = 1;
con2ival_ASL(a,i,X,nerror);
asl->i.x_known = xksave;
if (nerror && *nerror)
return;
}
if (asl->i.Derrs)
deriv_errchk_ASL(a, nerror, i, 1);
if (!(x0kind & ASL_have_funnel)) {
if (f_b)
funnelset(asl, f_b);
if (f_c)
funnelset(asl, f_c);
x0kind |= ASL_have_funnel;
}
Adjoints = adjoints;
d = con_de + i;
gr1 = asl->i.Cgrad0[i];
for(gr = gr1; gr; gr = gr->next)
Adjoints[gr->varno] = gr->coef;
if ((L = d->zaplen)) {
memset(adjoints_nv1, 0, L);
derprop(d->d);
}
vmi = 0;
if (asl->i.vmap)
vmi = get_vminv_ASL(a);
if ((vscale = asl->i.vscale)) {
if (vmi)
for(gr = gr1; gr; gr = gr->next) {
i0 = gr->varno;
Adjoints[i0] *= vscale[vmi[i0]];
}
else
for(gr = gr1; gr; gr = gr->next) {
i0 = gr->varno;
Adjoints[i0] *= vscale[i0];
}
}
gr = gr1;
i0 = 0;
switch(asl->i.congrd_mode) {
case 1:
for(; gr; gr = gr->next)
G[i0++] = Adjoints[gr->varno];
break;
case 2:
for(; gr; gr = gr->next)
G[gr->goff] = Adjoints[gr->varno];
break;
default:
if (vmi) {
for(; gr; gr = gr->next) {
i = vmi[j = gr->varno];
while(i0 < i)
G[i0++] = 0;
G[i] = Adjoints[j];
i0 = i + 1;
}
}
else
for(; gr; gr = gr->next) {
i = gr->varno;
while(i0 < i)
G[i0++] = 0;
G[i] = Adjoints[i];
i0 = i + 1;
}
i = n_var;
while(i0 < i)
G[i0++] = 0;
}
err_jmp = 0;
}
void
mpec_adjust_ASL(ASL *asl)
{
MPEC_Adjust *mpa;
cde *cd;
cde2 *cd2;
cgrad **Cgrd, **Cgrd1, **Cgrda, *cg, *cg1, *ncg, **pcg;
char *hx0;
int *cc, *ck, *cv, *ind1, *ind2, *map, *mapinv;
int i, incc, incv, j, k, m, m0, n, n0, n1, nb, ncc, ncc0, nib, nib0;
int nnv, nz, nz0, nznew, v1, v2, v3, v4;
real *Lc, *Lc0, *Lc1, *Lv, *Lv0, *Lv1, *Uc, *Uc0, *Uc1, *Uv, *Uv0, *Uv1;
real a, b, *x;
extern void f_OPVARVAL_ASL(), f2_VARVAL_ASL();
n = n1 = n0 = n_var;
nib = niv + nbv;
nib0 = n - nib; /* offset of first linear integer or binary variable */
m = m0 = n_con;
nz = nz0 = nzc;
cv = cvar;
Cgrd = Cgrad;
Cgrd1 = Cgrd + m;
incc = incv = 1;
Lc0 = LUrhs;
if (!(Uc0 = Urhsx)) {
Uc0 = Lc0 + 1;
incc = 2;
}
Lv0 = LUv;
if (!(Uv0 = Uvx)) {
Uv0 = Lv0 + 1;
incv = 2;
}
ncc = ncc0 = n_cc;
Lc1 = Lc0 + m*incc;
Uc1 = Uc0 + m*incc;
Lv1 = Lv0 + n*incv;
Uv1 = Uv0 + n*incv;
for(i = k = 0; i < m0; ++i)
if ((j = cv[i])) {
++k;
Lc = Lc0 + incc*i;
Uc = Uc0 + incc*i;
nb = (*Lc > negInfinity) + (*Uc < Infinity);
/* nb == 0 or 1 */
if (!nb) {
m += 2;
n += 4;
nz += 6;
++ncc;
}
else {
Lv = Lv0 + incv*--j;
if (*Lv != 0.) {
++m;
++n;
nz += 2;
}
/* Even if constraint i has the form v >= 0, */
/* add a new variable v1 >= 0 and change the */
/* constraint to v1 = v - rhs, in case v is */
/* involved in more than one complementarity */
++n;
++nz;
}
}
if (k != ncc0) {
fprintf(Stderr,
"\nERROR: mpec_adjust saw %d rather than %d incoming complementarities.\n",
k, ncc0);
exit(1);
}
n_var = n;
n_con = m;
nnv = n - n0;
if (n_obj)
adjust_zerograds_ASL(asl, nnv);
if (n_conjac[1] >= m0)
n_conjac[1] = m;
nzc = nz;
n_cc = ncc;
nznew = nz - nz0;
ncg = (cgrad*)M1alloc(2*(ncc + ncc0)*sizeof(int) + nznew*sizeof(cgrad)
+ ncc0*sizeof(cgrad*) + sizeof(MPEC_Adjust));
asl->i.mpa = mpa = (MPEC_Adjust*)(ncg + nznew);
Cgrda = mpa->Cgrda = (cgrad**)(mpa + 1);
asl->i.ccind1 = ind1 = (int*)(Cgrda + ncc0);
asl->i.ccind2 = ind2 = ind1 + ncc;
mpa->cc = cc = ind2 + ncc;
mpa->ck = ck = mpa->cce = cc + ncc0;
mpa->m0 = m0;
mpa->n0 = n0 - nib;
mpa->rhs1 = Lc1;
mpa->incc = incc;
mpa->incv = incv;
if (nib) {
map = get_vcmap_ASL(asl, ASL_Sufkind_var);
/* Three reverse calls move nib values of map up nnv places. */
j = n0 - nib;
reverse(map+j, map + n0 + nnv);
reverse(map+j, map + j + nnv);
reverse(map + j + nnv, map + n0 + nnv);
i = n0 + nnv;
while(--i >= n0) {
j = i - nnv;
Lv0[incv*i] = Lv0[incv*j];
Uv0[incv*i] = Uv0[incv*j];
}
if ((x = X0)) {
i = n0 + nnv;
while(--i >= n0)
x[i] = x[i-nnv];
for(i = n0 - nnv; i < n0; ++i)
x[i] = 0.;
if ((hx0 = havex0)) {
for(i = n0 + nnv; --i >= n0; )
hx0[i] = hx0[i-nnv];
for(i = n0 - nnv;i < n0; ++i)
hx0[i] = 0;
}
}
Lv1 -= j = incv*nib;
Uv1 -= j;
}
else {
if ((map = asl->i.vmap)) {
j = asl->i.n_var0;
for(i = n0; i < n; ++i)
map[i] = -1;
}
if ((x = X0)) {
memset(x + n0, 0, nnv*sizeof(real));
if ((hx0 = havex0))
memset(hx0 + n0, 0, nnv);
}
}
#define vset(x,y) *x = y; x += incv;
for(i = 0; i < m0; ++i)
if ((j = cv[i])) {
if (j > nib0)
j += nnv;
*cc++ = i;
pcg = &Cgrd[i];
cg = 0;
while((cg1 = *pcg))
pcg = &(cg = cg1)->next;
*Cgrda++ = cg;
Lc = Lc0 + incv*i;
Uc = Uc0 + incc*i;
Lv = Lv0 + incv*--j;
Uv = Uv0 + incv*j;
a = *Lc;
b = *Uc;
*ck++ = nb = (a > negInfinity) + (b < Infinity);
if (nb == 0) {
/* change L <= v = _svar[j] <= U */
/* and -Infinity <= body <= Infinity into */
/* v1 = v - L >= 0, v2 = U - v >= 0, */
/* v3 - v4 = body, v3 >= 0, v4 >= 0, */
/* v1 complements v3, v2 complements v4 */
*Lc = *Uc = 0.;
v1 = n1++;
v2 = n1++;
v3 = n1++;
v4 = n1++;
for(k = 0; k < 4; ++k) {
vset(Lv1, 0.);
vset(Uv1, Infinity);
}
ncg[1].varno = v4;
ncg[1].coef = 1.;
ncg[1].next = 0;
ncg[0].varno = v3;
ncg[0].coef = -1.;
ncg[0].next = &ncg[1];
*pcg = ncg;
ncg += 2;
ncg[1].varno = v1;
ncg[1].coef = -1.;
ncg[1].next = 0;
ncg[0].varno = j;
ncg[0].coef = 1.;
ncg[0].next = &ncg[1];
*Lc1 = *Uc1 = *Lv;
Lc1 += incc;
Uc1 += incc;
*Cgrd1++ = ncg;
ncg += 2;
ncg[1].varno = v2;
ncg[1].coef = 1.;
ncg[1].next = 0;
ncg[0].varno = j;
ncg[0].coef = 1.;
ncg[0].next = &ncg[1];
*Lc1 = *Uc1 = *Uv;
Lc1 += incc;
Uc1 += incc;
*Cgrd1++ = ncg;
ncg += 2;
*ind1++ = v1;
*ind2++ = v3;
*ind1++ = v2;
*ind2++ = v4;
}
else {
/*nb == 1*/
v1 = j;
if (*Lv != 0.) {
/* For v = _svar[j], replace */
/* v >= a with v1 = v - a, v1 >= 0, or */
/* v <= b with v1 = b - v, v1 >= 0 */
v1 = n1++;
vset(Lv1, 0.);
vset(Uv1, Infinity);
ncg[1].varno = v1;
ncg[1].next = 0;
ncg[0].varno = j;
ncg[0].coef = 1.;
ncg[0].next = &ncg[1];
if (*Lv > negInfinity) {
ncg[1].coef = -1.;
*Lc1 = *Uc1 = *Lv;
}
else {
ncg[1].coef = 1.;
*Lc1 = *Uc1 = *Uv;
}
Lc1 += incc;
Uc1 += incc;
*Cgrd1++ = ncg;
ncg += 2;
}
ncg->varno = v2 = n1++;
ncg->next = 0;
vset(Lv1, 0.);
vset(Uv1, Infinity);
if (*Lv > negInfinity) {
ncg->coef = -1.;
*Uc = *Lc;
}
else {
ncg->coef = 1.;
*Lc = *Uc;
}
*pcg = ncg++;
*ind1++ = v1;
*ind2++ = v2;
}
}
#undef vset
if (map) {
ind1 -= ncc;
ind2 -= ncc;
mapinv = get_vminv_ASL(asl);
for(i = 0; i < ncc; ++i) {
ind1[i] = mapinv[ind1[i]];
ind2[i] = mapinv[ind2[i]];
}
}
if ((map = asl->i.cmap)) {
j = asl->i.n_con0;
Cgrd1 = asl->i.Cgrad0;
for(i = m0; i < m; ++i) {
map[i] = -1;
Cgrd1[j++] = Cgrd[i];
}
}
i = m0;
k = m - m0;
switch(asl->i.ASLtype) {
case ASL_read_pfg:
memset(((ASL_pfg*)asl)->P.cps + m0, 0, k*sizeof(ps_func));
cd = ((ASL_pfg*)asl)->I.con_de_;
goto have_cd;
case ASL_read_f:
case ASL_read_fg:
cd = ((ASL_fg*)asl)->I.con_de_;
have_cd:
while(i < m)
cd[i++].e = (expr*)&ZeroExpr;
break;
case ASL_read_fgh:
cd2 = ((ASL_fgh*)asl)->I.con2_de_;
goto have_cd2;
case ASL_read_pfgh:
memset(((ASL_pfgh*)asl)->P.cps + m0, 0, k*sizeof(ps_func2));
cd2 = ((ASL_pfgh*)asl)->I.con2_de_;
have_cd2:
while(i < m)
cd2[i++].e = (expr2*)&ZeroExpr;
}
}
Fints
mqpcheck_ASL(ASL *a, int co, fint **rowqp, Fint **colqp, real **delsqp)
{
typedef struct dispatch {
struct dispatch *next;
fint i, j, jend;
} dispatch;
ASL_fg *asl;
Fint *colq, *colq1, nelq;
Objrep *od, **pod;
Static SS, *S;
cde *c;
cgrad *cg, **cgp, **cgq, *cq;
dispatch *cd, *cd0, **cdisp, **cdisp0, *cdnext, **cdp;
dyad *d, *d1, **q, **q1, **q2, **qe;
expr *e;
expr_n *en;
fint *rowq, *rowq0, *rowq1, *s, *z;
fint ftn, i, icol, j, ncom, nv, nz, nz1;
int arrays, *cm, co0, pass, *vmi;
ograd *og, *og1, *og2, **ogp;
real *L, *U, *delsq, *delsq0, *delsq1, objadj, t, *x;
term *T;
ASL_CHECK(a, ASL_read_fg, "nqpcheck");
asl = (ASL_fg*)a;
if (co >= n_obj || co < -n_con)
return -3L;
od = 0;
co0 = co;
if (co >= 0) {
if ((pod = asl->i.Or) && (od = pod[co])) {
co = od->ico;
goto use_Cgrad;
}
else {
c = obj_de + co;
ogp = Ograd + co;
cgp = 0;
}
}
else {
co = -1 - co;
if ((cm = asl->i.cmap))
co = cm[co];
use_Cgrad:
c = con_de + co;
cgp = Cgrad;
cgp += co;
ogp = 0;
}
e = c->e;
if (e->op == f_OPNUM)
return 0;
memset(S = &SS, 0, sizeof(Static));
SS.asl = asl;
if (asl->i.vmap && !asl->i.vminv)
/* keep vminv from being lost in free_blocks(S) below */
get_vminv_ASL(a);
M1state1 = asl->i.Mbnext;
M1state2 = asl->i.Mblast;
nv = n_var;
s_x = x = (double *)Malloc(nv*(sizeof(double)+2*sizeof(fint)));
s_z = z = (fint *)(x + nv);
s_s = s = z + nv;
memset(s, 0, nv*sizeof(fint));
ftn = Fortran;
SS.nvinc = nv - asl->i.n_var0 + asl->i.nsufext[ASL_Sufkind_var];
delsq = delsq0 = delsq1 = 0; /* silence buggy "not-initialized" warning */
colq = colq1 = 0; /* ditto */
rowq = rowq0 = rowq1 = 0; /* ditto */
cd0 = 0; /* ditto */
cdisp = cdisp0 = 0; /* ditto */
if ((ncom = ncom0 + ncom1)) {
cterms = (term **)Malloc(ncom*sizeof(term*));
memset(cterms, 0, ncom*sizeof(term*));
}
arrays = 1;
if (rowqp)
*rowqp = 0;
else
arrays = 0;
if (colqp)
*colqp = 0;
else
arrays = 0;
if (delsqp)
*delsqp = 0;
else
arrays = 0;
zerodiv = 0;
if (!(T = ewalk(S, e)) || zerodiv) {
free_blocks(S);
free(x);
return T ? -2L : -1L;
}
if (cterms)
cterm_free(S, cterms + ncom);
if (od) {
cgq = &od->cg;
for(i = 0, cg = *cgp; cg; cg = cg->next) {
if (cg->coef != 0.)
++i;
}
if (i) {
cq = Malloc(i*sizeof(cgrad));
for(cg = *cgp; cg; cg = cg->next) {
*cgq = cq;
cgq = &cq->next;
*cq = *cg;
++cq;
}
}
*cgq = 0;
}
q = (dyad **)Malloc(nv*sizeof(dyad *));
qe = q + nv;
objadj = dsort(S, T, (ograd **)q, cgp, ogp, arrays);
nelq = nz = nz1 = 0;
/* In pass 0, we the count nonzeros in the lower triangle. */
/* In pass 1, we compute the lower triangle and use column dispatch */
/* (via the cdisp array) to copy the strict lower triangle to the */
/* strict upper triangle. This ensures symmetry. */
for(pass = 0; pass < 2; pass++) {
if (pass) {
nelq += nelq - nz1;
if (!nelq || !arrays)
break;
free(q);
delsq1 = delsq = (double *)Malloc(nelq*sizeof(real));
rowq1 = rowq = (fint *)Malloc(nelq*sizeof(fint));
colq1 = colq = (Fint *)Malloc((nv+2)*sizeof(Fint));
nelq = ftn;
delsq0 = delsq - ftn;
rowq0 = rowq - ftn;
q = (dyad **)Malloc(nv*(sizeof(dyad*)
+ sizeof(dispatch *)
+ sizeof(dispatch)));
qe = q + nv;
cdisp = (dispatch**) qe;
cdisp0 = cdisp - ftn;
memset(cdisp, 0, nv*sizeof(dispatch*));
cd0 = (dispatch *)(cdisp + nv);
}
memset(q, 0, nv*sizeof(dyad *));
for(d = T->Q; d; d = d->next) {
og = d->Rq;
og1 = d->Lq;
i = og->varno;
while(og1 && og1->varno < i)
og1 = og1->next;
if (og1) {
q1 = q + i;
*q1 = new_dyad(S, *q1, og, og1, 0);
}
og1 = d->Lq;
i = og1->varno;
while(og && og->varno < i)
og = og->next;
if (og) {
q1 = q + i;
*q1 = new_dyad(S, *q1, og1, og, 0);
}
}
vmi = asl->i.vmap ? get_vminv_ASL((ASL*)asl) : 0;
for(icol = 0, q1 = q; q1 < qe; ++icol, ++q1) {
if (pass) {
*colq++ = nelq;
for(cd = cdisp[icol]; cd; cd = cdnext) {
cdnext = cd->next;
s[i = cd->i]++;
x[z[nz++] = i] = delsq0[cd->j++];
if (cd->j < cd->jend) {
cdp = cdisp0 + rowq0[cd->j];
cd->next = *cdp;
*cdp = cd;
}
}
}
if ((d = *q1))
do {
og = d->Lq;
og1 = d->Rq;
t = og->coef;
for(; og1; og1 = og1->next) {
if (!s[i = og1->varno]++)
x[z[nz++] = i] =
t*og1->coef;
else
x[i] += t*og1->coef;
}
if ((og1 = og->next)) {
og2 = d->Rq;
while (og2->varno < og1->varno)
if (!(og2 = og2->next)) {
while((og1 = og->next))
og = og1;
break;
}
d->Rq = og2;
}
d1 = d->next;
if ((og = og->next)) {
i = og->varno;
if (pass) {
og1 = d->Rq;
while(og1->varno < i)
if (!(og1 = og1->next))
goto d_del;
d->Rq = og1;
}
d->Lq = og;
q2 = q + i;
d->next = *q2;
*q2 = d;
}
else {
d_del:
free_dyad(S, d);
}
}
while((d = d1));
if (nz) {
if (pass) {
if (nz > 1)
qsortv(z, nz, sizeof(fint), lcmp, NULL);
for(i = nz1 = 0; i < nz; i++) {
if ((t = x[j = z[i]])) {
*delsq++ = t;
if (vmi)
j = vmi[j];
*rowq++ = j + ftn;
nelq++;
z[nz1++] = j;
}
s[j] = 0;
}
for(i = 0; i < nz1; i++)
if ((j = z[i]) > icol && x[j]) {
cd0->i = icol;
cd0->j = colq[-1] + i;
cd0->jend = nelq;
cdp = cdisp + j;
cd0->next = *cdp;
*cdp = cd0++;
break;
}
nz = 0;
}
else {
while(nz > 0) {
s[i = z[--nz]] = 0;
if (x[i]) {
++nelq;
if (i == icol)
++nz1;
}
}
}
}
}
}
free(q);
free_blocks(S);
free(x);
if (od && od->cg)
M1record(od->cg);
if (nelq) {
if (arrays) {
/* allow one more for obj. adjustment */
*colq = colq[1] = nelq;
*rowqp = rowq1;
*colqp = colq1;
*delsqp = delsq1;
}
nelq -= ftn;
}
if (arrays) {
en = (expr_n *)mem(sizeof(expr_n));
en->op = f_OPNUM_ASL;
if (od) {
od->opify = qp_opify_ASL;
if ((t = od->c12) != 1.)
for(i = 0; i < nelq; ++i)
delsq1[i] *= t;
objadj = t*objadj + od->c0a;
for(i = 0, cg = *cgp; cg; cg = cg->next)
++i;
ogp = Ograd + co0;
og2 = i ? (ograd*)M1alloc(i*sizeof(ograd)) : 0;
for(cg = *cgp; cg; cg = cg->next) {
*ogp = og = og2++;
ogp = &og->next;
og->varno = cg->varno;
og->coef = t*cg->coef;
}
*ogp = 0;
c = obj_de + co0;
}
else if (cgp && objadj != 0.) {
if (Urhsx) {
L = LUrhs + co;
U = Urhsx + co;
}
else {
L = LUrhs + 2*co;
U = L + 1;
}
if (*L > negInfinity)
*L -= objadj;
if (*U < Infinity)
*U -= objadj;
objadj = 0;
}
en->v = objadj;
c->e = (expr *)en;
}
return nelq;
}
ssize_t
mqpcheckv_ASL(ASL *a, int co, QPinfo **QPIp, void **vp)
{
ASL_fg *asl;
AVL_Node *NQ, *NQ0;
AVL_Tree *AQ;
Memblock *mb;
QPinfo *qpi;
Objrep *od, **pod;
Static *S;
cde *c;
cgrad *cg, **cgp, **cgq, *cq;
dispatch *cd, *cd0, **cdisp, **cdisp0, *cdnext, **cdp;
dyad *d, *d1, **q, **q1, **q2;
expr *e;
expr_n *en;
int *cm, *colno, *qm, *rowq, *rowq0, *rowq1, *s, *vmi, *w, *z;
int arrays, co0, ftn, i, icol, icolf, j, ncol, ncom, nv, nva, nz, nz1, pass;
ograd *og, *og1, *og2, **ogp;
real *L, *U, *delsq, *delsq0, *delsq1, objadj, t, *x;
size_t *colq, *colq1, nelq, nelq0;
term *T;
ASL_CHECK(a, ASL_read_fg, "nqpcheck");
asl = (ASL_fg*)a;
if (co >= n_obj || co < -n_con)
return -3L;
colno = 0;
od = 0;
co0 = co;
if (co >= 0) {
if ((pod = asl->i.Or) && (od = pod[co])) {
co = od->ico;
goto use_Cgrad;
}
else {
c = obj_de + co;
ogp = Ograd + co;
cgp = 0;
}
}
else {
co = -1 - co;
if ((cm = asl->i.cmap))
co = cm[co];
use_Cgrad:
c = con_de + co;
cgp = Cgrad;
cgp += co;
ogp = 0;
}
e = c->e;
if (e->op == f_OPNUM)
return 0;
if (asl->i.vmap && !asl->i.vminv)
get_vminv_ASL(a);
nv = n_var;
ncom = ncom0 + ncom1;
if (!(S = *(Static**)vp)) {
i = asl->i.n_var0 + asl->i.nsufext[0];
if ((nva = nv) < i)
nva = i;
x = (double *)Malloc(nva*(sizeof(double)
+sizeof(dyad*)
+sizeof(ograd*)
+sizeof(dispatch*)
+sizeof(dispatch)
+3*sizeof(int))
+ sizeof(Memblock)
+ sizeof(Static));
mb = (Memblock*)(x + nva);
mb->prev = mb->next = 0;
S = (Static*)(mb + 1);
*vp = (void*)S;
memset(S, 0, sizeof(Static));
S->mb0 = S->mblast = mb;
s_x = x;
S->asl = asl;
s_q = q = (dyad**)(S+1);
S->oq = (ograd**)(q + nva);
S->cdisp = cdisp = (dispatch**)(S->oq + nva);
S->cd0 = cd0 = (dispatch*)(cdisp + nva);
s_z = z = (int*)(cd0 + nva);
s_s = s = z + nva;
S->w = (int*)(s + nva);
memset(s, 0, nva*sizeof(int));
memset(cdisp, 0, nva*sizeof(dispatch*));
memset(q, 0, nva*sizeof(dyad *));
memset(S->w, 0, nva*sizeof(int));
if (ncom) {
cterms = (term **)Malloc(ncom*(sizeof(term*)+sizeof(int)));
memset(cterms, 0, ncom*sizeof(term*));
S->zct = (int*)(cterms + ncom);
}
S->AQ = AVL_Tree_alloc2(0, vcomp, mymalloc, 0);
}
else {
q = s_q;
x = s_x;
z = s_z;
s = s_s;
cdisp = S->cdisp;
cd0 = S->cd0;
}
S->mb = mb = S->mb0;
S->v = &mb->x[0];
S->ve = &mb->x[Memblock_gulp];
w = S->w;
freedyad = 0;
freeog = 0;
freeterm = 0;
AQ = S->AQ;
ftn = Fortran;
cdisp0 = cdisp - ftn;
S->nvinc = nv - asl->i.n_var0 + asl->i.nsufext[ASL_Sufkind_var];
delsq = delsq0 = delsq1 = 0; /* silence buggy "not-initialized" warning */
colq = colq1 = 0; /* ditto */
rowq = rowq0 = rowq1 = 0; /* ditto */
arrays = 0;
if (QPIp) {
*QPIp = 0;
arrays = 1;
}
zerodiv = 0;
if (!(T = ewalk(S, e)) || zerodiv)
return T ? -2L : -1L;
if (S->nzct)
cterm_free(S);
if (od) {
cgq = &od->cg;
for(i = 0, cg = *cgp; cg; cg = cg->next) {
if (cg->coef != 0.)
++i;
}
if (i) {
cq = M1alloc(i*sizeof(cgrad));
for(cg = *cgp; cg; cg = cg->next) {
*cgq = cq;
cgq = &cq->next;
*cq = *cg;
++cq;
}
}
*cgq = 0;
}
objadj = dsort(S, T, S->oq, cgp, ogp, arrays);
icolf = nelq = ncol = nz = nz1 = 0;
qpi = 0;
/* In pass 0, we the count nonzeros in the lower triangle. */
/* In pass 1, we compute the lower triangle and use column dispatch */
/* (via the cdisp array) to copy the strict lower triangle to the */
/* strict upper triangle. This ensures symmetry. */
for(pass = 0; pass < 2; pass++) {
if (pass) {
if (!nelq)
break;
nelq += nelq - nz1; /* nz1 = number of diagonal elements */
if (!arrays) {
for(qm = (int*)AVL_first(AQ, &NQ); qm; ) {
*qm = 0;
NQ0 = NQ;
qm = (int*) AVL_next(&NQ);
AVL_delnode(AQ, &NQ0);
}
break;
}
qpi = *QPIp = (QPinfo*)Malloc(sizeof(QPinfo)
+ nelq*(sizeof(real) + sizeof(int))
+ ncol*sizeof(int)
+ (ncol + 1)*sizeof(size_t));
qpi->delsq = delsq = delsq1 = (double *)(qpi+1);
qpi->colbeg = colq = (size_t *)(delsq + nelq);
qpi->rowno = rowq = (int *)(colq + ncol + 1);
qpi->colno = colno = rowq + nelq;
qpi->nc = ncol;
qpi->nz = nelq;
nelq = ftn;
delsq0 = delsq - ftn;
rowq0 = rowq - ftn;
}
for(d = T->Q; d; d = d->next) {
og = d->Rq;
og1 = d->Lq;
i = og->varno;
while(og1 && og1->varno < i)
og1 = og1->next;
if (og1) {
q1 = q + i;
if (!w[i]) {
w[i] = 1;
AVL_vinsert(AQ, 0, (Element*)&w[i], 0);
}
*q1 = new_dyad(S, *q1, og, og1, 0);
}
og1 = d->Lq;
i = og1->varno;
while(og && og->varno < i)
og = og->next;
if (og) {
q1 = q + i;
if (!w[i]) {
w[i] = 1;
AVL_vinsert(AQ, 0, (Element*)&w[i], 0);
}
*q1 = new_dyad(S, *q1, og1, og, 0);
}
}
vmi = asl->i.vmap ? get_vminv_ASL((ASL*)asl) : 0;
for(qm = (int*)AVL_first(AQ, &NQ); qm; ) {
NQ0 = NQ;
icol = qm - w;
nelq0 = nelq;
if (pass) {
*qm = 0;
icolf = icol + ftn;
if ((cd = cdisp[icol])) {
cdisp[icol] = 0;
do {
cdnext = cd->next;
s[i = cd->i]++;
x[z[nz++] = i] = delsq0[cd->j++];
if (cd->j < cd->jend) {
cdp = cdisp0 + rowq0[cd->j];
cd->next = *cdp;
*cdp = cd;
}
} while((cd = cdnext));
}
}
if ((d = q[icol])) {
q[icol] = 0;
do {
og = d->Lq;
og1 = d->Rq;
t = og->coef;
for(; og1; og1 = og1->next) {
if (!s[i = og1->varno]++)
x[z[nz++] = i] =
t*og1->coef;
else
x[i] += t*og1->coef;
}
if ((og1 = og->next)) {
og2 = d->Rq;
while (og2->varno < og1->varno)
if (!(og2 = og2->next)) {
while((og1 = og->next))
og = og1;
goto get_d1;
}
d->Rq = og2;
}
get_d1:
d1 = d->next;
if ((og = og->next)) {
i = og->varno;
if (pass) {
og1 = d->Rq;
while(og1->varno < i)
if (!(og1 = og1->next))
goto d_del;
d->Rq = og1;
}
d->Lq = og;
q2 = q + i;
if (!w[i]) {
w[i] = 1;
AVL_vinsert(AQ, 0, (Element*)&w[i], 0);
}
d->next = *q2;
*q2 = d;
}
else {
d_del:
free_dyad(S, d);
}
}
while((d = d1));
}
if (nz) {
if (pass) {
if (nz > 1)
qsortv(z, nz, sizeof(int), lcmp, NULL);
for(i = nz1 = 0; i < nz; i++) {
if ((t = x[j = z[i]])) {
*delsq++ = t;
if (vmi)
j = vmi[j];
*rowq++ = j + ftn;
nelq++;
z[nz1++] = j;
}
s[j] = 0;
}
if (nelq > nelq0) {
*colq++ = nelq0;
*colno++ = icolf;
}
for(i = 0; i < nz1; i++)
if ((j = z[i]) > icol) {
cd0->i = icol;
cd0->j = nelq0 + i;
cd0->jend = nelq;
cdp = cdisp + j;
cd0->next = *cdp;
*cdp = cd0++;
break;
}
nz = 0;
}
else {
while(nz > 0) {
s[i = z[--nz]] = 0;
if (x[i]) {
++nelq;
if (i == icol)
++nz1;
else {
if (!w[i])
AVL_vinsert(AQ, 0, (Element*)&w[i], 0);
w[i] = 2;
}
}
}
if (nelq > nelq0 || w[icol] == 2)
++ncol;
}
}
else if (!pass && w[icol] == 2)
++ncol;
qm = (int*) AVL_next(&NQ);
if (pass)
AVL_delnode(AQ, &NQ0);
}
}
if (colq)
*colq = nelq;
if (arrays) {
if (nelq)
nelq -= ftn;
en = (expr_n *)mem(sizeof(expr_n));
en->op = f_OPNUM_ASL;
if (od) {
od->opify = qp_opify_ASL;
if ((t = od->c12) != 1.)
for(i = 0; i < nelq; ++i)
delsq1[i] *= t;
objadj = t*objadj + od->c0a;
for(i = 0, cg = *cgp; cg; cg = cg->next)
++i;
ogp = Ograd + co0;
og2 = i ? (ograd*)M1alloc(i*sizeof(ograd)) : 0;
for(cg = *cgp; cg; cg = cg->next) {
*ogp = og = og2++;
ogp = &og->next;
og->varno = cg->varno;
og->coef = t*cg->coef;
}
*ogp = 0;
c = obj_de + co0;
}
else if (cgp && objadj != 0.) {
if (Urhsx) {
L = LUrhs + co;
U = Urhsx + co;
}
else {
L = LUrhs + 2*co;
U = L + 1;
}
if (*L > negInfinity)
*L -= objadj;
if (*U < Infinity)
*U -= objadj;
objadj = 0.;
}
en->v = objadj;
c->e = (expr *)en;
}
return nelq;
}
void
obj1grd_ASL(ASL *a, int i, real *X, real *G, fint *nerror)
{
ASL_fg *asl;
Jmp_buf err_jmp0;
cde *d;
fint ne0;
int ij, j, *vmi, xksave, *z;
ograd *gr, **gr0;
real *Adjoints, *vscale;
size_t L;
static char who[] = "obj1grd";
NNOBJ_chk(a, i, who);
asl = (ASL_fg*)a;
if (!want_derivs)
No_derivs_ASL(who);
ne0 = -1;
if (nerror && (ne0 = *nerror) >= 0) {
err_jmp = &err_jmp0;
ij = __builtin_setjmp(err_jmp0.jb);
if (ij) {
*nerror = err_jmp0.err;
goto done;
}
}
errno = 0; /* in case f77 set errno opening files */
if (!asl->i.x_known)
x0_check_ASL(asl,X);
if (!asl->i.noxval || asl->i.noxval[i] != asl->i.nxval) {
xksave = asl->i.x_known;
asl->i.x_known = 1;
obj1val_ASL(a, i, X, nerror);
asl->i.x_known = xksave;
if (ne0 >= 0 && *nerror)
goto done;
}
if (asl->i.Derrs)
deriv_errchk_ASL(a, nerror, -(i+1), 1);
if (f_b)
funnelset_ASL(asl, f_b);
if (f_o)
funnelset_ASL(asl, f_o);
Adjoints = adjoints;
d = obj_de + i;
gr0 = Ograd + i;
for(gr = *gr0; gr; gr = gr->next)
Adjoints[gr->varno] = gr->coef;
if ((L = d->zaplen)) {
memset(adjoints_nv1, 0, L);
derprop(d->d);
}
if (zerograds) { /* sparse gradients */
z = zerograds[i];
while((i = *z++) >= 0)
G[i] = 0;
}
gr = *gr0;
vmi = 0;
if (asl->i.vmap)
vmi = get_vminv_ASL(a);
if ((vscale = asl->i.vscale)) {
if (vmi)
for(; gr; gr = gr->next) {
j = vmi[i = gr->varno];
G[j] = Adjoints[i] * vscale[j];
}
else
for(; gr; gr = gr->next) {
i = gr->varno;
G[i] = Adjoints[i] * vscale[i];
}
}
else if (vmi)
for(; gr; gr = gr->next) {
i = gr->varno;
G[vmi[i]] = Adjoints[i];
}
else
for(; gr; gr = gr->next) {
i = gr->varno;
G[i] = Adjoints[i];
}
done:
err_jmp = 0;
}
real
obj2val_ASL(ASL *a, int i, real *X, fint *nerror)
{
ASL_fgh *asl;
Jmp_buf err_jmp0;
cde *d;
expr *e1;
int ij, j1, kv, *vmi;
ograd *gr, **gr0;
real f, *vscale;
NNOBJ_chk(a, i, "obj2val");
asl = (ASL_fgh*)a;
if (nerror && *nerror >= 0) {
err_jmp = &err_jmp0;
ij = setjmp(err_jmp0.jb);
if ((*nerror = ij)) {
f = 0.;
goto done;
}
}
want_deriv = want_derivs;
errno = 0; /* in case f77 set errno opening files */
x2_check(X);
if (!asl->i.noxval)
asl->i.noxval = (int*)M1zapalloc(n_obj*sizeof(int));
co_index = -(i + 1);
if (!(x0kind & ASL_have_objcom)) {
if (ncom0 > combc)
comeval(asl, combc, ncom0);
x0kind |= ASL_have_objcom;
}
d = obj_de + i;
if (d->n_com1)
com1eval(asl, d->com11, d->n_com1);
gr0 = Ograd + i;
e1 = d->e;
f = (*e1->op)(e1 C_ASL);
asl->i.noxval[i] = asl->i.nxval;
kv = 0;
vmi = 0;
if ((vscale = asl->i.vscale))
kv = 2;
if (asl->i.vmap) {
vmi = get_vminv_ASL(a);
++kv;
}
gr = *gr0;
switch(kv) {
case 3:
for(; gr; gr = gr->next) {
j1 = vmi[gr->varno];
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 2:
for(; gr; gr = gr->next) {
j1 = gr->varno;
f += X[j1] * vscale[j1] * gr->coef;
}
break;
case 1:
for(; gr; gr = gr->next)
f += X[vmi[gr->varno]] * gr->coef;
break;
case 0:
for(; gr; gr = gr->next)
f += X[gr->varno] * gr->coef;
}
done:
err_jmp = 0;
return f;
}
