void ihd_clear_ASL(ASL_pfgh *asl) { Ihinfo *ihi; int i = asl->P.ihdcur; asl->P.ihdcur = 0; for(ihi = asl->P.ihi1; ihi->ihd <= i; ihi = ihi->next) { del_mblk(ihi->k, ihi->hest); ihi->hest = 0; } }
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]]; }
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_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; }