new_Hesoprod(ASL_pfgh *asl, ograd *L, ograd *R, real coef)
#endif
{
Hesoprod *h, **hp, *h1, *h2;
int kh;
Char **mblk_free;
ACQUIRE_DTOA_LOCK(HESOPROD_LOCK);
if (!(h = asl->P.hop_free)) {
mblk_free = asl->mblk_free;
kh = asl->P.khesoprod;
while(kh < 8 && !mblk_free[kh])
kh++;
asl->P.khesoprod = kh;
h = h1 = (Hesoprod *)new_mblk(kh);
h2 = h + (sizeof(Char*) << kh)/sizeof(Hesoprod) - 1;
while(h1 < h2)
h1 = h1->next = h1 + 1;
h1->next = 0;
}
asl->P.hop_free = h->next;
FREE_DTOA_LOCK(HESOPROD_LOCK);
h->left = L;
h->right = R;
h->coef = coef;
hp = asl->P.otodo + R->varno;
h->next = *hp;
*hp = h;
}
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;
}
saveog(ASL_pfgh *asl, int no, int noe, int y, int *kp)
#endif
{
real *o, *ogsave;
int i, k, n;
ps_func *p, *pe;
psg_elem *g, *ge;
ograd *og;
n = 0;
if (asl->P.nobjgroups)
for(i = no; i < noe; i++) {
p = asl->P.ops + i;
g = p->g;
for(ge = g + p->ng; g < ge; g++)
for(og = g->og; og; og = og->next)
n++;
}
if (asl->P.ncongroups && y) {
p = asl->P.cps;
for(pe = p + n_con; p < pe; p++)
for(g = p->g, ge = g + p->ng; g < ge; g++)
for(og = g->og; og; og = og->next)
n++;
}
if (!n)
return 0;
k = *kp = htcl(n*sizeof(real));
o = ogsave = (real*)new_mblk(k);
if (asl->P.nobjgroups)
for(i = no; i < noe; i++) {
p = asl->P.ops + i;
g = p->g;
for(ge = g + p->ng; g < ge; g++)
for(og = g->og; og; og = og->next)
*o++ = og->coef;
}
if (asl->P.ncongroups && y) {
p = asl->P.cps;
for(pe = p + n_con; p < pe; p++)
for(g = p->g, ge = g + p->ng; g < ge; g++)
for(og = g->og; og; og = og->next)
*o++ = og->coef;
}
return ogsave;
}
static real *
bigUmult(ASL_pfgh *asl, real *h, range *r, int nobj, real *ow, real *y)
{
real *s, t;
Umultinfo *u, *u0, *u1, *ue, **utodo, **utodoi;
int i, j, ku, n, nv;
int *imap, *iv;
linarg *la, **lap;
ograd *og;
s = asl->P.dOscratch;
utodo = utodoi = (Umultinfo**)asl->P.utodo;
n = r->n;
ku = htcl(n*sizeof(Umultinfo) + n_var*sizeof(int));
u = u0 = (Umultinfo*)new_mblk(ku);
imap = (int*)(u + n);
iv = r->ui;
nv = r->nv;
for(i = 0; i < nv; i++) {
imap[j = *iv++] = i;
utodo[j] = 0;
}
lap = r->lap;
for(i = 0; i < n; i++) {
la = *lap++;
u->v = la->v;
u->i = i;
u->og = u->og0 = og = la->nz;
utodoi = utodo + og->varno;
u->next = *utodoi;
*utodoi = u++;
}
ue = u;
iv = r->ui;
for(i = 0; i < nv; i++) {
utodoi = utodo + *iv++;
u1 = *utodoi;
*utodoi = 0;
for(u = u1; u; u = u->next)
s[u->i] = u->og->coef;
pshv_prod(r, nobj, ow, y);
h += i;
for(j = 0; j <= i; j++)
h[j] = 0.;
while((u = u1)) {
u1 = u->next;
s[u->i] = 0.;
if ((og = u->og->next)) {
u->og = og;
utodoi = utodo + og->varno;
u->next = *utodoi;
*utodoi = u;
}
}
for(u = u0; u < ue; u++)
if ((t = u->v->aO))
for(og = u->og0; og &&
(j = imap[og->varno]) <= i;
og = og->next)
h[j] += t*og->coef;
}
del_mblk(ku, u0);
return h + nv;
}
bothadj(ASL_pfgh *asl, SputInfo *spi)
#endif
{
/* Adjust to compute both triangles of Hessian */
fint i, i0, i1, j, k, k0, L, n, n1, nod, nz;
int kz, *z, *z0, *z1;
fint *hcs, *hr, *hre, *hrn, *hrn0, *ucs, *ulc, *uli;
n = n_var;
if ((nod = spi->nod) >= 0) {
if (!nod)
return 0;
goto done;
}
n1 = n + 1;
hcs = spi->hcolstarts;
nod = nz = hcs[n] - hcs[0];
hr = spi->hrownos - 1;
i = i0 = Fortran;
for(j = i + n; i < j; i++, hcs++) {
hr += k = hcs[1] - hcs[0];
if (k && *hr == i)
--nod;
}
/* nod = number of off-diagonal elements in upper triangle */
if (!(spi->nod = nod))
return 0; /* diagonal Hessian */
nz += nod;
spi->khinfob = kz = htcl((nz+2*(nod+n1))*sizeof(fint));
spi->ulinc0 = uli = (fint*)new_mblk(kz);
spi->hcs[1] = hcs = uli + n1;
spi->hrn[1] = hrn0 = hcs + n1;
spi->ulcopy0 = ulc = hrn0 + nz;
z = z0 = (int*)new_mblk(kz = htcl(n*sizeof(int)));
z1 = z - Fortran;
ucs = spi->hcs[0];
hre = spi->hrn[0];
for(i = i0; i < j; i++, ucs++) {
hr = hre;
hre += *z++ = ucs[1] - ucs[0];
while(hr < hre)
if ((k = *hr++) != i)
z1[k]++;
}
ucs = spi->hcs[0];
hre = spi->hrn[0];
*uli++ = 0;
for(i = k = i0; i < j; i++, ucs++) {
hr = hre;
hre += L = ucs[1] - ucs[0];
*hcs++ = k;
k0 = k - i0;
hrn = hrn0 + k0;
*uli++ = z1[i] - L;
k += z1[i];
z1[i] = k0 + L;
while(hr < hre)
if ((i1 = *hrn++ = *hr++) != i) {
*ulc++ = k0++;
hrn0[*ulc++ = z1[i1]++] = i;
}
}
*hcs = k;
spi->ulcend = ulc;
Del_mblk_ASL((ASL*)asl, kz, z0);
spi->ulinc = spi->ulinc0;
spi->ulcopy = spi->ulcopy0;
done:
spi->hrownos = spi->hrn[1];
spi->hcolstarts = spi->hcs[1];
return nod;
}
