void
hvpinit_ASL(ASL *a, int ndhmax, int nobj, real *ow, real *y)
{
ASL_pfgh *asl;
Ihinfo *ihi;
range *r;
real *h, *s, *si;
int i, ihc, n1;
linarg **lap, **lap1, **lape;
expr_v *v;
ASL_CHECK(a, ASL_read_pfgh, "xvpinit");
asl = (ASL_pfgh*)a;
xpsg_check_ASL(asl, nobj, ow, y);
asl->P.nhvprod = 0;
if (!asl->P.hes_setup_called)
(*asl->p.Hesset)(a, 1, 0, nlo, 0, nlc);
ihc = 0;
if (ndhmax > asl->P.ihdmax)
ndhmax = asl->P.ihdmax;
if ((asl->P.ndhmax = ndhmax) <= 0)
goto done;
if (!(ihi = asl->P.ihi1) || ndhmax < asl->P.ihdmin)
return;
if (nobj < 0 || nobj >= n_obj)
nobj = -1;
s = asl->P.dOscratch;
for(ihc = 0; ihi->ihd <= ndhmax; ihi = ihi->next) {
ihc = ihi->ihd;
ihi->hest = h = (real *)new_mblk(ihi->k);
for(r = ihi->r; r; r = r->rlist.prev) {
r->hest = h;
if ((n1 = r->n) < r->nv) {
si = s;
lape = lap = r->lap;
for(i = 0; i < n1; i++) {
*si = 1.;
pshv_prod(r, nobj, ow, y);
*si++ = 0;
lape++;
lap1 = lap;
do {
v = (*lap1++)->v;
*h++ = v->aO;
}
while(lap1 < lape);
}
}
else
h = bigUmult(asl, h, r, nobj, ow, y);
}
}
done:
asl->P.ihdcur = ihc;
}
sphes_ASL(ASL *a, SputInfo **pspi, real *H, int nobj, real *ow, real *y)
#endif
{
/* sparse upper triangle of Hessian */
int i, j, k, kh, n, no, noe, *ui;
linarg *la, **lap, **lap1, **lape;
expr_v *v;
range *r, *r0, **rp, **rtodo;
real *Hi, *H0, *H00;
real *cscale, *owi, *s, *si, t, t1, *vsc0, *vsc1, *vsc, *y1;
ograd *og, *og1, **ogp, **ogpe;
Hesoprod *hop, *hop1, **otodo, **otodoi, **otodoj;
uHeswork *uhw, *uhwi, **utodo, **utodoi, **utodoj;
fint *hcs, *hr, *uli;
psg_elem *g, *ge;
ps_func *p, *pe;
ASL_pfgh *asl;
SputInfo *spi;
asl = pscheck_ASL(a, "sputhes");
xpsg_check_ASL(asl, nobj, ow, y);
if (!pspi)
pspi = &a->i.sputinfo_;
i = j = 0;
if (y)
j = 1;
if (nobj >= 0 && nobj < n_obj) {
no = nobj;
noe = no + 1;
owi = ow ? ow + no : &edag_one_ASL;
ow = 0;
}
else {
nobj = -1;
no = noe = 0;
if (owi = ow) {
noe = n_obj;
i = 1;
}
}
if (asl->P.hes_setup_called != 3)
sphes_setup_ASL(a, pspi, nobj, ow != 0, y != 0, 0);
spi = *pspi;
if (spi->nobj != nobj || spi->ow != i || spi->y != j) {
fprintf(Stderr,
"\nsphes() call inconsistent with previous sphsetup()\n");
exit(1);
}
otodo = otodoi = asl->P.otodo;
rtodo = asl->P.rtodo;
utodo = utodoi = asl->P.utodo;
s = asl->P.dOscratch;
n = n_var;
Hi = H0 = (real*)new_mblk_ASL(a, kh = htcl(n*sizeof(real)));
memset(Hi, 0, n * sizeof(real));
H0 -= Fortran;
r0 = (range*)&asl->P.rlist;
for(r = asl->P.rlist.next; r != r0; r = r->rlist.next) {
if ((j = r->n) <= 0)
continue;
i = r->lasttermno;
rp = rtodo + i;
r->hnext = *rp;
*rp = r;
}
if (asl->P.nobjgroups)
for(; no < noe; no++)
if (t = *owi++) {
p = asl->P.ops + no;
g = p->g;
for(ge = g + p->ng; g < ge; g++)
if (t1 = t*g->g2)
for(og = g->og; og; og = og->next)
if (og->coef) {
new_Hesoprod(asl, og, og, t1);
break;
}
}
if (asl->P.ncongroups && y) {
cscale = asl->i.lscale;
p = asl->P.cps;
y1 = y;
for(pe = p + n_con; p < pe; p++, y1++)
if (t = cscale ? *cscale++ * *y1 : *y1)
for(g = p->g, ge = g + p->ng; g < ge; g++)
if (t1 = t*g->g2)
for(og = g->og; og; og = og->next)
if (og->coef) {
new_Hesoprod(asl, og, og, t1);
break;
}
}
hcs = spi->hcs[0];
hr = spi->hrn[0];
uli = spi->ulinc;
H00 = H;
if (vsc = asl->i.vscale) {
vsc0 = vsc - Fortran;
vsc1 = vsc;
}
for(i = 0; i < n; i++) {
rp = rtodo;
uhwi = *utodoi;
*utodoi++ = 0;
while(r = *rp) {
rp = &r->hnext;
lap = r->lap;
lape = lap + r->n;
if (r->n >= r->nv) {
k = htcl(sizeof(uHeswork)
+ (r->n - 1)*sizeof(ograd*));
uhw = (uHeswork *)new_mblk_ASL(a, k);
uhw->k = k;
uhw->next = uhwi;
uhwi = uhw;
uhw->r = r;
uhw->ui = ui = r->ui;
uhw->uie = ui + r->nv;
ogp = uhw->ogp;
while(lap < lape)
*ogp++ = (*lap++)->nz;
}
else {
si = s;
while(lap < lape) {
*si = 1;
pshv_prod_ASL(asl, r, nobj, ow, y);
*si++ = 0;
lap1 = lap++;
la = *lap1++;
og = la->nz;
v = la->v;
if (t = v->aO)
new_Hesoprod(asl,og,og,t);
while(lap1 < lape) {
la = *lap1++;
v = la->v;
if (t = v->aO) {
og1 = la->nz;
new_Hesoprod(asl,og,og1,t);
new_Hesoprod(asl,og1,og,t);
}
}
}
}
}
*rtodo++ = 0; /* reset */
while(uhw = uhwi) {
uhwi = uhwi->next;
si = s;
ogp = uhw->ogp;
r = uhw->r;
ogpe = ogp + r->n;
si = s;
do {
if ((og = *ogp) && og->varno == i)
*si = og->coef;
si++;
} while(++ogp < ogpe);
pshv_prod_ASL(asl, r, nobj, ow, y);
lap = r->lap;
lape = lap + r->n;
do {
la = *lap++;
if (t = la->v->aO)
for(og = la->nz; og; og = og->next)
if ((j = og->varno) <= i)
Hi[j] += t*og->coef;
}
while(lap < lape);
ogp = uhw->ogp;
si = s;
do {
if ((og = *ogp) && og->varno == i) {
*si = 0;
*ogp = og->next;
}
si++;
} while(++ogp < ogpe);
if ((ui = ++uhw->ui) >= uhw->uie)
del_mblk(uhw->k, uhw);
else {
utodoj = utodo + *ui;
uhw->next = *utodoj;
*utodoj = uhw;
}
}
hop1 = *otodoi;
*otodoi++ = 0;
while(hop = hop1) {
hop1 = hop->next;
og = hop->left;
og1 = hop->right;
t = hop->coef * og1->coef;
while((j = og->varno) <= i) {
Hi[j] += t*og->coef;
if (!(og = og->next))
break;
}
if (og = og1->next) {
hop->right = og;
otodoj = otodo + og->varno;
hop->next = *otodoj;
*otodoj = hop;
}
else
del_Hesoprod(asl,hop);
}
k = (int)(hcs[1] - hcs[0]);
hcs++;
if (uli)
H += *uli++;
if (vsc) {
t = *vsc1++;
while(--k >= 0) {
j = (int)*hr++;
*H++ = t * vsc0[j] * H0[j];
H0[j] = 0;
}
}
else
while(--k >= 0) {
*H++ = H0[j = (int)*hr++];
H0[j] = 0;
}
}
del_mblk(kh, Hi);
if (hr = spi->ulcopy)
for(uli = spi->ulcend; hr < uli; hr += 2)
H00[hr[1]] = H00[hr[0]];
}
