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