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]]; }