C++ Tcl_GetDouble函数代码示例

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

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

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