/************************************************************************* * This function performs k-way refinement **************************************************************************/ void MCGreedy_KWayEdgeBalanceHorizontal(CtrlType *ctrl, GraphType *graph, int nparts, float *ubvec, int npasses) { int i, ii, /*iii,*/ j, /*jj,*/ k, /*l,*/ pass, nvtxs, ncon, nbnd, myndegrees, oldgain, gain, nmoves; int from, me, to, oldcut; idxtype *xadj, *adjncy, *adjwgt; idxtype *where, *perm, *bndptr, *bndind, *moved; EDegreeType *myedegrees; RInfoType *myrinfo; PQueueType queue; float *npwgts, *nvwgt, *minwgt, *maxwgt, tvec[MAXNCON]; nvtxs = graph->nvtxs; ncon = graph->ncon; xadj = graph->xadj; adjncy = graph->adjncy; adjwgt = graph->adjwgt; bndind = graph->bndind; bndptr = graph->bndptr; where = graph->where; npwgts = graph->npwgts; /* Setup the weight intervals of the various subdomains */ minwgt = fwspacemalloc(ctrl, ncon*nparts); maxwgt = fwspacemalloc(ctrl, ncon*nparts); for (i=0; i<nparts; i++) { for (j=0; j<ncon; j++) { maxwgt[i*ncon+j] = ubvec[j]/nparts; minwgt[i*ncon+j] = 1.0/(ubvec[j]*nparts); } } perm = idxwspacemalloc(ctrl, nvtxs); moved = idxwspacemalloc(ctrl, nvtxs); PQueueInit(ctrl, &queue, nvtxs, graph->adjwgtsum[idxamax(nvtxs, graph->adjwgtsum)]); if (ctrl->dbglvl&DBG_REFINE) { printf("Partitions: [%5.4f %5.4f], Nv-Nb[%6d %6d]. Cut: %6d, LB: ", npwgts[samin(ncon*nparts, npwgts)], npwgts[samax(ncon*nparts, npwgts)], graph->nvtxs, graph->nbnd, graph->mincut); ComputeHKWayLoadImbalance(ncon, nparts, npwgts, tvec); for (i=0; i<ncon; i++) printf("%.3f ", tvec[i]); printf("[B]\n"); } for (pass=0; pass<npasses; pass++) { ASSERT(ComputeCut(graph, where) == graph->mincut); /* Check to see if things are out of balance, given the tolerance */ if (MocIsHBalanced(ncon, nparts, npwgts, ubvec)) break; PQueueReset(&queue); idxset(nvtxs, -1, moved); oldcut = graph->mincut; nbnd = graph->nbnd; RandomPermute(nbnd, perm, 1); for (ii=0; ii<nbnd; ii++) { i = bndind[perm[ii]]; PQueueInsert(&queue, i, graph->rinfo[i].ed - graph->rinfo[i].id); moved[i] = 2; } nmoves = 0; for (;;) { if ((i = PQueueGetMax(&queue)) == -1) break; moved[i] = 1; myrinfo = graph->rinfo+i; from = where[i]; nvwgt = graph->nvwgt+i*ncon; if (AreAllHVwgtsBelow(ncon, 1.0, npwgts+from*ncon, -1.0, nvwgt, minwgt+from*ncon)) continue; /* This cannot be moved! */ myedegrees = myrinfo->edegrees; myndegrees = myrinfo->ndegrees; for (k=0; k<myndegrees; k++) { to = myedegrees[k].pid; if (IsHBalanceBetterFT(ncon, nparts, npwgts+from*ncon, npwgts+to*ncon, nvwgt, ubvec)) break; } if (k == myndegrees) continue; /* break out if you did not find a candidate */ for (j=k+1; j<myndegrees; j++) { to = myedegrees[j].pid; if (IsHBalanceBetterTT(ncon, nparts, npwgts+myedegrees[k].pid*ncon, npwgts+to*ncon, nvwgt, ubvec)) k = j; } to = myedegrees[k].pid; j = 0; if (!AreAllHVwgtsBelow(ncon, 1.0, npwgts+from*ncon, 0.0, nvwgt, maxwgt+from*ncon)) j++; if (myedegrees[k].ed-myrinfo->id >= 0) j++; if (!AreAllHVwgtsAbove(ncon, 1.0, npwgts+to*ncon, 0.0, nvwgt, minwgt+to*ncon) && AreAllHVwgtsBelow(ncon, 1.0, npwgts+to*ncon, 1.0, nvwgt, maxwgt+to*ncon)) j++; if (j == 0) continue; /* DELETE if (myedegrees[k].ed-myrinfo->id < 0 && AreAllHVwgtsBelow(ncon, 1.0, npwgts+from*ncon, 0.0, nvwgt, maxwgt+from*ncon) && AreAllHVwgtsAbove(ncon, 1.0, npwgts+to*ncon, 0.0, nvwgt, minwgt+to*ncon) && AreAllHVwgtsBelow(ncon, 1.0, npwgts+to*ncon, 1.0, nvwgt, maxwgt+to*ncon)) continue; */ /*===================================================================== * If we got here, we can now move the vertex from 'from' to 'to' *======================================================================*/ graph->mincut -= myedegrees[k].ed-myrinfo->id; IFSET(ctrl->dbglvl, DBG_MOVEINFO, printf("\t\tMoving %6d to %3d. Gain: %4d. Cut: %6d\n", i, to, myedegrees[k].ed-myrinfo->id, graph->mincut)); /* Update where, weight, and ID/ED information of the vertex you moved */ saxpy(ncon, 1.0, nvwgt, 1, npwgts+to*ncon, 1); saxpy(ncon, -1.0, nvwgt, 1, npwgts+from*ncon, 1); where[i] = to; myrinfo->ed += myrinfo->id-myedegrees[k].ed; SWAP(myrinfo->id, myedegrees[k].ed, j); if (myedegrees[k].ed == 0) myedegrees[k] = myedegrees[--myrinfo->ndegrees]; else myedegrees[k].pid = from; if (myrinfo->ed == 0) BNDDelete(nbnd, bndind, bndptr, i); /* Update the degrees of adjacent vertices */ for (j=xadj[i]; j<xadj[i+1]; j++) { ii = adjncy[j]; me = where[ii]; myrinfo = graph->rinfo+ii; if (myrinfo->edegrees == NULL) { myrinfo->edegrees = ctrl->wspace.edegrees+ctrl->wspace.cdegree; ctrl->wspace.cdegree += xadj[ii+1]-xadj[ii]; } myedegrees = myrinfo->edegrees; ASSERT(CheckRInfo(myrinfo)); oldgain = (myrinfo->ed-myrinfo->id); if (me == from) { INC_DEC(myrinfo->ed, myrinfo->id, adjwgt[j]); if (myrinfo->ed > 0 && bndptr[ii] == -1) BNDInsert(nbnd, bndind, bndptr, ii); } else if (me == to) { INC_DEC(myrinfo->id, myrinfo->ed, adjwgt[j]); if (myrinfo->ed == 0 && bndptr[ii] != -1) BNDDelete(nbnd, bndind, bndptr, ii); } /* Remove contribution from the .ed of 'from' */ if (me != from) { for (k=0; k<myrinfo->ndegrees; k++) { if (myedegrees[k].pid == from) { if (myedegrees[k].ed == adjwgt[j]) myedegrees[k] = myedegrees[--myrinfo->ndegrees]; else myedegrees[k].ed -= adjwgt[j]; break; } } } /* Add contribution to the .ed of 'to' */ if (me != to) { for (k=0; k<myrinfo->ndegrees; k++) { if (myedegrees[k].pid == to) { myedegrees[k].ed += adjwgt[j]; break; } } if (k == myrinfo->ndegrees) { myedegrees[myrinfo->ndegrees].pid = to; myedegrees[myrinfo->ndegrees++].ed = adjwgt[j]; } } /* Update the queue */ if (me == to || me == from) { gain = myrinfo->ed-myrinfo->id; if (moved[ii] == 2) { if (myrinfo->ed > 0) PQueueUpdate(&queue, ii, oldgain, gain); else { PQueueDelete(&queue, ii, oldgain); moved[ii] = -1; } } else if (moved[ii] == -1 && myrinfo->ed > 0) { PQueueInsert(&queue, ii, gain); moved[ii] = 2; } } ASSERT(myrinfo->ndegrees <= xadj[ii+1]-xadj[ii]); ASSERT(CheckRInfo(myrinfo)); } nmoves++; } graph->nbnd = nbnd; if (ctrl->dbglvl&DBG_REFINE) { printf("\t [%5.4f %5.4f], Nb: %6d, Nmoves: %5d, Cut: %6d, LB: ", npwgts[samin(ncon*nparts, npwgts)], npwgts[samax(ncon*nparts, npwgts)], nbnd, nmoves, graph->mincut); ComputeHKWayLoadImbalance(ncon, nparts, npwgts, tvec); for (i=0; i<ncon; i++) printf("%.3f ", tvec[i]); printf("\n"); } if (nmoves == 0) break; } PQueueFree(ctrl, &queue); fwspacefree(ctrl, ncon*nparts); fwspacefree(ctrl, ncon*nparts); idxwspacefree(ctrl, nvtxs); idxwspacefree(ctrl, nvtxs); }
int local_search(CtrlType *ctrl, GraphType *graph, int nparts, int chain_length, idxtype *w, float *tpwgts, float ubfactor) //return # of points moved { int nvtxs, nedges, nbnd, me, i, j, k, s, ii; idxtype *sum, *squared_sum, *xadj, *adjncy, *adjwgt, *where, *bndptr, *bndind; float change, obj, epsilon, **kDist, *accum_change; int moves, actual_length, *mark, fidx, loopend; Chains *chain; nedges = graph->nedges; nvtxs = graph->nvtxs; xadj = graph->xadj; adjncy = graph->adjncy; adjwgt = graph->adjwgt; where = graph->where; nbnd = graph->nbnd; bndind = graph->bndind; bndptr = graph->bndptr; if(boundary_points == 1) loopend = nbnd; else loopend = nvtxs; chain = chainmalloc(chain_length, "Local_search: local search chain"); mark = ismalloc(loopend, 0 , "Local_search: mark"); sum = idxsmalloc(nparts,0, "Local_search: weight sum"); squared_sum = idxsmalloc(nparts,0,"Local_search: weight squared sum"); kDist = f2malloc(loopend, nparts, "Local_search: distance matrix"); accum_change = fmalloc(chain_length+1,"Local_search: accumulated change"); //initialization for (i = 0; i<nparts; i++) sum[i] = squared_sum[i] = 0; for (i = 0; i<loopend; i++) for (j = 0; j<nparts; j++) kDist[i][j] = 0; for (i = 0; i<chain_length+1; i++) accum_change[i] = 0; obj = 0; moves = 0; epsilon =.0001; actual_length = chain_length; for (i=0; i<nvtxs; i++) sum[where[i]] += w[i]; for (i=0; i<nvtxs; i++){ me = where[i]; for (j=xadj[i]; j<xadj[i+1]; j++) if (where[adjncy[j]] == me) squared_sum[me] += adjwgt[j]; } //the diagonal entries won't affect the result so diagonal's assumed zero //for (i=0; i<nvtxs; i++) for (ii=0; ii<loopend; ii++){ if (boundary_points == 1) i = bndind[ii]; else i = ii; for (j=xadj[i]; j<xadj[i+1]; j++) //kDist[i][where[adjncy[j]]] += 1.0*adjwgt[j]/w[i]; kDist[ii][where[adjncy[j]]] += 1.0*adjwgt[j]/w[i]; } for (k=0; k<nparts; k++) if (sum[k] >0) //for (i=0; i<nvtxs; i++) for (ii=0; ii<loopend; ii++) //kDist[i][k] = squared_sum[k]/(1.0*sum[k]*sum[k]) - 2*kDist[i][k]/sum[k]; kDist[ii][k] = squared_sum[k]/(1.0*sum[k]*sum[k]) - 2*kDist[ii][k]/sum[k]; for (i=0; i<nparts; i++) if (sum[i] >0) obj += squared_sum[i]*1.0/sum[i]; for (i=0; i<chain_length; i++) { float tempMinChange, tempchange, temp_q; int tempid, tempMoveTo, from, to, tempbndind; tempMinChange = obj; tempchange =0; tempid =0; tempMoveTo = where[tempid]; tempbndind =0; //for (j=0; j<nvtxs; j++) for (ii=0; ii<loopend; ii++){ if (boundary_points == 1) j = bndind[ii]; else j = ii; if (mark[ii] ==0){ me = where[j]; if (sum[me] > w[j]) // if this cluster where j belongs is not a singleton for (k=0; k<nparts; k++) if (k != me){ //tempchange = -kDist[j][me]*sum[me]*w[j]/(sum[me]-w[j]) + kDist[j][k]*sum[k]*w[j]/(sum[k]+w[j]); tempchange = -kDist[ii][me]*sum[me]*w[j]/(sum[me]-w[j]) + kDist[ii][k]*sum[k]*w[j]/(sum[k]+w[j]); if (tempchange < tempMinChange){ tempMinChange = tempchange; tempid = j; tempbndind = ii; tempMoveTo = k; } } } } if ((tempMoveTo == where[tempid]) || (mark[tempbndind] >0)){ actual_length = i; break; } else{ // record which point is moved from its original cluster to new cluster chain[i].point = tempid; chain[i].from = where[tempid]; chain[i].to = tempMoveTo; chain[i].change = tempMinChange; //mark the point moved mark[tempbndind] = 1; // update info accum_change[i+1] = accum_change[i] + tempMinChange; from = chain[i].from; to = chain[i].to; where[tempid] = to; sum[from] -= w[tempid]; sum[to] += w[tempid]; for (j=xadj[tempid]; j<xadj[tempid+1]; j++) if (where[adjncy[j]] == from) squared_sum[from] -= 2*adjwgt[j]; //for (s=0; s<nvtxs; s++){ for (ii=0; ii<loopend; ii++){ //kDist[s][from] = 0; kDist[ii][from] = 0; if(boundary_points == 1) s = bndind[ii]; else s = ii; for (j=xadj[s]; j<xadj[s+1]; j++) if (where[adjncy[j]] == from) //kDist[s][from] += adjwgt[j]*1.0/w[s]; kDist[ii][from] += adjwgt[j]*1.0/w[s]; } temp_q = squared_sum[from]/(1.0*sum[from]*sum[from]); //for (s=0; s<nvtxs; s++) for (ii=0; ii<loopend; ii++) kDist[ii][from] = temp_q - 2*kDist[ii][from]/sum[from]; for (j=xadj[tempid]; j<xadj[tempid+1]; j++) if (where[adjncy[j]] == to) squared_sum[to] += 2*adjwgt[j]; //for (s=0; s<nvtxs; s++){ for (ii=0; ii<loopend; ii++){ //kDist[s][to] = 0; kDist[ii][to] = 0; if(boundary_points == 1) s = bndind[ii]; else s = ii; for (j=xadj[s]; j<xadj[s+1]; j++) if (where[adjncy[j]] == to) //kDist[s][to] += adjwgt[j]*1.0/w[s]; kDist[ii][to] += adjwgt[j]*1.0/w[s]; } temp_q = squared_sum[to]/(1.0*sum[to]*sum[to]); //for (s=0; s<nvtxs; s++) for (ii=0; ii<loopend; ii++) //kDist[s][to] = temp_q - 2*kDist[s][to]/sum[to]; kDist[ii][to] = temp_q - 2*kDist[ii][to]/sum[to]; } } fidx = samin(actual_length, accum_change); if (accum_change[fidx] < -epsilon * obj){ for (i= fidx+1; i<=actual_length; i++) where[chain[i-1].point] = chain[i-1].from; moves = fidx; change = accum_change[fidx]; } else{ for (i= 0; i<actual_length; i++) where[chain[i].point] = chain[i].from; moves = 0; change = 0; } free(sum); free(squared_sum);free(accum_change); free(chain); free(mark); //for (i= 0; i<nvtxs; i++) for (i= 0; i<loopend; i++) free(kDist[i]); free(kDist); return moves; }
/************************************************************************* * This function performs k-way refinement **************************************************************************/ void MCRandom_KWayEdgeRefineHorizontal(CtrlType *ctrl, GraphType *graph, int nparts, float *orgubvec, int npasses) { int i, ii, iii, j, /*jj,*/ k, /*l,*/ pass, nvtxs, ncon, nmoves, nbnd, myndegrees, same; int from, me, to, oldcut, gain; idxtype *xadj, *adjncy, *adjwgt; idxtype *where, *perm, *bndptr, *bndind; EDegreeType *myedegrees; RInfoType *myrinfo; float *npwgts, *nvwgt, *minwgt, *maxwgt, maxlb, minlb, ubvec[MAXNCON], tvec[MAXNCON]; nvtxs = graph->nvtxs; ncon = graph->ncon; xadj = graph->xadj; adjncy = graph->adjncy; adjwgt = graph->adjwgt; bndptr = graph->bndptr; bndind = graph->bndind; where = graph->where; npwgts = graph->npwgts; /* Setup the weight intervals of the various subdomains */ minwgt = fwspacemalloc(ctrl, nparts*ncon); maxwgt = fwspacemalloc(ctrl, nparts*ncon); /* See if the orgubvec consists of identical constraints */ maxlb = minlb = orgubvec[0]; for (i=1; i<ncon; i++) { minlb = (orgubvec[i] < minlb ? orgubvec[i] : minlb); maxlb = (orgubvec[i] > maxlb ? orgubvec[i] : maxlb); } same = (fabs(maxlb-minlb) < .01 ? 1 : 0); /* Let's not get very optimistic. Let Balancing do the work */ ComputeHKWayLoadImbalance(ncon, nparts, npwgts, ubvec); for (i=0; i<ncon; i++) ubvec[i] = amax(ubvec[i], orgubvec[i]); if (!same) { for (i=0; i<nparts; i++) { for (j=0; j<ncon; j++) { maxwgt[i*ncon+j] = ubvec[j]/nparts; minwgt[i*ncon+j] = 1.0/(ubvec[j]*nparts); } } } else { maxlb = ubvec[0]; for (i=1; i<ncon; i++) maxlb = (ubvec[i] > maxlb ? ubvec[i] : maxlb); for (i=0; i<nparts; i++) { for (j=0; j<ncon; j++) { maxwgt[i*ncon+j] = maxlb/nparts; minwgt[i*ncon+j] = 1.0/(maxlb*nparts); } } } perm = idxwspacemalloc(ctrl, nvtxs); if (ctrl->dbglvl&DBG_REFINE) { printf("Partitions: [%5.4f %5.4f], Nv-Nb[%6d %6d]. Cut: %6d, LB: ", npwgts[samin(ncon*nparts, npwgts)], npwgts[samax(ncon*nparts, npwgts)], graph->nvtxs, graph->nbnd, graph->mincut); ComputeHKWayLoadImbalance(ncon, nparts, npwgts, tvec); for (i=0; i<ncon; i++) printf("%.3f ", tvec[i]); printf("\n"); } for (pass=0; pass<npasses; pass++) { ASSERT(ComputeCut(graph, where) == graph->mincut); oldcut = graph->mincut; nbnd = graph->nbnd; RandomPermute(nbnd, perm, 1); for (nmoves=iii=0; iii<graph->nbnd; iii++) { ii = perm[iii]; if (ii >= nbnd) continue; i = bndind[ii]; myrinfo = graph->rinfo+i; if (myrinfo->ed >= myrinfo->id) { /* Total ED is too high */ from = where[i]; nvwgt = graph->nvwgt+i*ncon; if (myrinfo->id > 0 && AreAllHVwgtsBelow(ncon, 1.0, npwgts+from*ncon, -1.0, nvwgt, minwgt+from*ncon)) continue; /* This cannot be moved! */ myedegrees = myrinfo->edegrees; myndegrees = myrinfo->ndegrees; for (k=0; k<myndegrees; k++) { to = myedegrees[k].pid; gain = myedegrees[k].ed - myrinfo->id; if (gain >= 0 && (AreAllHVwgtsBelow(ncon, 1.0, npwgts+to*ncon, 1.0, nvwgt, maxwgt+to*ncon) || IsHBalanceBetterFT(ncon, nparts, npwgts+from*ncon, npwgts+to*ncon, nvwgt, ubvec))) break; } if (k == myndegrees) continue; /* break out if you did not find a candidate */ for (j=k+1; j<myndegrees; j++) { to = myedegrees[j].pid; if ((myedegrees[j].ed > myedegrees[k].ed && (AreAllHVwgtsBelow(ncon, 1.0, npwgts+to*ncon, 1.0, nvwgt, maxwgt+to*ncon) || IsHBalanceBetterFT(ncon, nparts, npwgts+from*ncon, npwgts+to*ncon, nvwgt, ubvec))) || (myedegrees[j].ed == myedegrees[k].ed && IsHBalanceBetterTT(ncon, nparts, npwgts+myedegrees[k].pid*ncon, npwgts+to*ncon, nvwgt, ubvec))) k = j; } to = myedegrees[k].pid; if (myedegrees[k].ed-myrinfo->id == 0 && !IsHBalanceBetterFT(ncon, nparts, npwgts+from*ncon, npwgts+to*ncon, nvwgt, ubvec) && AreAllHVwgtsBelow(ncon, 1.0, npwgts+from*ncon, 0.0, npwgts+from*ncon, maxwgt+from*ncon)) continue; /*===================================================================== * If we got here, we can now move the vertex from 'from' to 'to' *======================================================================*/ graph->mincut -= myedegrees[k].ed-myrinfo->id; IFSET(ctrl->dbglvl, DBG_MOVEINFO, printf("\t\tMoving %6d to %3d. Gain: %4d. Cut: %6d\n", i, to, myedegrees[k].ed-myrinfo->id, graph->mincut)); /* Update where, weight, and ID/ED information of the vertex you moved */ saxpy(ncon, 1.0, nvwgt, 1, npwgts+to*ncon, 1); saxpy(ncon, -1.0, nvwgt, 1, npwgts+from*ncon, 1); where[i] = to; myrinfo->ed += myrinfo->id-myedegrees[k].ed; SWAP(myrinfo->id, myedegrees[k].ed, j); if (myedegrees[k].ed == 0) myedegrees[k] = myedegrees[--myrinfo->ndegrees]; else myedegrees[k].pid = from; if (myrinfo->ed-myrinfo->id < 0) BNDDelete(nbnd, bndind, bndptr, i); /* Update the degrees of adjacent vertices */ for (j=xadj[i]; j<xadj[i+1]; j++) { ii = adjncy[j]; me = where[ii]; myrinfo = graph->rinfo+ii; if (myrinfo->edegrees == NULL) { myrinfo->edegrees = ctrl->wspace.edegrees+ctrl->wspace.cdegree; ctrl->wspace.cdegree += xadj[ii+1]-xadj[ii]; } myedegrees = myrinfo->edegrees; ASSERT(CheckRInfo(myrinfo)); if (me == from) { INC_DEC(myrinfo->ed, myrinfo->id, adjwgt[j]); if (myrinfo->ed-myrinfo->id >= 0 && bndptr[ii] == -1) BNDInsert(nbnd, bndind, bndptr, ii); } else if (me == to) { INC_DEC(myrinfo->id, myrinfo->ed, adjwgt[j]); if (myrinfo->ed-myrinfo->id < 0 && bndptr[ii] != -1) BNDDelete(nbnd, bndind, bndptr, ii); } /* Remove contribution from the .ed of 'from' */ if (me != from) { for (k=0; k<myrinfo->ndegrees; k++) { if (myedegrees[k].pid == from) { if (myedegrees[k].ed == adjwgt[j]) myedegrees[k] = myedegrees[--myrinfo->ndegrees]; else myedegrees[k].ed -= adjwgt[j]; break; } } } /* Add contribution to the .ed of 'to' */ if (me != to) { for (k=0; k<myrinfo->ndegrees; k++) { if (myedegrees[k].pid == to) { myedegrees[k].ed += adjwgt[j]; break; } } if (k == myrinfo->ndegrees) { myedegrees[myrinfo->ndegrees].pid = to; myedegrees[myrinfo->ndegrees++].ed = adjwgt[j]; } } ASSERT(myrinfo->ndegrees <= xadj[ii+1]-xadj[ii]); ASSERT(CheckRInfo(myrinfo)); } nmoves++; } } graph->nbnd = nbnd; if (ctrl->dbglvl&DBG_REFINE) { printf("\t [%5.4f %5.4f], Nb: %6d, Nmoves: %5d, Cut: %6d, LB: ", npwgts[samin(ncon*nparts, npwgts)], npwgts[samax(ncon*nparts, npwgts)], nbnd, nmoves, graph->mincut); ComputeHKWayLoadImbalance(ncon, nparts, npwgts, tvec); for (i=0; i<ncon; i++) printf("%.3f ", tvec[i]); printf("\n"); } if (graph->mincut == oldcut) break; } fwspacefree(ctrl, ncon*nparts); fwspacefree(ctrl, ncon*nparts); idxwspacefree(ctrl, nvtxs); }
/* par fn gr method options */ SEXP optim(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP par, fn, gr, method, options, tmp, slower, supper; SEXP res, value, counts, conv; int i, npar=0, *mask, trace, maxit, fncount = 0, grcount = 0, nREPORT, tmax; int ifail = 0; double *dpar, *opar, val = 0.0, abstol, reltol, temp; const char *tn; OptStruct OS; PROTECT_INDEX par_index; args = CDR(args); OS = (OptStruct) R_alloc(1, sizeof(opt_struct)); OS->usebounds = 0; OS->R_env = rho; par = CAR(args); OS->names = getAttrib(par, R_NamesSymbol); args = CDR(args); fn = CAR(args); if (!isFunction(fn)) error(_("'fn' is not a function")); args = CDR(args); gr = CAR(args); args = CDR(args); method = CAR(args); if (!isString(method)|| LENGTH(method) != 1) error(_("invalid '%s' argument"), "method"); tn = CHAR(STRING_ELT(method, 0)); args = CDR(args); options = CAR(args); PROTECT(OS->R_fcall = lang2(fn, R_NilValue)); PROTECT_WITH_INDEX(par = coerceVector(par, REALSXP), &par_index); if (MAYBE_REFERENCED(par)) REPROTECT(par = duplicate(par), par_index); npar = LENGTH(par); dpar = vect(npar); opar = vect(npar); trace = asInteger(getListElement(options, "trace")); OS->fnscale = asReal(getListElement(options, "fnscale")); tmp = getListElement(options, "parscale"); if (LENGTH(tmp) != npar) error(_("'parscale' is of the wrong length")); PROTECT(tmp = coerceVector(tmp, REALSXP)); OS->parscale = vect(npar); for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i]; UNPROTECT(1); for (i = 0; i < npar; i++) dpar[i] = REAL(par)[i] / (OS->parscale[i]); PROTECT(res = allocVector(VECSXP, 5)); SEXP names; PROTECT(names = allocVector(STRSXP, 5)); SET_STRING_ELT(names, 0, mkChar("par")); SET_STRING_ELT(names, 1, mkChar("value")); SET_STRING_ELT(names, 2, mkChar("counts")); SET_STRING_ELT(names, 3, mkChar("convergence")); SET_STRING_ELT(names, 4, mkChar("message")); setAttrib(res, R_NamesSymbol, names); UNPROTECT(1); PROTECT(value = allocVector(REALSXP, 1)); PROTECT(counts = allocVector(INTSXP, 2)); SEXP countnames; PROTECT(countnames = allocVector(STRSXP, 2)); SET_STRING_ELT(countnames, 0, mkChar("function")); SET_STRING_ELT(countnames, 1, mkChar("gradient")); setAttrib(counts, R_NamesSymbol, countnames); UNPROTECT(1); PROTECT(conv = allocVector(INTSXP, 1)); abstol = asReal(getListElement(options, "abstol")); reltol = asReal(getListElement(options, "reltol")); maxit = asInteger(getListElement(options, "maxit")); if (maxit == NA_INTEGER) error(_("'maxit' is not an integer")); if (strcmp(tn, "Nelder-Mead") == 0) { double alpha, beta, gamm; alpha = asReal(getListElement(options, "alpha")); beta = asReal(getListElement(options, "beta")); gamm = asReal(getListElement(options, "gamma")); nmmin(npar, dpar, opar, &val, fminfn, &ifail, abstol, reltol, (void *)OS, alpha, beta, gamm, trace, &fncount, maxit); for (i = 0; i < npar; i++) REAL(par)[i] = opar[i] * (OS->parscale[i]); grcount = NA_INTEGER; } else if (strcmp(tn, "SANN") == 0) { tmax = asInteger(getListElement(options, "tmax")); temp = asReal(getListElement(options, "temp")); if (trace) trace = asInteger(getListElement(options, "REPORT")); if (tmax == NA_INTEGER || tmax < 1) // PR#15194 error(_("'tmax' is not a positive integer")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ } samin (npar, dpar, &val, fminfn, maxit, tmax, temp, trace, (void *)OS); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); fncount = npar > 0 ? maxit : 1; grcount = NA_INTEGER; UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "BFGS") == 0) { SEXP ndeps; nREPORT = asInteger(getListElement(options, "REPORT")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } mask = (int *) R_alloc(npar, sizeof(int)); for (i = 0; i < npar; i++) mask[i] = 1; vmmin(npar, dpar, &val, fminfn, fmingr, maxit, trace, mask, abstol, reltol, nREPORT, (void *)OS, &fncount, &grcount, &ifail); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "CG") == 0) { int type; SEXP ndeps; type = asInteger(getListElement(options, "type")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } cgmin(npar, dpar, opar, &val, fminfn, fmingr, &ifail, abstol, reltol, (void *)OS, type, trace, &fncount, &grcount, maxit); for (i = 0; i < npar; i++) REAL(par)[i] = opar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "L-BFGS-B") == 0) { SEXP ndeps, smsg; double *lower = vect(npar), *upper = vect(npar); int lmm, *nbd = (int *) R_alloc(npar, sizeof(int)); double factr, pgtol; char msg[60]; nREPORT = asInteger(getListElement(options, "REPORT")); factr = asReal(getListElement(options, "factr")); pgtol = asReal(getListElement(options, "pgtol")); lmm = asInteger(getListElement(options, "lmm")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } args = CDR(args); slower = CAR(args); /* coerce in calling code */ args = CDR(args); supper = CAR(args); for (i = 0; i < npar; i++) { lower[i] = REAL(slower)[i] / (OS->parscale[i]); upper[i] = REAL(supper)[i] / (OS->parscale[i]); if (!R_FINITE(lower[i])) { if (!R_FINITE(upper[i])) nbd[i] = 0; else nbd[i] = 3; } else { if (!R_FINITE(upper[i])) nbd[i] = 1; else nbd[i] = 2; } } OS->usebounds = 1; OS->lower = lower; OS->upper = upper; lbfgsb(npar, lmm, dpar, lower, upper, nbd, &val, fminfn, fmingr, &ifail, (void *)OS, factr, pgtol, &fncount, &grcount, maxit, msg, trace, nREPORT); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ PROTECT(smsg = mkString(msg)); SET_VECTOR_ELT(res, 4, smsg); UNPROTECT(1); } else error(_("unknown 'method'")); if(!isNull(OS->names)) setAttrib(par, R_NamesSymbol, OS->names); REAL(value)[0] = val * (OS->fnscale); SET_VECTOR_ELT(res, 0, par); SET_VECTOR_ELT(res, 1, value); INTEGER(counts)[0] = fncount; INTEGER(counts)[1] = grcount; SET_VECTOR_ELT(res, 2, counts); INTEGER(conv)[0] = ifail; SET_VECTOR_ELT(res, 3, conv); UNPROTECT(6); return res; }