int tclFit(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
int i;
int npar2;
double val[512];
double scal[512];
int used[512];
char method[256];
char *p,**pp,**pp2;
if (argc != 2) {
fprintf(stderr,"%s: specify array with parameters\n",argv[0]);
return 1;
}
iter=0;
strcpy(array,argv[1]);
intrp = interp;
TclGetString(interp,function,array,"function",1,"");
TclGetString(interp,method,array,"fitmethod",0,"simplex");
p=Tcl_GetVar2(interp,array,"values",0);
if (p == NULL)
TclError(interp,"array must contain a variable 'values'");
if (Tcl_SplitList(interp,p,&npar,&pp) != TCL_OK) {
fprintf(stderr,"%s\n",interp->result);
exit(1);
}
for (i=0;i<npar;i++) {
if (Tcl_SplitList(interp,pp[i],&npar2,&pp2) != TCL_OK) {
fprintf(stderr,"%s\n",interp->result);
exit(1);
}
if (npar2 != 4)
TclError(interp,"invalid number of parameters in 'values'");
strcpy(name[i+1],pp2[0]);
if (Tcl_GetDouble(interp,pp2[1],&val[i+1]) != TCL_OK)
TclError(interp,"getdouble(1)");
if (Tcl_GetDouble(interp,pp2[2],&scal[i+1]) != TCL_OK)
TclError(interp,"getdouble(2)");
if (Tcl_GetInt(interp,pp2[3],&used[i+1]) != TCL_OK)
TclError(interp,"getint(3)");
free(pp2);
}
free(pp);
if (!strcmp(method,"simplex")) {
simplex(func,npar,used,val,scal);
} else {
return TclError(interp,"fit: unknown method '%s' (known method: simplex)",method);
}
return TCL_OK;
}
int
Tnm_SnmpSplitVBList(Tcl_Interp *interp, char *list, int *varBindSizePtr, SNMP_VarBind **varBindPtrPtr)
{
int code, vblc, i;
const char **vblv;
int varBindSize;
SNMP_VarBind *varBindPtr;
code = Tcl_SplitList(interp, list, &vblc, &vblv);
if (code != TCL_OK) {
return TCL_ERROR;
}
/*
* Allocate space for the varbind table. Note, we could reuse space
* allocated from previous runs to avoid all the malloc and free
* operations. For now, we go the simple way.
*/
varBindSize = vblc;
varBindPtr = (SNMP_VarBind *) ckalloc(varBindSize * sizeof(SNMP_VarBind));
memset((char *) varBindPtr, 0, varBindSize * sizeof(SNMP_VarBind));
for (i = 0; i < varBindSize; i++) {
int vbc;
char **vbv;
code = Tcl_SplitList(interp, vblv[i], &vbc, (const char ***)&vbv);
if (code != TCL_OK) {
Tnm_SnmpFreeVBList(varBindSize, varBindPtr);
ckfree((char *) vblv);
return TCL_ERROR;
}
if (vbc > 0) {
varBindPtr[i].soid = vbv[0];
if (vbc > 1) {
varBindPtr[i].syntax = vbv[1];
if (vbc > 2) {
varBindPtr[i].value = vbv[2];
}
}
}
varBindPtr[i].freePtr = (char *) vbv;
}
*varBindSizePtr = varBindSize;
*varBindPtrPtr = varBindPtr;
ckfree((char *) vblv);
return TCL_OK;
}
/****
* implementation of list2shape (creates RFshape from a list { {a p} {a p} ... }
****/
int tclList2Shape(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
char **list1, **list2;
int nlist1, nlist2, i, slot;
if (argc != 2)
return TclError(interp,"Usage: <RFshape> list2shape { {a1 p1} {a2 p2} ... }");
if (Tcl_SplitList(interp,argv[1],&nlist1,&list1) != TCL_OK)
return TclError(interp,"list2shape: unable to decompose list argument");
/* get a new slot and allocate */
slot = RFshapes_slot();
if (slot == -1) {
Tcl_Free((char *)list1);
return TclError(interp,"list2shape error: no more free slots available, free some shape first!");
}
RFshapes[slot] = RFshapes_alloc(nlist1);
for (i=0; i<nlist1; i++) {
if (Tcl_SplitList(interp,list1[i],&nlist2,&list2) != TCL_OK) {
Tcl_Free((char *)list1);
return TclError(interp,"list2shape can not read list element %d",i+1);
}
if (nlist2 != 2) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"list2shape: expecting two elements like {amplitude phase} in list");
}
if (Tcl_GetDouble(interp,list2[0],&RFshapes[slot][i+1].ampl) != TCL_OK) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"lis2shape cannot interpret amplitude in element %d",i+1);
}
if (Tcl_GetDouble(interp,list2[1],&RFshapes[slot][i+1].phase) != TCL_OK) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"lis2shape cannot interpret phase in element %d",i+1);
}
Tcl_Free((char *)list2);
}
Tcl_Free((char *)list1);
sprintf(interp->result,"%d",slot);
return TCL_OK;
}
/* Exposed as private function to librt, but not (currently) beyond librt -
* see librt_private.h */
int
tcl_list_to_avs(const char *tcl_list, struct bu_attribute_value_set *avs, int offset)
{
int i = 0;
int list_c = 0;
const char **listv = (const char **)NULL;
if (Tcl_SplitList(NULL, tcl_list, &list_c, (const char ***)&listv) != TCL_OK) {
return -1;
}
if (!BU_AVS_IS_INITIALIZED(avs)) BU_AVS_INIT(avs);
if (!list_c) {
Tcl_Free((char *)listv);
return 0;
}
if (list_c > 2) {
for (i = offset; i < list_c; i += 2) {
(void)bu_avs_add(avs, listv[i], listv[i+1]);
}
} else {
return -1;
}
Tcl_Free((char *)listv);
return 0;
}
/* Parsing results */
CAMLprim value camltk_splitlist (value v)
{
int argc;
char **argv;
int result;
char *utf;
CheckInit();
utf = caml_string_to_tcl(v);
/* argv is allocated by Tcl, to be freed by us */
result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
switch(result) {
case TCL_OK:
{ value res = copy_string_list(argc,argv);
Tcl_Free((char *)argv); /* only one large block was allocated */
/* argv points into utf: utf must be freed after argv are freed */
stat_free( utf );
return res;
}
case TCL_ERROR:
default:
stat_free( utf );
tk_error(Tcl_GetStringResult(cltclinterp));
}
}
//**************************************************************************************
//**************************************************************************************
// Function - to create an fd EvolutionLaw_T object
fdEvolution_T *EvaluatefdEvolution_T(ClientData clientData, Tcl_Interp *interp, TCL_Char *tclString)
{
int argc;
TCL_Char **argv;
// split the list
if (Tcl_SplitList(interp, tclString, &argc, &argv) != TCL_OK) {
exit (-1);
}
fdEvolution_T *fdET = 0;
//1. Linear kinematic (tensor) evolution law:
//
if ((strcmp(argv[0],"-Linear") == 0) ) {
double H_linear = 0.0;
if (argc >= 2) {
if (Tcl_GetDouble(interp, argv[1], &H_linear) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid H_linear " << argv[1] << "\n";
cleanup(argv);
exit (-1);
}
}
fdET = new fdEvolution_TL(H_linear);
}
cleanup(argv);
return fdET;
}
void
ldelete (Tcl_Interp *interp, char *slist, char *item)
{
int largc, i;
char **largv;
if (item == NULL) return;
if (Tcl_SplitList (interp, slist, &largc, &largv) != TCL_OK) {
Tcl_ResetResult (interp);
return;
}
*slist = 0;
for (i = 0; i < largc; i++) {
if ((item[0] != largv[i][0]) || (strcmp (item, largv[i]) != 0)) {
strcat (slist, largv[i]);
strcat (slist, " ");
}
}
ckfree ((char*) largv);
i = strlen (slist) - 1;
if (slist[i] == ' ') slist[i] = '\0';
}
TimeSeriesIntegrator *
TclSeriesIntegratorCommand(ClientData clientData, Tcl_Interp *interp, TCL_Char *arg)
{
int argc;
TCL_Char **argv;
// split the list
if (Tcl_SplitList(interp, arg, &argc, &argv) != TCL_OK) {
opserr << "WARNING could not split series integrator list " << arg << endln;
return 0;
}
TimeSeriesIntegrator *theSeriesIntegrator = 0;
if (strcmp(argv[0],"Trapezoidal") == 0) {
theSeriesIntegrator = new TrapezoidalTimeSeriesIntegrator();
}
else if (strcmp(argv[0],"Simpson") == 0) {
theSeriesIntegrator = new SimpsonTimeSeriesIntegrator();
}
else {
// type of load pattern type unknown
opserr << "WARNING unknown TimeSeriesIntegrator type " << argv[0] << " - ";
opserr << " SeriesIntegratorType <type args>\n\tvalid types: Trapezoidal or Simpson\n";
cleanup(argv);
return 0;
}
cleanup(argv);
return theSeriesIntegrator;
}
// move all atoms by a given vector
int ScriptTcl::Tcl_moveallby(ClientData clientData,
Tcl_Interp *interp, int argc, char *argv[]) {
ScriptTcl *script = (ScriptTcl *)clientData;
script->initcheck();
if (argc != 2) {
Tcl_SetResult(interp, "wrong # args", TCL_VOLATILE);
return TCL_ERROR;
}
char **fstring;
int fnum;
double x, y, z;
if (Tcl_SplitList(interp, argv[1], &fnum, &fstring) != TCL_OK)
return TCL_ERROR;
if ( (fnum != 3) ||
(Tcl_GetDouble(interp, fstring[0],&x) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[1],&y) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[2],&z) != TCL_OK) ) {
Tcl_SetResult(interp,"argument not a vector",TCL_VOLATILE);
Tcl_Free((char*)fstring);
return TCL_ERROR;
}
Tcl_Free((char*)fstring);
MoveAllByMsg *msg = new MoveAllByMsg;
msg->offset = Vector(x,y,z);
(CProxy_PatchMgr(CkpvAccess(BOCclass_group).patchMgr)).moveAllBy(msg);
script->barrier();
return TCL_OK;
}
/** Reads a Tcl vector and returns a C vector.
\param interp The Tcl interpreter
\param data_in String containing a Tcl vector of doubles
\param nrep Pointer to the C vector
\param len Pointer to an int to store the length of the vector
\return \em TCL_OK if everything went fine \em TCL_ERROR otherwise and
interp->result is set to an error message.
If \em TCL_OK is returned you have to make sure to free the memory
pointed to by nrep.
*/
int uwerr_read_tcl_double_vector(Tcl_Interp *interp, char * data_in ,
double ** nrep, int * len)
{
char ** col;
int i;
*len = -1;
if (Tcl_SplitList(interp, data_in, len, &col) == TCL_ERROR)
return TCL_ERROR;
if (*len < 1) {
Tcl_AppendResult(interp, "Argument is not a vector.",
(char *)NULL);
return TCL_ERROR;
}
if (!(*nrep = (double*)malloc((*len)*sizeof(double)))) {
Tcl_AppendResult(interp, "Out of Memory.",
(char *)NULL);
Tcl_Free((char *)col);
return TCL_ERROR;
}
for (i = 0; i < *len; ++i) {
if (Tcl_GetDouble(interp, col[i], &((*nrep)[i])) == TCL_ERROR) {
Tcl_Free((char *)col);
free(*nrep);
return TCL_ERROR;
}
}
Tcl_Free((char *)col);
return TCL_OK;
}
void
TnmSnmpDumpPDU(Tcl_Interp *interp, TnmSnmpPdu *pdu)
{
if (hexdump) {
int i, code, argc;
const char **argv;
char *name, *status;
char buffer[80];
Tcl_DString dst;
Tcl_Channel channel;
Tcl_DStringInit(&dst);
name = TnmGetTableValue(tnmSnmpPDUTable, (unsigned) pdu->type);
if (name == NULL) {
name = "(unknown PDU type)";
}
status = TnmGetTableValue(tnmSnmpErrorTable, (unsigned) pdu->errorStatus);
if (status == NULL) {
status = "(unknown error code)";
}
if (pdu->type == ASN1_SNMP_GETBULK) {
sprintf(buffer, "%s %d non-repeaters %d max-repetitions %d\n",
name, pdu->requestId,
pdu->errorStatus, pdu->errorIndex);
} else if (pdu->type == ASN1_SNMP_TRAP1) {
sprintf(buffer, "%s\n", name);
} else if (pdu->errorStatus == TNM_SNMP_NOERROR) {
sprintf(buffer, "%s %d %s\n", name, pdu->requestId, status);
} else {
sprintf(buffer, "%s %d %s at %d\n",
name, pdu->requestId, status, pdu->errorIndex);
}
Tcl_DStringAppend(&dst, buffer, -1);
code = Tcl_SplitList(interp, Tcl_DStringValue(&pdu->varbind),
&argc, &argv);
if (code == TCL_OK) {
for (i = 0; i < argc; i++) {
sprintf(buffer, "%4d.\t", i+1);
Tcl_DStringAppend(&dst, buffer, -1);
Tcl_DStringAppend(&dst, argv[i], -1);
Tcl_DStringAppend(&dst, "\n", -1);
}
ckfree((char *) argv);
}
Tcl_ResetResult(interp);
channel = Tcl_GetStdChannel(TCL_STDOUT);
if (channel) {
Tcl_Write(channel,
Tcl_DStringValue(&dst), Tcl_DStringLength(&dst));
}
Tcl_DStringFree(&dst);
}
}
//**************************************************************************************
//**************************************************************************************
// Function - to create a FD Yield Surface
fdYield *EvaluatefdYield(ClientData clientData, Tcl_Interp *interp, TCL_Char *tclString)
{
int argc;
TCL_Char **argv;
// split the list
if (Tcl_SplitList(interp, tclString, &argc, &argv) != TCL_OK) {
exit (-1);
}
if (argc == 0)
exit (-1);
// now parse the list & construct the required object
fdYield *fdY = 0;
// 1. von Mises fd Yield Surface
//
if ((strcmp(argv[0],"-VM") == 0) || (strcmp(argv[0],"-vM") == 0) || (strcmp(argv[0],"-J2") == 0)) {
double Y0 = 0.0;
if (argc == 2) {
if (Tcl_GetDouble(interp, argv[1], &Y0) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Y0 " << argv[1] << "\n";
exit (-1);
}
}
fdY = new fdYieldVM(Y0);
}
// 2. Druke-Prager fd Yield Surface
//
else if ((strcmp(argv[0],"-DP") == 0) || (strcmp(argv[0],"-dp") == 0) ) {
double FrictionAng_in = 0.0;
double k_in = 0.0;
if (argc >= 3) {
if (Tcl_GetDouble(interp, argv[1], &FrictionAng_in) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Friction Angle " << argv[1] << "\n";
exit (-1);
}
if (Tcl_GetDouble(interp, argv[2], &k_in) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Conhesion " << argv[2] << "\n";
exit (-1);
}
}
fdY = new fdYieldDP(FrictionAng_in, k_in);
}
else {
opserr << "Warning: invalid fd yield function: " << argv[0] << "\n";
exit (-1);
}
cleanup(argv);
return fdY;
}
//**************************************************************************************
//**************************************************************************************
// Function - to create a FD Flow Rule
fdFlow *EvaluatefdFlow(ClientData clientData, Tcl_Interp *interp, TCL_Char *tclString)
{
int argc;
TCL_Char **argv;
// split the list
if (Tcl_SplitList(interp, tclString, &argc, &argv) != TCL_OK) {
exit (-1);
}
if (argc == 0)
exit (-1);
fdFlow *fdF = 0;
// 1. von Mises fd Yield Surface
//
if ((strcmp(argv[0],"-VM") == 0) || (strcmp(argv[0],"-vM") == 0) || (strcmp(argv[0],"-J2") == 0)) {
double Y0 = 0.0;
if (argc == 2) {
if (Tcl_GetDouble(interp, argv[1], &Y0) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Y0 " << argv[1] << "\n";
exit (-1);
}
}
fdF = new fdFlowVM(Y0);
}
// 2. Druke-Prager fd Flow Rule
//
else if ((strcmp(argv[0],"-DP") == 0) || (strcmp(argv[0],"-dp") == 0) ) {
double DilatedAngle_in = 0.0;
double k_in = 0.0;
if (argc >= 3) {
if (Tcl_GetDouble(interp, argv[1], &DilatedAngle_in) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Dilated Angle " << argv[1] << "\n";
exit (-1);
}
if (Tcl_GetDouble(interp, argv[2], &k_in) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid Conhesion " << argv[2] << "\n";
exit (-1);
}
}
fdF = new fdFlowDP(DilatedAngle_in, k_in);
}
else {
opserr << "Warning: invalid fd flow rule: " << argv[0] << "\n";
exit (-1);
}
cleanup(argv);
return fdF;
}
int tcl_split_one_arg(Tcl_Interp *interp, int *argc, char ***argv)
{
if (*argc == 1 && strchr((*argv)[0], ' ') != 0) {
if (Tcl_SplitList(interp, (*argv)[0], argc, argv) == TCL_OK) {
return(1);
}
}
return(0);
}
/* ARGSUSED */
int
Tcl_ForeachCmd(
void *dummy /* Not used. */
, Tcl_Interp *interp /* Current interpreter. */
, int argc /* Number of arguments. */
, unsigned char **argv /* Argument strings. */
)
{
int listArgc, i, result;
unsigned char **listArgv;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" varName list command\"", 0);
return TCL_ERROR;
}
/*
* Break the list up into elements, and execute the command once
* for each value of the element.
*/
result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
if (result != TCL_OK) {
return result;
}
for (i = 0; i < listArgc; i++) {
if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == 0) {
Tcl_SetResult(interp, (unsigned char*) "couldn't set loop variable", TCL_STATIC);
result = TCL_ERROR;
break;
}
result = Tcl_Eval(interp, argv[3], 0, 0);
if (result != TCL_OK) {
if (result == TCL_CONTINUE) {
result = TCL_OK;
} else if (result == TCL_BREAK) {
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
unsigned char msg[100];
snprintf(msg, sizeof (msg), "\n (\"foreach\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
break;
} else {
break;
}
}
}
mem_free (listArgv);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
LispRef eul_tk_listbox_cmd(char *name, Tcl_CmdInfo * cmdPtr, char *command)
{
command = "curselection";
int argc = 2;
const char **argv;
argv = (const char **)gc_malloc(argc*sizeof(char*));
argv[0] = name;
argv[1] = command;
Tcl_ResetResult(interp);
int result = (cmdPtr->proc)
(
cmdPtr->clientData,
interp,
argc,
argv
);
if (result == TCL_OK)
{
char *list = gc_malloc(strlen(interp->result));
strcpy(list, interp->result);
Tcl_ResetResult(interp);
int argc1;
const char **argv1;
int result = Tcl_SplitList(interp, list, &argc1, &argv1);
if (result == TCL_OK)
{
LispRef list_element, list_result = eul_nil;
for (int i = (argc1 - 1); i >= 0; i--)
{
eul_allocate_string(list_element, (char*)argv1[i]);
eul_allocate_cons(list_result, list_element, list_result);
}
return list_result;
}
else
{
return eul_nil;
}
}
else
{
return eul_nil;
}
}
void
DumpString(Tcl_DString *dsPtr)
{
char **largv;
int i, largc;
if (Tcl_SplitList(NULL, dsPtr->string, &largc, (CONST char***)&largv) == TCL_OK) {
for (i = 0; i < largc; ++i) {
printf("\t%s\n", largv[i]);
}
ckfree((char *) largv);
}
Tcl_DStringTrunc(dsPtr, 0);
}
char *Tksh_ConvertList(Tcl_Interp *interp, char *list, int toMode)
{
int fromMode = (toMode == INTERP_KSH) ? INTERP_TCL : INTERP_KSH;
int oldMode, argc;
char *result, **argv;
result = NULL;
oldMode = TkshSetListMode(fromMode);
if (Tcl_SplitList(interp, list, &argc, &argv) == TCL_OK)
{
TkshSetListMode(toMode);
result = Tcl_Merge(argc, argv);
}
TkshSetListMode(oldMode);
return result;
}
//**************************************************************************************
//**************************************************************************************
// Function - to create an fd EvolutionLaw_S object
fdEvolution_S *EvaluatefdEvolution_S(ClientData clientData, Tcl_Interp *interp, TCL_Char *tclString)
{
int argc;
TCL_Char **argv;
// split the list
if (Tcl_SplitList(interp, tclString, &argc, &argv) != TCL_OK) {
exit (-1);
}
fdEvolution_S *fdES = 0;
//1. Linear and Saturation isotropic (scalar) evolution law:
//
if ((strcmp(argv[0],"-LS") == 0) || (strcmp(argv[0],"-LinearSaturated") == 0)) {
double H_linear = 0.0;
double q_saturated = 0.0;
double beta = 0.0;
if (argc >= 2) {
if (Tcl_GetDouble(interp, argv[1], &H_linear) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid H_linear " << argv[1] << "\n";
cleanup(argv);
exit (-1);
}
}
if (argc >= 4) {
if (Tcl_GetDouble(interp, argv[2], &q_saturated) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid q_saturated " << argv[2] << "\n";
cleanup(argv);
exit (-1);
}
if (Tcl_GetDouble(interp, argv[3], &beta) != TCL_OK) {
opserr << "Warning: nDMaterial FDEP3D - invalid beta " << argv[3] << "\n";
cleanup(argv);
exit (-1);
}
}
fdES = new fdEvolution_SLS(H_linear, q_saturated, beta);
}
cleanup(argv);
return fdES;
}
int ScriptTcl::Tcl_move(ClientData clientData,
Tcl_Interp *interp, int argc, char *argv[]) {
ScriptTcl *script = (ScriptTcl *)clientData;
script->initcheck();
if (argc != 4) {
Tcl_SetResult(interp,"wrong # args",TCL_VOLATILE);
return TCL_ERROR;
}
char **fstring; int fnum; int atomid; int moveto; double x, y, z;
if (Tcl_GetInt(interp,argv[1],&atomid) != TCL_OK) return TCL_ERROR;
if (argv[2][0]=='t' && argv[2][1]=='o' && argv[2][2]==0) moveto = 1;
else if (argv[2][0]=='b' && argv[2][1]=='y' && argv[2][2]==0) moveto = 0;
else {
Tcl_SetResult(interp,"syntax is 'move <id> to|by {<x> <y> <z>}'",TCL_VOLATILE);
return TCL_ERROR;
}
if (Tcl_SplitList(interp, argv[3], &fnum, &fstring) != TCL_OK) {
return TCL_ERROR;
}
if ( (fnum != 3) ||
(Tcl_GetDouble(interp, fstring[0],&x) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[1],&y) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[2],&z) != TCL_OK) ) {
Tcl_SetResult(interp,"third argument not a vector",TCL_VOLATILE);
Tcl_Free((char*)fstring);
return TCL_ERROR;
}
Tcl_Free((char*)fstring);
SimParameters *simParams = Node::Object()->simParameters;
iout << "TCL: Moving atom " << atomid << " ";
if ( moveto ) iout << "to"; else iout << "by";
iout << " " << Vector(x,y,z) << ".\n" << endi;
MoveAtomMsg *msg = new MoveAtomMsg;
msg->atomid = atomid - 1;
msg->moveto = moveto;
msg->coord = Vector(x,y,z);
(CProxy_PatchMgr(CkpvAccess(BOCclass_group).patchMgr)).moveAtom(msg);
script->barrier();
return TCL_OK;
}
int
Dci_ListInit(Dci_List *listPtr, char *list)
{
int listc;
char **listv;
if (Tcl_SplitList(NULL, list, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (listc & 1) {
ckfree((char *) listv);
return TCL_ERROR;
}
listPtr->nelem = listc / 2;
listPtr->elems = (Dci_Elem *) listv;
qsort(listPtr->elems, listPtr->nelem, sizeof(Dci_Elem), CmpElem);
return TCL_OK;
}
static char *traced_globchanset(ClientData cdata, Tcl_Interp * irp,
char *name1, char *name2, int flags)
{
char *s;
char *t;
int i;
int items;
char **item;
Context;
if (flags & (TCL_TRACE_READS | TCL_TRACE_UNSETS)) {
Tcl_SetVar2(interp, name1, name2, glob_chanset, TCL_GLOBAL_ONLY);
if (flags & TCL_TRACE_UNSETS)
Tcl_TraceVar(interp, "global-chanset",
TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
traced_globchanset, NULL);
} else { /* write */
s = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
Tcl_SplitList(interp, s, &items, &item);
Context;
for (i = 0; i<items; i++) {
if (!(item[i]) || (strlen(item[i]) < 2)) continue;
s = glob_chanset;
while (s[0]) {
t = strchr(s, ' '); /* cant be NULL coz of the extra space */
Context;
t[0] = 0;
if (!strcmp(s + 1, item[i] + 1)) {
s[0] = item[i][0]; /* +- */
t[0] = ' ';
break;
}
t[0] = ' ';
s = t + 1;
}
}
if (item) /* hmm it cant be 0 */
Tcl_Free((char *) item);
Tcl_SetVar2(interp, name1, name2, glob_chanset, TCL_GLOBAL_ONLY);
}
return NULL;
}
int save_renzyme(FILE *pw, Tcl_Interp *interp, char **sel, int num_sel) {
int i, j;
char **item = NULL;
int num_item;
char item_name[5][4] = {"ID", "RS", "PT", "CR", "EFS"};
for (i = 0; i < num_sel; i++) {
if (Tcl_SplitList(interp, sel[i], &num_item, &item) != TCL_OK)
return TCL_ERROR;
for (j = 0; j < num_item; j++) {
fprintf(pw, "%2s %s\n", item_name[j], item[j]);
}
fprintf(pw, "//\n\n");
}
fclose(pw);
ckfree((char*)item);
return 0;
}
/* Parsing results */
value camltk_splitlist (value v) /* ML */
{
int argc;
char **argv;
int result;
CheckInit();
/* argv is allocated by Tcl, to be freed by us using Tcl_Free */
result = Tcl_SplitList(cltclinterp,String_val(v),&argc,&argv);
switch(result) {
case TCL_OK:
{ value res = copy_string_list(argc,argv);
Tcl_Free((char *)argv); /* only one large block was allocated */
return res;
}
case TCL_ERROR:
default:
tk_error(cltclinterp->result);
}
}
dfsch_object_t* dfsch_tcl_split_list(char* list){
int argc;
char** argv;
int i;
dfsch_object_t* vec;
if (Tcl_SplitList(NULL, list, &argc, &argv) == TCL_ERROR){
dfsch_error("Syntax error", dfsch_make_string_cstr(list));
}
vec = dfsch_make_vector(argc, NULL);
for (i = 0; i < argc; i++){
dfsch_vector_set(vec, i, dfsch_make_string_cstr(argv[i]));
}
Tcl_Free(argv); /* both array and it's strings are in one chunk of heap */
return vec;
}
static PyObject *
Split(char *list)
{
int argc;
char **argv;
PyObject *v;
if (list == NULL) {
Py_INCREF(Py_None);
return Py_None;
}
if (Tcl_SplitList((Tcl_Interp *)NULL, list, &argc, &argv) != TCL_OK) {
/* Not a list.
* Could be a quoted string containing funnies, e.g. {"}.
* Return the string itself.
*/
return PyString_FromString(list);
}
if (argc == 0)
v = PyString_FromString("");
else if (argc == 1)
v = PyString_FromString(argv[0]);
else if ((v = PyTuple_New(argc)) != NULL) {
int i;
PyObject *w;
for (i = 0; i < argc; i++) {
if ((w = Split(argv[i])) == NULL) {
Py_DECREF(v);
v = NULL;
break;
}
PyTuple_SetItem(v, i, w);
}
}
Tcl_Free(FREECAST argv);
return v;
}
int SaveRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) {
FILE *pw;
char **sel = NULL;
int num_sel;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " filename selected_items\"", (char*)NULL);
return TCL_ERROR;
}
if (NULL == (pw = fopen(argv[1], "w"))) {
verror(ERR_WARN, "save personal r_enzyme file", "Unable to open file %s", argv[1]);
return TCL_OK;
}
/* create selecing Renzyme name array */
if (Tcl_SplitList(interp, argv[2], &num_sel, &sel) != TCL_OK)
return TCL_ERROR;
save_renzyme(pw, interp, sel, num_sel);
return TCL_OK;
}
double* TclGetVector(Tcl_Interp* interp,char* aryname,char* varname,
int mustexist,double* defval)
{
int i,argc;
char** argv;
char* list;
double* v;
list=Tcl_GetVar2(interp,aryname,varname,0);
if (!list) {
if (mustexist) {
fprintf(stderr,"error: could not read vector variable %s(%s)\n",aryname,varname);
exit(-1);
}
if (verbose & VERBOSE_PAR) {
printf("vector variable %s in array %s is set to default value ",varname,aryname);
if (defval != NULL) {
for (i=1;i<=LEN(defval);i++)
printf("%f ",defval[i]);
} else {
printf("<null>\n");
}
}
return defval;
}
if (Tcl_SplitList(interp,list,&argc,&argv) != TCL_OK) TclError(interp,"GetVector(2)");
if (!argc) return NULL;
v = double_vector(argc);
for (i=0;i<argc;i++) {
if (Tcl_GetDouble(interp,argv[i],&v[i+1]) != TCL_OK) TclError(interp,"GetVector(3)");
}
free(argv);
if (verbose & VERBOSE_PAR) {
printf("vector variable %s in array %s is set to value ",varname,aryname);
for (i=1;i<=LEN(v);i++)
printf("%f ",v[i]);
}
return v;
}
/* Parse an n-tuple of doubles specified as a tcl-list.
* Used for grabbing point or vector coordinates, colors, and other things.
* Puts results into an array of doubles.
*/
int get_tcl_tuple ( Tcl_Interp *ip, const char *inList, double *p, int n )
{
CONST84 char **indices;
double tmp;
int num_doubles;
int rtn;
char s[100];
int i;
rtn = Tcl_SplitList(ip, inList, &num_doubles, &indices);
if ((TCL_OK != rtn) || (n != num_doubles)) {
sprintf(s,"%d",n);
Tcl_AppendResult(ip,
"Expected a tuple of ", s, " doubles.\n",
(char *) 0
);
Tcl_Free((char *)indices);
return TCL_ERROR;
}
for (i = 0; i < n; i++) {
if (TCL_OK != Tcl_GetDouble(ip, indices[i], &tmp)) {
Tcl_Free((char *)indices);
sprintf(s,"%d",n);
Tcl_AppendResult(ip,
"Expected a tuple of ", s, " doubles.\n",
(char *) 0
);
return TCL_ERROR;
}
p[i] = tmp;
}
Tcl_Free((char *)indices);
return TCL_OK;
}
pure_expr *tk_split(const char *s)
{
int argc, ret;
const char **argv;
ret = Tcl_SplitList(NULL, s, &argc, &argv);
if (ret == TCL_OK) {
pure_expr *x;
if (argc <= 0)
x = pure_listl(0);
else {
pure_expr **xv = (pure_expr**)malloc(argc*sizeof(pure_expr*));
int i;
for (i = 0; i < argc; i++)
xv[i] = pure_string_dup(argv[i]);
x = pure_listv(argc, xv);
free(xv);
}
Tcl_Free((char *)argv);
return x;
} else {
if (argv) Tcl_Free((char *)argv);
return NULL;
}
}
