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;
}
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]];
}
sphes_setup_ASL(ASL *a, SputInfo **pspi, int nobj, int ow, int y, int uptri)
#endif
{
int i, j, k, khinfo, kog, kz, n, n1, nhinfo, no, noe, nqslim, nzc;
int *ui, *zc, *zci;
linarg *la, **lap, **lap1, **lape;
expr_v *v;
range *r, *r0, **rp, **rtodo;
real *ogsave, *s, *si, t;
ograd *og, *og1, **ogp, **ogpe;
Hesoprod *hop, *hop1, **otodo, **otodoi, **otodoj;
uHeswork *uhw, *uhwi, **utodo, **utodoi, **utodoj;
fint *hcolstarts, *hr, *hre, *hrownos, rv, *tf;
derp *D1;
de *d;
psg_elem *g, *ge;
ps_func *p, *pe;
ASL_pfgh *asl;
expr_va *valist;
expr_if *iflist;
SputInfo *spi, *spi1;
asl = pscheck_ASL(a, "sphes_setup");
if (!pspi)
pspi = &asl->i.sputinfo_;
if (nobj >= 0 && nobj < n_obj) {
ow = 0;
no = nobj;
noe = no + 1;
}
else {
nobj = -1;
no = noe = 0;
if (ow) {
noe = n_obj;
ow = 1;
}
}
if (y)
y = 1;
n = n_var;
if (spi = *pspi) {
if (spi->ow == ow && spi->y == y && spi->nobj == nobj
&& spi->uptri == uptri)
goto done;
del_mblk(spi->khinfo, spi);
if (spi->ulinc0)
del_mblk(spi->khinfob, spi->ulinc0);
*pspi = 0;
}
if (!asl->P.hes_setup_called)
(*asl->p.Hesset)(a, 1, 0, nlo, 0, nlc);
asl->P.hes_setup_called = 3;
asl->P.iflist = 0;
asl->P.valist = 0;
otodo = otodoi = asl->P.otodo;
rtodo = asl->P.rtodo;
utodo = utodoi = asl->P.utodo;
s = asl->P.dOscratch;
nqslim = n >> 3;
kz = htcl(2*sizeof(int)*n);
zc = (int*)new_mblk_ASL(a, kz);
zci = zc + n;
memset(zc, 0, n*sizeof(int));
n1 = n + 1;
khinfo = htcl((2*n + 30)*sizeof(fint) + sizeof(SputInfo));
spi = (SputInfo*)new_mblk_ASL(a, khinfo);
hcolstarts = (fint*)(spi+1);
hr = hrownos = hcolstarts + n1;
nhinfo = ((sizeof(Char*)<<khinfo) - sizeof(SputInfo)) / sizeof(fint);
hre = hr + (nhinfo - n1);
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;
}
ogsave = asl->P.npsgcomp ? saveog(asl, no, noe, y, &kog) : 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++)
if (og = g->og) {
do og->coef = 1; while(og = og->next);
og = g->og;
new_Hesoprod(asl, og, og, 1.);
}
}
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++)
if (og = g->og) {
do og->coef = 1; while(og = og->next);
og = g->og;
new_Hesoprod(asl, og, og, 1.);
}
}
for(i = 0; i < n; i++) {
nzc = 0;
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_prod1(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_prod1(asl, r, nobj, ow, y);
lap = r->lap;
lape = lap + r->n;
do {
la = *lap++;
if (la->v->aO)
for(og = la->nz; og; og = og->next)
if ((j = og->varno) <= i
&& !zc[j]++)
zci[nzc++] = j;
}
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;
while((j = og->varno) <= i) {
if (!zc[j]++)
zci[nzc++] = j;
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);
}
hcolstarts[i] = hr - hrownos;
if (nzc > hre - hr) {
k = khinfo++;
spi1 = (SputInfo*)new_mblk_ASL(a, khinfo);
tf = (fint*)(spi1+1);
memcpy(tf, hcolstarts, (hr - hcolstarts)*sizeof(fint));
del_mblk(k, spi);
spi = spi1;
hcolstarts = tf;
hrownos = tf + n1;
hr = hrownos + hcolstarts[i];
nhinfo = ((sizeof(Char*)<<khinfo) - sizeof(SputInfo))
/ sizeof(fint);
hre = hrownos + (nhinfo - n1);
}
if (nzc > nqslim) {
for(j = 0; j < n; j++)
if (zc[j])
zc[*hr++ = j] = 0;
}
else {
if (nzc > 1)
qsort(zci, nzc, sizeof(int), compar);
for(j = 0; j < nzc; j++)
zc[*hr++ = zci[j]] = 0;
}
}
for(valist = asl->P.valist; valist; valist = valist->next) {
D1 = valist->d0;
for(d = valist->L.d; d->e; d++)
d->dlast->next = D1;
}
for(iflist = asl->P.iflist; iflist; iflist = iflist->next)
iflist->dTlast->next = iflist->d0;
hcolstarts[n] = hr - hrownos;
if (j = Fortran) {
for(i = 0; i <= n; i++)
hcolstarts[i] += j;
i = (int)(hcolstarts[n] - j);
while(i)
hrownos[--i] += j;
}
spi->hcs[0] = hcolstarts;
spi->hrn[0] = hrownos;
spi->nod = -1;
spi->ulcend = 0;
spi->khinfo = khinfo;
spi->nobj = nobj;
spi->ow = ow;
spi->y = y;
spi->uptri = uptri;
*pspi = spi;
if (ogsave)
restog(asl, ogsave, no, noe, y, kog);
spi->ulinc0 = spi->ulinc = spi->ulcopy = 0;
done:
spi->hrownos = spi->hrn[0];
spi->hcolstarts = hcolstarts = spi->hcs[0];
rv = hcolstarts[n] - hcolstarts[0];
if (!uptri)
rv += bothadj(asl, spi);
return rv;
}
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;
}
