int TclModelBuilder_addQuadraticCyclic(ClientData clientData, Tcl_Interp *interp, int argc, TCL_Char **argv, TclModelBuilder *theBuilder) { int tag; double wt, qy; if (Tcl_GetInt(interp, argv[2], &tag) != TCL_OK) { opserr << "WARNING invalid CyclicModel tag" << endln; return TCL_ERROR; } if (Tcl_GetDouble(interp, argv[3], &wt) != TCL_OK) { opserr << "WARNING invalid arg[3]" << endln; return TCL_ERROR; } if (Tcl_GetDouble(interp, argv[4], &qy) != TCL_OK) { opserr << "WARNING invalid arg[4]" << endln; return TCL_ERROR; } CyclicModel *cModel = new QuadraticCyclic(tag, wt, qy); if (theBuilder->addCyclicModel(*cModel) < 0) { opserr << "WARNING TclElmtBuilder - could not add cycModel to domain "; opserr << tag << endln; opserr << "\a"; return TCL_ERROR; } return TCL_OK; }
/* ******************************************************** Ndelete_key -- Delete a keyframe. Arguments: Floating point position (i.e. time) Floating point precision Single delete? (boolean) Returns: Number of keys deleted. Side Effects: if single delete is false then removes all keyframes within precision of position. Otherwise removes the first (lowest pos) keyframe within precision of position. ******************************************************** */ int Ndelete_key_cmd(Nv_data * data, /* Local data */ Tcl_Interp * interp, /* Current interpreter */ int argc, /* Number of arguments */ char **argv /* Argument strings */ ) { /* Parse arguments */ double pos, precis; int justone; int num_deleted; char tmp[10]; if (argc != 4) { Tcl_SetResult(interp, "Error: should be Ndelete_key pos precis justone", TCL_VOLATILE); return (TCL_ERROR); } if (Tcl_GetDouble(interp, argv[1], &pos) != TCL_OK) return TCL_ERROR; if (Tcl_GetDouble(interp, argv[2], &precis) != TCL_OK) return TCL_ERROR; if (Tcl_GetBoolean(interp, argv[3], &justone) != TCL_OK) return TCL_ERROR; /* Call the function */ num_deleted = GK_delete_key((float)pos, (float)precis, justone); sprintf(tmp, "%d", num_deleted); Tcl_SetResult(interp, tmp, TCL_VOLATILE); return (TCL_OK); }
int TclExponReducingCommand(ClientData clienData, Tcl_Interp *interp, int argc, TCL_Char **argv, TclModelBuilder *theTclBuilder) { if(argc < 5) { opserr << "TclExponReducingCommand - argc != 5 \n"; return TCL_ERROR; } PlasticHardeningMaterial *theMaterial = 0; int tag; double arg1, arg2, arg3; //plasticMaterial exponReducing (int tag, double kp0, double alfa); //5 //plasticMaterial exponReducing (int tag, double kp0, double x0, double tol); //6 if (Tcl_GetInt(interp, argv[2], &tag) != TCL_OK) { opserr << "WARNING invalid PlaticHardening exponReducing tag" << endln; return TCL_ERROR; } if (Tcl_GetDouble(interp, argv[3], &arg1) != TCL_OK) { opserr << "WARNING invalid double PlaticHardening exponReducing" << endln; return TCL_ERROR; } if (Tcl_GetDouble(interp, argv[4], &arg2) != TCL_OK) { opserr << "WARNING invalid double PlaticHardening exponReducing" << endln; return TCL_ERROR; } if(argc == 6) { if (Tcl_GetDouble(interp, argv[5], &arg3) != TCL_OK) { opserr << "WARNING invalid double PlaticHardening exponReducing" << endln; return TCL_ERROR; } theMaterial = new ExponReducing(tag, arg1, arg2, arg3); // opserr << "factor = " << arg3 << endln; } else theMaterial = new ExponReducing(tag, arg1, arg2); if (theTclBuilder->addPlasticMaterial(*theMaterial) < 0) { opserr << "WARNING could not add uniaxialMaterial to the domain\n"; opserr << *theMaterial << endln; delete theMaterial; // invoke the material objects destructor, otherwise mem leak return TCL_ERROR; } return TCL_OK; }
// 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; }
//************************************************************************************** //************************************************************************************** // 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; }
// text has a start point and a string to display static int tcl_graphics_text(MoleculeGraphics *gmol, int argc, const char *argv[], Tcl_Interp *interp) { // have a vector and some text AT_LEAST(2, "text"); float vals[3]; if (tcl_get_vector(argv[0], vals+0, interp) != TCL_OK) { return TCL_ERROR; } // get the optional size values const char* string = argv[1]; double size = 1.0; double thickness = 1.0; argc -= 2; argv += 2; if (argc %2) { Tcl_SetResult(interp, (char *) "graphics: text has wrong number of options", TCL_STATIC); return TCL_ERROR; } while (argc) { if (!strcmp(argv[0], "size")) { if (Tcl_GetDouble(interp, argv[1], &size) != TCL_OK) { return TCL_ERROR; } if (size <0) size = 0; argc -= 2; argv += 2; continue; } if (!strcmp(argv[0], "thickness")) { if (Tcl_GetDouble(interp, argv[1], &thickness) != TCL_OK) { return TCL_ERROR; } if (thickness <0) thickness = 0; argc -= 2; argv += 2; continue; } // reaching here is an error Tcl_AppendResult(interp, "graphics: unknown option for text: ", argv[0], NULL); return TCL_ERROR; } // add the text char tmpstring[64]; sprintf(tmpstring, "%d", gmol->add_text(vals+0, string, (float) size, (float) thickness)); Tcl_SetResult(interp, tmpstring, TCL_VOLATILE); return TCL_OK; }
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; }
PotentialSurface * TclPotentialSurfaceCommand(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { // parse args and return a DruckerPrager potential surface if ((strcmp(argv[0],"DruckerPrager") == 0) || (strcmp(argv[0],"DP") == 0)) { double a2d = 0.0; if (argc == 2) { if (Tcl_GetDouble(interp, argv[1], &a2d) != TCL_OK) { g3ErrorHandler->warning("invalid a2d: %s for -PS DruckerPrage a2d", argv[1]); return 0; } } // create the object & return it return new DPPotentialSurface(a2d); } // parse args and return a CamClay potential surface else if ((strcmp(argv[0],"CamClay") == 0) || (strcmp(argv[0],"Cam") == 0)) { double mp = 0.0; if (argc == 2) { if (Tcl_GetDouble(interp, argv[1], &mp) != TCL_OK) { g3ErrorHandler->warning("invalid M: %s for -PS CamClay M", argv[1]); return 0; } } // create the object & return it return new CAMPotentialSurface(mp); } // parse args and return a VonMises potential surface else if ((strcmp(argv[0],"VonMises") == 0) || (strcmp(argv[0],"VM") == 0)) { return new VMPotentialSurface(); } // unknown type return error else { g3ErrorHandler->warning("unkown Potential Surface type: %s\n", argv[0]); return 0; } }
/**** * 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; }
//************************************************************************************** //************************************************************************************** // 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; }
int tclcommand_change_volume(ClientData data, Tcl_Interp *interp, int argc, char **argv) { char buffer[50 + TCL_DOUBLE_SPACE + TCL_INTEGER_SPACE]; char *mode; double d_new = box_l[0]; int dir = -1; if (argc < 2) { Tcl_AppendResult(interp, "Wrong # of args! Usage: change_volume { <V_new> | <L_new> { x | y | z | xyz } }", (char *)NULL); return (TCL_ERROR); } if (Tcl_GetDouble(interp, argv[1], &d_new) == TCL_ERROR) return (TCL_ERROR); if (argc == 3) { mode = argv[2]; if (!strncmp(mode, "x", strlen(mode))) dir = 0; else if (!strncmp(mode, "y", strlen(mode))) dir = 1; else if (!strncmp(mode, "z", strlen(mode))) dir = 2; else if (!strncmp(mode, "xyz", strlen(mode))) dir = 3; } else if (argc > 3) { Tcl_AppendResult(interp, "Wrong # of args! Usage: change_volume { <V_new> | <L_new> { x | y | z | xyz } }", (char *)NULL); return (TCL_ERROR); } if (dir < 0) { d_new = pow(d_new,1./3.); rescale_boxl(3,d_new); } else { rescale_boxl(dir,d_new); } sprintf(buffer, "%f", box_l[0]*box_l[1]*box_l[2]); Tcl_AppendResult(interp, buffer, (char *)NULL); return gather_runtime_errors(interp, TCL_OK); }
/* ******************************************************** Nset_tension_cmd -- Hook for Nset_tension tcl/tk command. Arguments: A float value between 0.0 and 1.0 inclusive. Returns: None. Side Effects: Sets tension for interpolating splines ******************************************************** */ int Nset_tension_cmd(Nv_data * data, /* Local data */ Tcl_Interp * interp, /* Current interpreter */ int argc, /* Number of arguments */ char **argv /* Argument strings */ ) { /* Parse arguments */ double tension; if (argc != 2) { Tcl_SetResult(interp, "Error: should be Nset_tension float_value", TCL_VOLATILE); return (TCL_ERROR); } if (Tcl_GetDouble(interp, argv[1], &tension) != TCL_OK) return (TCL_ERROR); if ((tension < 0) || (tension > 1)) { Tcl_SetResult(interp, "Error: float_value should be between 0 and 1 inclusive", TCL_VOLATILE); return (TCL_ERROR); } /* Now set the tension value */ GK_set_tension((float)tension); 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; }
/**** * implementation of shape_energy [rf in Hz, energy in (rad.s-1)^2 ] ****/ int tclShapeEnergy(ClientData data,Tcl_Interp* interp,int argc, char *argv[]) { int slot, i, N; double nrg, dur, dum; if (argc != 3) return TclError(interp,"Usage: <result> shape_energy <RFshape> <duration>"); if (Tcl_GetInt(interp,argv[1],&slot) == TCL_ERROR) return TclError(interp,"shape_energy: first argument must be integer <RFshape>"); /* check for RFshape existence */ if (!RFshapes[slot]) return TclError(interp,"shape_energy: trying to acces non-existing RFshape"); if (Tcl_GetDouble(interp,argv[2],&dur) == TCL_ERROR) return TclError(interp,"shape_energy: second argument must be double <duration>"); if (dur <= 0.0) return TclError(interp,"shape_energy: duration should be greater than zero"); nrg = 0.0; N = RFshapes_len(slot); for (i=1; i<=N; i++) { dum = RFshapes[slot][i].ampl; nrg += dum*dum; } nrg = 4.0*M_PI*M_PI*nrg*dur*1e-6/(double)N; sprintf(interp->result,"%.15g",nrg); return TCL_OK; }
int mpsa_PclVelUpdateCmd( ClientData dummy, Tcl_Interp *interp, int argc, char **argv ) { mpsa_List *List; mpsa_Link *Link; double TempDouble; float DT; if(argc != 3) { Tcl_AppendResult(interp, "Error - insufficient arguments", (char *) NULL); return TCL_ERROR; } if(mpsa_GetList(interp, argv[1], &List) != MPSA_OKAY) { return TCL_ERROR; } if(Tcl_GetDouble(interp, argv[2], &TempDouble) != TCL_OK) { Tcl_AppendResult(interp, "Error getting timestep", (char *) NULL); return TCL_ERROR; } DT = TempDouble; for(Link = List->firstLink; Link != NULL; Link = Link->nextLink) { mpsa_PclVelUpdate(Link->Pcl, DT); } return TCL_OK; }
double func (double x[]) { int i; double value; char buf2[256]; char buf[2048]; sprintf(buf,"%d",++iter); if (NULL == Tcl_SetVar2(intrp,array,"iter",buf, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) { fprintf(stderr,"Error: '%s'\n",intrp->result); exit(1); } strcpy(buf,function); strcat(buf," {"); for (i=1;i<=npar;i++) { sprintf(buf2," { %s %g }",name[i],x[i]); strcat(buf,buf2); } strcat(buf," }"); if (Tcl_Eval(intrp,buf) != TCL_OK) { fprintf(stderr,"Error: '%s'\n",intrp->result); exit(1); } if (Tcl_GetDouble(intrp,intrp->result,&value) != TCL_OK) { fprintf(stderr,"Error: '%s'\n",intrp->result); exit(1); } return value; }
/**** * implementation of Tcl shape_index_set routine ****/ int tclShapeIndexSet(ClientData data,Tcl_Interp* interp,int argc, char *argv[]) { int slot, idx; double am, ph; if (argc != 5 && argc != 7) return TclError(interp,"Usage: shape_index_set <RFshape> <index> ?-ampl <a>? ?-phase <p>?"); if (Tcl_GetInt(interp,argv[1],&slot) == TCL_ERROR) return TclError(interp,"shape_index_set: argument 1 must be integer <RFshape>"); /* check for RFshape existence */ if (!RFshapes[slot]) return TclError(interp,"shape_index_set: trying to acces non-existing RFshape"); /* read second argument */ if (Tcl_GetInt(interp,argv[2],&idx) == TCL_ERROR) return TclError(interp,"shape_index_set: argument 2 must be integer <index>"); if (idx<1 || idx>RFshapes_len(slot)) return TclError(interp,"shape_index_set: index out of shape size"); if (!strcmp(argv[3],"-ampl") ) { if (Tcl_GetDouble(interp,argv[4],&am) == TCL_ERROR) return TclError(interp,"shape_index_set: -ampl must be double"); RFshapes[slot][idx].ampl = am; } else if (!strcmp(argv[3],"-phase") ) { if (Tcl_GetDouble(interp,argv[4],&ph) == TCL_ERROR) return TclError(interp,"shape_index_set: -phase must be double"); RFshapes[slot][idx].phase = ph; } else return TclError(interp,"shape_index_set: argument 3 must be either '-ampl' or '-phase'"); if ( argc == 5) return TCL_OK; if (!strcmp(argv[5],"-ampl") ) { if (Tcl_GetDouble(interp,argv[6],&am) == TCL_ERROR) return TclError(interp,"shape_index_set: -ampl must be double"); RFshapes[slot][idx].ampl = am; } else if (!strcmp(argv[5],"-phase") ) { if (Tcl_GetDouble(interp,argv[6],&ph) == TCL_ERROR) return TclError(interp,"shape_index_set: -phase must be double"); RFshapes[slot][idx].phase = ph; } else return TclError(interp,"shape_index_set: argument 5 must be either '-ampl' or '-phase'"); return TCL_OK; }
//************************************************************************************** //************************************************************************************** // 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; }
/******************************************************************************* * dhsIOctlTcl ( ... ) * Use: set dhsStat [dhs::IOctl <eID> <ioctl> <expID> <obsID>] *******************************************************************************/ static int dhsIOctlTcl ( ClientData clientData, Tcl_Interp *interp, int argc, char *argv[] ) { /* declare local scope variable and initialize them */ dhsHandle eID=(dhsHandle)0; double expID=(double)0.0; int inum=0, ic=0, ival=0; long lstat=0; char obsID[DHS_IMPL_MAXSTR]; (void) memset(obsID,'\0',DHS_IMPL_MAXSTR); /* initialize static variables */ (void) memset(response,'\0',MAXMSG); (void) memset(result,'\0',DHS_RESULT_LEN); /* check handle */ if ( Tcl_GetInt(interp,argv[1],&ival) != TCL_OK ) { (void) sprintf(result,"%s","dhsIOctlTcl-E-bad handle\n"); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_ERROR; } eID = (dhsHandle)ival; #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::IOctl: eID=%d\n",(int)eID); (void) fflush(stderr); #endif /* check ioctl */ if ( Tcl_GetInt(interp,argv[2],(int *)&inum) != TCL_OK ) { (void) sprintf(result,"%s","dhsIOctlTcl-E-bad ioctl\n"); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_ERROR; } #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::IOctl: ionum=%d\n",inum); (void) fflush(stderr); #endif /* check expID */ if ( Tcl_GetDouble(interp,argv[3],&expID) != TCL_OK ) { (void) sprintf(result,"%s","dhsIOctlTcl-E-bad exposure id\n"); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_ERROR; } #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::IOctl: expID=%lf\n",expID); (void) fflush(stderr); #endif /* check obsID */ for ( ic=4; ic<argc; ic++ ) { strcat(obsID,argv[ic]); strcat(obsID," "); } obsID[strlen(obsID)-1] = '\0'; #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::IOctl: obsID=%s\n",obsID); (void) fflush(stderr); #endif /* execute the dhs function */ dhsIOCtl(&lstat,response,eID,(long)inum,&expID,obsID,NULL); if ( STATUS_BAD(lstat) ) { (void) Tcl_SetResult(interp,response,TCL_STATIC); return TCL_ERROR; } #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::IOctl: lstat=%ld\n",lstat); (void) fflush(stderr); #endif /* return result */ (void) sprintf(result,"%ld",lstat); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_OK; }
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; }
/**** * implementation of shape_dup (creates new RFshape by adding phase to existent RFshape} ****/ int tclShapeDup(ClientData data,Tcl_Interp* interp,int argc, char *argv[]) { int slot, newslot, i, N; double ph; double k=1.0; if ( (argc < 3) || (argc > 4) ) return TclError(interp,"Usage: <RFshape> shape_dup <RFshape> <phase> ?<ampl. scale factor>?"); if (Tcl_GetInt(interp,argv[1],&slot) == TCL_ERROR) return TclError(interp,"shape_dup: first argument must be integer <RFshape>"); /* check for RFshape existence */ if (!RFshapes[slot]) return TclError(interp,"shape_dup: trying to acces non-existing RFshape"); if (Tcl_GetDouble(interp,argv[2],&ph) == TCL_ERROR) return TclError(interp,"shape_dup: second argument must be double <phase in deg.>"); if (argc == 4) { if (Tcl_GetDouble(interp,argv[3],&k) == TCL_ERROR) return TclError(interp,"shape_dup: third argument must be double <ampl. scale factor>"); } /* get a new slot and allocate */ newslot = RFshapes_slot(); if (newslot == -1) { return TclError(interp,"shape_dup error: no more free slots available, free some shape first!"); } N = RFshapes_len(slot); RFshapes[newslot] = RFshapes_alloc(N); for (i=1; i<=N; i++) { RFshapes[newslot][i].ampl = (RFshapes[slot][i].ampl)*k; RFshapes[newslot][i].phase = RFshapes[slot][i].phase+ph; if ( RFshapes[newslot][i].phase < 0.0 ) RFshapes[newslot][i].phase += 360.0; if ( RFshapes[newslot][i].phase > 360.0 ) RFshapes[newslot][i].phase -= 360.0; } sprintf(interp->result,"%d",newslot); return TCL_OK; }
int Tk_GetScrollInfo( Tcl_Interp *interp, /* Used for error reporting. */ int argc, /* # arguments for command. */ const char **argv, /* Arguments for command. */ double *dblPtr, /* Filled in with argument "moveto" option, if * any. */ int *intPtr) /* Filled in with number of pages or lines to * scroll, if any. */ { int c = argv[2][0]; size_t length = strlen(argv[2]); if ((c == 'm') && (strncmp(argv[2], "moveto", length) == 0)) { if (argc != 4) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: should be \"%s %s %s\"", argv[0], argv[1], "moveto fraction")); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) { return TK_SCROLL_ERROR; } return TK_SCROLL_MOVETO; } else if ((c == 's') && (strncmp(argv[2], "scroll", length) == 0)) { if (argc != 5) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: should be \"%s %s %s\"", argv[0], argv[1], "scroll number units|pages")); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) { return TK_SCROLL_ERROR; } length = strlen(argv[4]); c = argv[4][0]; if ((c == 'p') && (strncmp(argv[4], "pages", length) == 0)) { return TK_SCROLL_PAGES; } else if ((c == 'u') && (strncmp(argv[4], "units", length) == 0)) { return TK_SCROLL_UNITS; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be units or pages", argv[4])); Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL); return TK_SCROLL_ERROR; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown option \"%s\": must be moveto or scroll", argv[2])); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", argv[2], NULL); return TK_SCROLL_ERROR; }
// sphere has a center, radius, and resolution static int tcl_graphics_sphere(MoleculeGraphics *gmol, int argc, const char *argv[], Tcl_Interp *interp) { // only really need the coordinates AT_LEAST(1, "sphere"); float vals[3]; if (tcl_get_vector(argv[0], vals+0, interp) != TCL_OK) { return TCL_ERROR; } // get the optional values double radius = 1.0; int resolution = 6; argc -= 1; argv += 1; if (argc %2) { Tcl_SetResult(interp, (char *) "graphics: sphere has wrong number of options", TCL_STATIC); return TCL_ERROR; } while (argc) { if (!strcmp(argv[0], "radius")) { if (Tcl_GetDouble(interp, argv[1], &radius) != TCL_OK) { return TCL_ERROR; } if (radius <0) radius = 0; argc -= 2; argv += 2; continue; } if (!strcmp(argv[0], "resolution")) { if (Tcl_GetInt(interp, argv[1], &resolution) != TCL_OK) { return TCL_ERROR; } if (resolution < 0) resolution = 0; if (resolution > 30) resolution = 30; argc -= 2; argv += 2; continue; } // reaching here is an error Tcl_AppendResult(interp, "graphics: unknown option for sphere: ", argv[0], NULL); return TCL_ERROR; } // I have a sphere, so add it char tmpstring[64]; sprintf(tmpstring, "%d", gmol->add_sphere(vals+0, (float) radius, resolution)); Tcl_SetResult(interp, tmpstring, TCL_VOLATILE); return TCL_OK; }
int OPS_GetDoubleInput(int *numData, double *data) { int size = *numData; for (int i=0; i<size; i++) { if ((currentArg >= maxArg) || (Tcl_GetDouble(theInterp, currentArgv[currentArg], &data[i]) != TCL_OK)) { opserr << "OPS_GetDoubleInput -- error reading " << currentArg << endln; return -1; } else currentArg++; } return 0; }
int tux_material( ClientData cd, Tcl_Interp *ip, int argc, const char *argv[] ) { const char *errmsg; const char *mat_name; scalar_t diffuse[3]; scalar_t specular[3]; double spec_exp; if (5 != argc) { Tcl_AppendResult(ip, argv[0], ": invalid number of arguments\n", "Usage: ", argv[0], " <name> { <ambient colour> } " "{ <specular colour> } <specular exponent", (char *)0 ); return TCL_ERROR; } /* obtain material name */ mat_name = argv[1]; /* obtain diffuse colour */ if (TCL_OK != get_tcl_tuple(ip,argv[2],diffuse,3)) { Tcl_AppendResult(ip, argv[0], ": invalid diffuse colour", (char *)0 ); return TCL_ERROR; } /* obtain specular colour */ if (TCL_OK != get_tcl_tuple(ip,argv[3],specular,3)) { Tcl_AppendResult(ip, argv[0], ": invalid specular colour", (char *)0 ); return TCL_ERROR; } /* obtain specular exponent */ if (TCL_OK != Tcl_GetDouble(ip,argv[4],&spec_exp)) { Tcl_AppendResult(ip, argv[0], ": invalid specular exponent", (char *)0 ); return TCL_ERROR; } errmsg = create_material(mat_name,make_colour_from_array(diffuse), make_colour_from_array(specular), spec_exp); /* report error, if any */ if (errmsg) { Tcl_AppendResult(ip, argv[0], ": ", errmsg, (char *)0 ); return TCL_ERROR; } return TCL_OK; }
/* ******************************************************** Nmove_key -- Move a keyframe. Arguments: Floating point old position (i.e. time) Floating point precision Floating point new position (i.e. time) Returns: Number of keys moved (either 1 or 0) Side Effects: Moves the specified key from old_position +- precision to new_position +- precision ******************************************************** */ int Nmove_key_cmd(Nv_data * data, /* Local data */ Tcl_Interp * interp, /* Current interpreter */ int argc, /* Number of arguments */ char **argv /* Argument strings */ ) { /* Parse arguments */ double new_pos, old_pos, precis; int num_moved; char tmp[10]; if (argc != 4) { Tcl_SetResult(interp, "Error: should be Nmove_key oldpos precis newpos", TCL_VOLATILE); return (TCL_ERROR); } if (Tcl_GetDouble(interp, argv[1], &old_pos) != TCL_OK) return TCL_ERROR; if (Tcl_GetDouble(interp, argv[2], &precis) != TCL_OK) return TCL_ERROR; if (Tcl_GetDouble(interp, argv[3], &new_pos) != TCL_OK) return TCL_ERROR; /* Call the function */ num_moved = GK_move_key((float)old_pos, (float)precis, (float)new_pos); G_debug(3, "Arguments to move_key %f %f %f\n", (float)old_pos, (float)precis, (float)new_pos); G_debug(3, "Frames moved = %d\n", num_moved); sprintf(tmp, "%d", num_moved); Tcl_SetResult(interp, tmp, TCL_VOLATILE); return (TCL_OK); }
/******************************************************************************* * dhsCloseExpTcl ( ... ) * Use: set dhsStat [dhs::CloseExp <eID> <expID>] *******************************************************************************/ static int dhsCloseExpTcl ( ClientData clientData, Tcl_Interp *interp, int argc, char *argv[] ) { /* declare local scope variable and initialize them */ dhsHandle eID=(dhsHandle)0; double expID=(double)0.0; int ival=0; long lstat=0; char obsID[DHS_IMPL_MAXSTR]; (void) memset(obsID,'\0',DHS_IMPL_MAXSTR); /* initialize static variables */ (void) memset(response,'\0',MAXMSG); (void) memset(result,'\0',DHS_RESULT_LEN); /* check handle */ if ( Tcl_GetInt(interp,argv[1],&ival) != TCL_OK ) { (void) sprintf(result,"%s","dhsCloseExpTcl-E-bad handle\n"); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_ERROR; } eID = (dhsHandle)ival; #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::CloseExp>> eID=%d\n",(int)eID); (void) fflush(stderr); #endif /* check expID */ if ( Tcl_GetDouble(interp,argv[2],&expID) != TCL_OK ) { (void) sprintf(result,"%s","dhsCloseExpTcl-E-bad exposure id\n"); (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_ERROR; } #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::CloseExp>> expID=%lf\n",expID); (void) fflush(stderr); #endif /* execute the dhs function */ dhsCloseExp(&lstat,response,eID,expID); if ( STATUS_BAD(lstat) ) { (void) Tcl_SetResult(interp,response,TCL_STATIC); return TCL_ERROR; } #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::CloseExp>> lstat=%ld\n",lstat); (void) fflush(stderr); #endif /* return result */ (void) sprintf(result,"%ld",lstat); #ifdef DEBUGTCL (void) fprintf(stderr,"dhs::CloseExp>> response=\"%s\"\n",response); (void) fflush(stderr); (void) fprintf(stderr,"dhs::CloseExp>> result=\"%s\"\n",result); (void) fflush(stderr); #endif (void) Tcl_SetResult(interp,result,TCL_STATIC); return TCL_OK; }
/* ScaleVariableChanged -- * Variable trace procedure for scale -variable; * Updates the scale's value. * If the linked variable is not a valid double, * sets the 'invalid' state. */ static void ScaleVariableChanged(void *recordPtr, const char *value) { Scale *scale = recordPtr; double v; if (value == NULL || Tcl_GetDouble(0, value, &v) != TCL_OK) { TtkWidgetChangeState(&scale->core, TTK_STATE_INVALID, 0); } else { Tcl_Obj *valueObj = Tcl_NewDoubleObj(v); Tcl_IncrRefCount(valueObj); Tcl_DecrRefCount(scale->scale.valueObj); scale->scale.valueObj = valueObj; TtkWidgetChangeState(&scale->core, 0, TTK_STATE_INVALID); } TtkRedisplayWidget(&scale->core); }
int TclInterpreter::getDouble(double *data, int numArgs) { if ((wrapper.getNumberArgs() - wrapper.getCurrentArg()) < numArgs) { return -1; } for (int i=0; i<numArgs; i++) { if (Tcl_GetDouble(interp, wrapper.getCurrentArgv()[wrapper.getCurrentArg()], &data[i]) != TCL_OK) { wrapper.incrCurrentArg(); return -1; } else { wrapper.incrCurrentArg(); } } return 0; }