示例#1
0
static int
getresid(Tcl_Interp *interp, CONST84 char *id, Pg_ConnectionId ** connid_p)
{
	Tcl_Channel conn_chan;
	char	   *mark;
	int			resid;
	Pg_ConnectionId *connid;

	if (!(mark = strchr(id, '.')))
		return -1;
	*mark = '\0';
	conn_chan = Tcl_GetChannel(interp, id, 0);
	*mark = '.';
	if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
	{
		Tcl_SetResult(interp, "Invalid connection handle", TCL_STATIC);
		return -1;
	}

	if (Tcl_GetInt(interp, mark + 1, &resid) == TCL_ERROR)
	{
		Tcl_SetResult(interp, "Poorly formated result handle", TCL_STATIC);
		return -1;
	}

	connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);

	if (resid < 0 || resid >= connid->res_max || connid->results[resid] == NULL)
	{
		Tcl_SetResult(interp, "Invalid result handle", TCL_STATIC);
		return -1;
	}

	*connid_p = connid;

	return resid;
}
示例#2
0
/*
** Usage:   fake_big_file  N  FILENAME
**
** Write a few bytes at the N megabyte point of FILENAME.  This will
** create a large file.  If the file was a valid SQLite database, then
** the next time the database is opened, SQLite will begin allocating
** new pages after N.  If N is 2096 or bigger, this will test the
** ability of SQLite to write to large files.
*/
static int fake_big_file(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  const char **argv      /* Text of each argument */
){
  int rc;
  int n;
  i64 offset;
  OsFile *fd = 0;
  int readOnly = 0;
  if( argc!=3 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
       " N-MEGABYTES FILE\"", 0);
    return TCL_ERROR;
  }
  if( Tcl_GetInt(interp, argv[1], &n) ) return TCL_ERROR;
  rc = sqlite3OsOpenReadWrite(argv[2], &fd, &readOnly);
  if( rc ){
    Tcl_AppendResult(interp, "open failed: ", errorName(rc), 0);
    return TCL_ERROR;
  }
  offset = n;
  offset *= 1024*1024;
  rc = sqlite3OsSeek(fd, offset);
  if( rc ){
    Tcl_AppendResult(interp, "seek failed: ", errorName(rc), 0);
    return TCL_ERROR;
  }
  rc = sqlite3OsWrite(fd, "Hello, World!", 14);
  sqlite3OsClose(&fd);
  if( rc ){
    Tcl_AppendResult(interp, "write failed: ", errorName(rc), 0);
    return TCL_ERROR;
  }
  return TCL_OK;
}
示例#3
0
/* Parse an n-tuple of ints specified as a tcl-list. */
int get_tcl_int_tuple( Tcl_Interp *ip, const char *inList, int *p, int n ) 
{
    CONST84 char **indices;
    int tmp;
    int num_ints;
    int rtn;
    char s[100];
    int i;

    rtn = Tcl_SplitList(ip, inList, &num_ints, &indices);

    if ((TCL_OK != rtn) || (n != num_ints)) {
	sprintf(s,"%d",n);
	Tcl_AppendResult(ip, 
			 "Expected a tuple of ", s, " integers.\n",
			 (char *) 0
	    );
	Tcl_Free((char *)indices);
	return TCL_ERROR;
    }

    for (i = 0; i < n; i++) {
	if (TCL_OK != Tcl_GetInt(ip, indices[i], &tmp)) {
	    Tcl_Free((char *)indices);
	    sprintf(s,"%d",n);
	    Tcl_AppendResult(ip, 
			     "Expected a tuple of ", s, " integers.\n",
			     (char *) 0
		);
	    return TCL_ERROR;
	}
	p[i] = tmp;
    }
    Tcl_Free((char *)indices);
    return TCL_OK;
}
int TclNullPlasticMaterialCommand(ClientData clienData, Tcl_Interp *interp, int argc,
					TCL_Char **argv, TclModelBuilder *theTclBuilder)
{
    PlasticHardeningMaterial *theMaterial = 0;

	int tag;

	if (Tcl_GetInt(interp, argv[2], &tag) != TCL_OK)
	{
	    	opserr << "WARNING invalid  PlaticHardening quadrReducing tag" << endln;
	    	return TCL_ERROR;
	}

	theMaterial = new NullPlasticMaterial(tag);
    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;
}
示例#5
0
static int page_lookup(
  void *NotUsed,
  Tcl_Interp *interp,    
  int argc,              
  const char **argv      
){
  Pager *pPager;
  char zBuf[100];
  DbPage *pPage;
  int pgno;
  if( argc!=3 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
       " ID PGNO\"", 0);
    return TCL_ERROR;
  }
  pPager = sqlite3TestTextToPtr(argv[1]);
  if( Tcl_GetInt(interp, argv[2], &pgno) ) return TCL_ERROR;
  pPage = sqlite3PagerLookup(pPager, pgno);
  if( pPage ){
    sqlite3_snprintf(sizeof(zBuf),zBuf,"%p",pPage);
    Tcl_AppendResult(interp, zBuf, 0);
  }
  return TCL_OK;
}
示例#6
0
/*******************************************************************************
 * dhsSysCloseTcl ( ... )
 *  Use: set dhsStat [dhs::SysClose <sID>]
 *******************************************************************************/
static int dhsSysCloseTcl ( ClientData clientData, Tcl_Interp *interp, int argc, char *argv[] ) {
 /* declare local scope variable and initialize them */
 dhsHandle sID=(dhsHandle)0;
 int ival=0;
 long lstat=0;
 /* 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","dhsSysCloseTcl-E-bad handle\n");
  (void) Tcl_SetResult(interp,result,TCL_STATIC);
  return TCL_ERROR;
 }
 sID = (dhsHandle)ival;
 #ifdef DEBUGTCL
  (void) fprintf(stderr,"dhs::SysClose>> sID=%d\n",(int)sID); (void) fflush(stderr);
 #endif
 /* execute the dhs function */
 dhsSysClose(&lstat,response,sID);
 if ( STATUS_BAD(lstat) ) {
  (void) Tcl_SetResult(interp,response,TCL_STATIC);
  return TCL_ERROR;
 }
 #ifdef DEBUGTCL
  (void) fprintf(stderr,"dhs::SysClose>> lstat=%ld\n",lstat); (void) fflush(stderr);
 #endif
 /* return result */  
 (void) sprintf(result,"%ld",lstat);
 #ifdef DEBUGTCL
  (void) fprintf(stderr,"dhs::SysClose>> response=\"%s\"\n",response); (void) fflush(stderr);
  (void) fprintf(stderr,"dhs::SysClose>> result=\"%s\"\n",result); (void) fflush(stderr);
 #endif
 (void) Tcl_SetResult(interp,result,TCL_STATIC);
 return TCL_OK;
}
示例#7
0
/** Reads a Tcl vector and returns a C vector.

    \param interp The Tcl interpreter
    \param data_in String containing a Tcl vector of integers
    \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_int_vector(Tcl_Interp *interp, char * data_in ,
			  int ** nrep, int * len)
{
  char ** col;
  int i;

  *len  = -1;
  *nrep =  0;

  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 = (int*)malloc((*len)*sizeof(int)))) {
    Tcl_AppendResult(interp, "Out of Memory.",
		     (char *)NULL);
    Tcl_Free((char *)col);
    return TCL_ERROR;
  }

  for (i = 0; i < *len; ++i) {
      if (Tcl_GetInt(interp, col[i], &((*nrep)[i])) == TCL_ERROR) {
	Tcl_Free((char *)col);
	free(*nrep);
	return TCL_ERROR;
      }
  }

  Tcl_Free((char *)col);
  return TCL_OK;
}
示例#8
0
文件: test2.c 项目: Av3ng3/Lamobo-D1s
/*
** Usage:   fake_big_file  N  FILENAME
**
** Write a few bytes at the N megabyte point of FILENAME.  This will
** create a large file.  If the file was a valid SQLite database, then
** the next time the database is opened, SQLite will begin allocating
** new pages after N.  If N is 2096 or bigger, this will test the
** ability of SQLite to write to large files.
*/
static int fake_big_file(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  const char **argv      /* Text of each argument */
){
  sqlite3_vfs *pVfs;
  sqlite3_file *fd = 0;
  int rc;
  int n;
  i64 offset;
  if( argc!=3 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
       " N-MEGABYTES FILE\"", 0);
    return TCL_ERROR;
  }
  if( Tcl_GetInt(interp, argv[1], &n) ) return TCL_ERROR;

  pVfs = sqlite3_vfs_find(0);
  rc = sqlite3OsOpenMalloc(pVfs, argv[2], &fd, 
      (SQLITE_OPEN_CREATE|SQLITE_OPEN_READWRITE|SQLITE_OPEN_MAIN_DB), 0
  );
  if( rc ){
    Tcl_AppendResult(interp, "open failed: ", errorName(rc), 0);
    return TCL_ERROR;
  }
  offset = n;
  offset *= 1024*1024;
  rc = sqlite3OsWrite(fd, "Hello, World!", 14, offset);
  sqlite3OsCloseFree(fd);
  if( rc ){
    Tcl_AppendResult(interp, "write failed: ", errorName(rc), 0);
    return TCL_ERROR;
  }
  return TCL_OK;
}
示例#9
0
int GraphCmdMask(GRAPH_ARGS)
{
  int mask;

  if ((argc != 2) && (argc != 3)) {
    Tcl_AppendResult(interp, "wrong # args", (char *) NULL);
    return TCL_ERROR;
  }

  if (argc == 3) {
    if ((Tcl_GetInt(interp, argv[2], &mask) != TCL_OK) ||
	(mask < 0) || (mask > 63)) {
      Tcl_AppendResult(interp, " bogus args", (char *) NULL);
      return TCL_ERROR;
    }

    graph->mask = mask;
    NewGraph = 1;
  }

  sprintf(interp->result, "%d", graph->mask);

  return TCL_OK;
}
示例#10
0
文件: test2.c 项目: Av3ng3/Lamobo-D1s
/*
** Usage:   page_lookup ID PGNO
**
** Return a pointer to a page if the page is already in cache.
** If not in cache, return an empty string.
*/
static int page_lookup(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  const char **argv      /* Text of each argument */
){
  Pager *pPager;
  char zBuf[100];
  DbPage *pPage;
  int pgno;
  if( argc!=3 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
       " ID PGNO\"", 0);
    return TCL_ERROR;
  }
  pPager = sqlite3TestTextToPtr(argv[1]);
  if( Tcl_GetInt(interp, argv[2], &pgno) ) return TCL_ERROR;
  pPage = sqlite3PagerLookup(pPager, pgno);
  if( pPage ){
    sqlite3_snprintf(sizeof(zBuf),zBuf,"%p",pPage);
    Tcl_AppendResult(interp, zBuf, 0);
  }
  return TCL_OK;
}
示例#11
0
/*
** usage:   btree_set_cache_size ID NCACHE
**
** Set the size of the cache used by btree $ID.
*/
static int btree_set_cache_size(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  const char **argv      /* Text of each argument */
){
  int nCache;
  Btree *pBt;
  
  if( argc!=3 ){
    Tcl_AppendResult(
        interp, "wrong # args: should be \"", argv[0], " BT NCACHE\"", 0);
    return TCL_ERROR;
  }
  pBt = sqlite3TestTextToPtr(argv[1]);
  if( Tcl_GetInt(interp, argv[2], &nCache) ) return TCL_ERROR;

  sqlite3_mutex_enter(pBt->db->mutex);
  sqlite3BtreeEnter(pBt);
  sqlite3BtreeSetCacheSize(pBt, nCache);
  sqlite3BtreeLeave(pBt);
  sqlite3_mutex_leave(pBt->db->mutex);
  return TCL_OK;
}      
示例#12
0
int GraphCmdRange(GRAPH_ARGS)
{
  int range;

  if ((argc != 2) && (argc != 3)) {
    Tcl_AppendResult(interp, "wrong # args", (char *) NULL);
    return TCL_ERROR;
  }

  if (argc == 3) {
    if ((Tcl_GetInt(interp, argv[2], &range) != TCL_OK) ||
	((range != 10) && (range != 120))) {
      Tcl_AppendResult(interp, " bogus args", (char *) NULL);
      return TCL_ERROR;
    }

    graph->range = range;
    NewGraph = 1;
  }

  sprintf(interp->result, "%d", graph->range);

  return TCL_OK;
}
示例#13
0
文件: tkOldTest.c 项目: das/tcltk
	/* ARGSUSED */
static int
ImageCmd(
    ClientData clientData,	/* Main window for application. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    TImageMaster *timPtr = clientData;
    int x, y, width, height;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], "option ?arg ...?", NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "changed") == 0) {
	if (argc != 8) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " changed x y width height imageWidth imageHeight", NULL);
	    return TCL_ERROR;
	}
	if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[4], &width) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[5], &height) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) {
	    return TCL_ERROR;
	}
	Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width,
		timPtr->height);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be changed", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}
示例#14
0
文件: nurbs.c 项目: gsjaardema/CGNS
int
NurbsSurface (Tcl_Interp *interp, int argc, char* argv [])
{
    int result = TCL_OK;
    GLint uOrder = 4;
    GLint vOrder = 4;
    GLenum type = GL_MAP2_VERTEX_3;
    int nCoords = 3;
    FloatArray uKnot = NewFloatArray ();
    FloatArray vKnot = NewFloatArray ();
    FloatArray cPoint = NewFloatArray ();
    GLfloat samplingTolerance = 50.0;
    GLfloat displayMode = GLU_FILL;
    GLfloat culling = GL_FALSE;
    int iarg;
    int dlist = 0;

    for (iarg = 2; iarg < argc; iarg++) {
        int len = (int)strlen (argv [iarg]);
        if (strncmp (argv [iarg], "-uorder", len) == 0) {
            int val;
            iarg++;
            if (iarg >= argc) ERRMSG ("No value given for -uorder");
            if (Tcl_GetInt (interp, argv [iarg], &val) != TCL_OK ||
                    val < 2 || val > 8)
                ERRMSG2 ("\nInvalid value for -uorder:", argv [iarg]);
            uOrder = val;
        }
        else if (strncmp (argv [iarg], "-vorder", len) == 0) {
            int val;
            iarg++;
            if (iarg >= argc) ERRMSG ("No value given for -vorder");
            if (Tcl_GetInt (interp, argv [iarg], &val) != TCL_OK ||
                    val < 2 || val > 8)
                ERRMSG2 ("\nInvalid value for -vorder:", argv [iarg]);
            vOrder = val;
        }
        else if (strncmp (argv [iarg], "-uknots", len) == 0) {
            if (uKnot->count != 0) ERRMSG ("uknot values already given");
            iarg++;
            while (iarg < argc &&
                    !(argv [iarg][0] == '-' && isalpha(argv [iarg][1]))) {
                double val;
                if (Tcl_GetDouble (interp, argv [iarg], &val) != TCL_OK)
                    ERRMSG ("\nError parsing uknot value");
                if (uKnot->count > 0 &&
                        uKnot->value [uKnot->count-1] > val)
                    ERRMSG ("uknot values not in non-descending order");
                AddFloat (uKnot, (GLfloat)val);
                iarg++;
            }
            iarg--;
        }
        else if (strncmp (argv [iarg], "-vknots", len) == 0) {
            if (vKnot->count != 0) ERRMSG ("vknot values already given");
            iarg++;
            while (iarg < argc &&
                    !(argv [iarg][0] == '-' && isalpha(argv [iarg][1]))) {
                double val;
                if (Tcl_GetDouble (interp, argv [iarg], &val) != TCL_OK)
                    ERRMSG ("\nError parsing uknot value");
                if (vKnot->count > 0 &&
                        vKnot->value [vKnot->count-1] > val)
                    ERRMSG ("vknot values not in non-descending order");
                AddFloat (vKnot, (GLfloat)val);
                iarg++;
            }
            iarg--;
        }
        else if (strncmp (argv [iarg], "-controlpoints", len) == 0) {
            if (cPoint->count != 0) ERRMSG ("controlpoint values already given");
            iarg++;
            while (iarg < argc &&
                    !(argv [iarg][0] == '-' && isalpha(argv [iarg][1]))) {
                double val;
                if (Tcl_GetDouble (interp, argv [iarg], &val) != TCL_OK)
                    ERRMSG ("\nError parsing uknot value");
                AddFloat (cPoint, (GLfloat)val);
                iarg++;
            }
            iarg--;
        }
        else if (strncmp (argv [iarg], "-type", len) == 0) {
            iarg++;
            if (iarg >= argc) ERRMSG ("No -type value given");
            if (strcmp (argv [iarg], "map2vertex3") ==0) {
                type = GL_MAP2_VERTEX_3;
                nCoords = 3;
            } else if (strcmp (argv [iarg], "map2vertex4") == 0) {
                type = GL_MAP2_VERTEX_4;
                nCoords = 4;
            } else if (strcmp (argv [iarg], "map2color4") == 0) {
                type = GL_MAP2_COLOR_4;
                nCoords = 4;
            } else if (strcmp (argv [iarg], "map2normal") == 0) {
                type = GL_MAP2_NORMAL;
                nCoords = 3;
            } else if (strcmp (argv [iarg], "map2texturecoord1") == 0) {
                type = GL_MAP2_TEXTURE_COORD_1;
                nCoords = 1;
            } else if (strcmp (argv [iarg], "map2texturecoord2") == 0) {
                type = GL_MAP2_TEXTURE_COORD_2;
                nCoords = 2;
            } else if (strcmp (argv [iarg], "map2texturecoord3") == 0) {
                type = GL_MAP2_TEXTURE_COORD_3;
                nCoords = 3;
            } else if (strcmp (argv [iarg], "map2texturecoord4") == 0) {
                type = GL_MAP2_TEXTURE_COORD_4;
                nCoords = 4;
            } else
                ERRMSG2 ("not a valid type:", argv [iarg]);
        }
        else if (strncmp (argv [iarg], "-samplingtolerance", len) == 0) {
            double val;
            iarg++;
            if (iarg >= argc) ERRMSG ("No -samplingtolerance value given");
            if (Tcl_GetDouble (interp, argv [iarg], &val) != TCL_OK)
                ERRMSG ("\nError parsing sampling tolerance");
            samplingTolerance = (GLfloat)val;
        }
        else if (strncmp (argv [iarg], "-displaymode", len) == 0) {
            iarg++;
            if (iarg >= argc) ERRMSG ("No -displaymode value given");
            if (strcmp (argv [iarg], "fill") == 0) {
                displayMode = GLU_FILL;
            } else if (strcmp (argv [iarg], "outlinepolygon") == 0) {
                displayMode = GLU_OUTLINE_POLYGON;
            } else if (strcmp (argv [iarg], "outlinepatch") == 0) {
                displayMode = GLU_OUTLINE_PATCH;
            } else {
                ERRMSG2 ("not a valid display mode:", argv [iarg]);
            }
        }
        else if (strncmp (argv [iarg], "-culling", len) == 0) {
            int val;
            iarg++;
            if (iarg >= argc) ERRMSG ("No -culling value given");
            if (Tcl_GetBoolean (interp, argv [iarg], &val) != TCL_OK)
                ERRMSG ("\nError parsing culling value");
            culling = (GLfloat)val;
        }
        else {
            ERRMSG2 ("invalid option:", argv [iarg]);
        }
    }

    if (vKnot->count == 0 || uKnot->count == 0 || cPoint->count == 0)
        ERRMSG ("All of -uknot, -vknot and -cpoint options must be specified");

    /* Now try to guess the remaining arguments and call gluNurbsSurface */
    {
        GLint uKnotCount = uKnot->count;
        GLint vKnotCount = vKnot->count;
        GLint vStride = nCoords;
        GLint uStride = nCoords * (vKnotCount - vOrder);
        static GLUnurbsObj* obj = NULL;
        if (uStride * (uKnotCount - uOrder) != cPoint->count) {
            char buf [80];
            sprintf (buf, "%d", uStride * (uKnotCount - uOrder));
            ERRMSG2 ("Incorrect number of controlpoint coordinates. Expected ",
                     buf);
        }
        /* Theoretically, a nurbs object could be allocated for each
        invocation of NurbsSurface and then freed after the creation
         of the display list. However, this produces a segmentation
         violation on AIX OpenGL 1.0. Thus, only one nurbs object is
         ever allocated and never freed.
            */
        if (obj == NULL) obj = gluNewNurbsRenderer();
        dlist = glGenLists (1);
        gluNurbsProperty (obj, GLU_SAMPLING_TOLERANCE, samplingTolerance);
        gluNurbsProperty (obj, GLU_DISPLAY_MODE, displayMode);
        gluNurbsProperty (obj, GLU_CULLING, culling);
        glNewList (dlist, GL_COMPILE);
        gluBeginSurface (obj);
        gluNurbsSurface (obj, uKnotCount, uKnot->value,
                         vKnotCount, vKnot->value,
                         uStride, vStride, cPoint->value,
                         uOrder, vOrder, type);
        gluEndSurface (obj);
        /* This is never used because of a bug in AIX OpenGL 1.0.
        gluDeleteNurbsObj (obj);
            */
        glEndList();
        glFlush();
    }

done:

    DestroyFloatArray (uKnot);
    DestroyFloatArray (vKnot);
    DestroyFloatArray (cPoint);

    if (result == TCL_OK) {
        char tmp[128];
        sprintf (tmp, "%d", dlist);
        Tcl_SetResult(interp, tmp, TCL_VOLATILE);
    }

    return result;
}
int TclModelBuilder_addElastomericBearingPlasticity(ClientData clientData,
    Tcl_Interp *interp, int argc, TCL_Char **argv, Domain *theTclDomain,
    TclModelBuilder *theTclBuilder, int eleArgStart)
{
    // ensure the destructor has not been called
    if (theTclBuilder == 0)  {
        opserr << "WARNING builder has been destroyed - elastomericBearing\n";
        return TCL_ERROR;
    }
    
    Element *theElement = 0;
    int ndm = theTclBuilder->getNDM();
    int ndf = theTclBuilder->getNDF();
    int tag;
    
    if (ndm == 2)  {
        // check plane frame problem has 3 dof per node
        if (ndf != 3)  {
            opserr << "WARNING invalid ndf: " << ndf;
            opserr << ", for plane problem need 3 - elastomericBearing\n";
            return TCL_ERROR;
        } 
        
        // check the number of arguments is correct
        if ((argc-eleArgStart) < 13)  {
            opserr << "WARNING insufficient arguments\n";
            printCommand(argc, argv);
            opserr << "Want: elastomericBearing eleTag iNode jNode kInit fy alpha1 alpha2 mu -P matTag -Mz matTag <-orient x1 x2 x3 y1 y2 y3> <-shearDist sDratio> <-doRayleigh> <-mass m>\n";
            return TCL_ERROR;
        }    
        
        // get the id and end nodes
        int iNode, jNode, matTag, argi, j;
        int recvMat = 0;
        double kInit, fy, alpha1;
        double alpha2 = 0.0;
        double mu = 2.0;
        double shearDistI = 0.5;
        int doRayleigh = 0;
        double mass = 0.0;
        
        if (Tcl_GetInt(interp, argv[1+eleArgStart], &tag) != TCL_OK)  {
            opserr << "WARNING invalid elastomericBearing eleTag\n";
            return TCL_ERROR;
        }
        if (Tcl_GetInt(interp, argv[2+eleArgStart], &iNode) != TCL_OK)  {
            opserr << "WARNING invalid iNode\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetInt(interp, argv[3+eleArgStart], &jNode) != TCL_OK)  {
            opserr << "WARNING invalid jNode\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[4+eleArgStart], &kInit) != TCL_OK)  {
            opserr << "WARNING invalid kInit\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[5+eleArgStart], &fy) != TCL_OK)  {
            opserr << "WARNING invalid fy\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[6+eleArgStart], &alpha1) != TCL_OK)  {
            opserr << "WARNING invalid alpha1\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[7+eleArgStart], &alpha2) != TCL_OK)  {
            opserr << "WARNING invalid alpha2\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[8+eleArgStart], &mu) != TCL_OK)  {
            opserr << "WARNING invalid mu\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        UniaxialMaterial *theMaterials[2];
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-P") == 0)  {
                theMaterials[0] = 0;
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[0] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[0] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-Mz") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[1] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[1] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        if (recvMat != 2)  {
            opserr << "WARNING wrong number of materials\n";
            opserr << "got " << recvMat << " materials, but want 2 materials\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        
        // check for optional arguments
        Vector x = 0;
        Vector y = 0;
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (strcmp(argv[i],"-orient") == 0)  {
                j = i+1;
                int numOrient = 0;
                while (j < argc &&
                    strcmp(argv[j],"-shearDist") != 0 &&
                    strcmp(argv[j],"-doRayleigh") != 0 &&
                    strcmp(argv[j],"-mass") != 0)  {
                        numOrient++;
                        j++;
                }
                if (numOrient == 6)  {
                    argi = i+1;
                    x.resize(3);
                    y.resize(3);
                    double value;
                    // read the x values
                    for (j=0; j<3; j++)  {
                        if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK)  {
                            opserr << "WARNING invalid -orient value\n";
                            opserr << "elastomericBearing element: " << tag << endln;
                            return TCL_ERROR;
                        } else  {
                            argi++;
                            x(j) = value;
                        }
                    }
                    // read the y values
                    for (j=0; j<3; j++)  {
                        if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK)  {
                            opserr << "WARNING invalid -orient value\n";
                            opserr << "elastomericBearing element: " << tag << endln;
                            return TCL_ERROR;
                        } else  {
                            argi++;
                            y(j) = value;
                        }
                    }
                }
                else  {
                    opserr << "WARNING insufficient arguments after -orient flag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-shearDist") == 0)  {
                if (Tcl_GetDouble(interp, argv[i+1], &shearDistI) != TCL_OK)  {
                    opserr << "WARNING invalid -shearDist value\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (strcmp(argv[i], "-doRayleigh") == 0)
                doRayleigh = 1;
        }
        for (int i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-mass") == 0)  {
                if (Tcl_GetDouble(interp, argv[i+1], &mass) != TCL_OK)  {
                    opserr << "WARNING invalid -mass value\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        
        // now create the elastomericBearing
        theElement = new ElastomericBearingPlasticity2d(tag, iNode, jNode, kInit, fy, 
            alpha1, theMaterials, y, x, alpha2, mu, shearDistI, doRayleigh, mass);
        
        if (theElement == 0)  {
            opserr << "WARNING ran out of memory creating element\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        
        // then add the elastomericBearing to the domain
        if (theTclDomain->addElement(theElement) == false)  {
            opserr << "WARNING could not add element to the domain\n";
            opserr << "elastomericBearing element: " << tag << endln;
            delete theElement;
            return TCL_ERROR;
        }       
    }
    
    else if (ndm == 3)  {
        // check space frame problem has 6 dof per node
        if (ndf != 6)  {
            opserr << "WARNING invalid ndf: " << ndf;
            opserr << ", for space problem need 6 - elastomericBearing \n";
            return TCL_ERROR;
        } 
        
        // check the number of arguments is correct
        if ((argc-eleArgStart) < 17)  {
            opserr << "WARNING insufficient arguments\n";
            printCommand(argc, argv);
            opserr << "Want: elastomericBearing eleTag iNode jNode kInit fy alpha1 alpha2 mu -P matTag -T matTag -My matTag -Mz matTag <-orient <x1 x2 x3> y1 y2 y3> <-shearDist sDratio> <-mass m>\n";
            return TCL_ERROR;
        }
        
        // get the id and end nodes
        int iNode, jNode, matTag, argi, i, j;
        int recvMat = 0;
        double kInit, fy, alpha1;
        double alpha2 = 0.0;
        double mu = 2.0;
        double shearDistI = 0.5;
        int doRayleigh = 0;
        double mass = 0.0;
        
        if (Tcl_GetInt(interp, argv[1+eleArgStart], &tag) != TCL_OK)  {
            opserr << "WARNING invalid elastomericBearing eleTag\n";
            return TCL_ERROR;
        }
        if (Tcl_GetInt(interp, argv[2+eleArgStart], &iNode) != TCL_OK)  {
            opserr << "WARNING invalid iNode\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetInt(interp, argv[3+eleArgStart], &jNode) != TCL_OK)  {
            opserr << "WARNING invalid jNode\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[4+eleArgStart], &kInit) != TCL_OK)  {
            opserr << "WARNING invalid kInit\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[5+eleArgStart], &fy) != TCL_OK)  {
            opserr << "WARNING invalid fy\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[6+eleArgStart], &alpha1) != TCL_OK)  {
            opserr << "WARNING invalid alpha1\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[7+eleArgStart], &alpha2) != TCL_OK)  {
            opserr << "WARNING invalid alpha2\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        if (Tcl_GetDouble(interp, argv[8+eleArgStart], &mu) != TCL_OK)  {
            opserr << "WARNING invalid mu\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        UniaxialMaterial *theMaterials[4];
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-P") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid axial matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[0] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[0] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-T") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid torsional matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[1] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[1] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-My") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid moment y matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[2] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[2] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-Mz") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &matTag) != TCL_OK)  {
                    opserr << "WARNING invalid moment z matTag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                theMaterials[3] = OPS_getUniaxialMaterial(matTag);
                if (theMaterials[3] == 0)  {
                    opserr << "WARNING material model not found\n";
                    opserr << "uniaxialMaterial: " << matTag << endln;
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
                recvMat++;
            }
        }
        if (recvMat != 4)  {
            opserr << "WARNING wrong number of materials\n";
            opserr << "got " << recvMat << " materials, but want 4 materials\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        
        // check for optional arguments
        Vector x(0);
        Vector y(3); y(0) = 0.0; y(1) = 1.0; y(2) = 0.0;
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (strcmp(argv[i],"-orient") == 0)  {
                j = i+1;
                int numOrient = 0;
                while (j < argc &&
                    strcmp(argv[j],"-shearDist") != 0 &&
                    strcmp(argv[j],"-doRayleigh") != 0 &&
                    strcmp(argv[j],"-mass") != 0)  {
                        numOrient++;
                        j++;
                }
                if (numOrient == 3)  {
                    argi = i+1;
                    double value;
                    // read the y values
                    for (j=0; j<3; j++)  {
                        if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK)  {
                            opserr << "WARNING invalid -orient value\n";
                            opserr << "elastomericBearing element: " << tag << endln;
                            return TCL_ERROR;
                        } else  {
                            argi++;
                            y(j) = value;
                        }
                    }
                }
                else if (numOrient == 6)  {
                    argi = i+1;
                    x.resize(3);
                    double value;
                    // read the x values
                    for (j=0; j<3; j++)  {
                        if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK)  {
                            opserr << "WARNING invalid -orient value\n";
                            opserr << "elastomericBearing element: " << tag << endln;
                            return TCL_ERROR;
                        } else  {
                            argi++;
                            x(j) = value;
                        }
                    }
                    // read the y values
                    for (j=0; j<3; j++)  {
                        if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK)  {
                            opserr << "WARNING invalid -orient value\n";
                            opserr << "elastomericBearing element: " << tag << endln;
                            return TCL_ERROR;
                        } else  {
                            argi++;
                            y(j) = value;		
                        }
                    }
                }
                else  {
                    opserr << "WARNING insufficient arguments after -orient flag\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-shearDist") == 0)  {
                if (Tcl_GetDouble(interp, argv[i+1], &shearDistI) != TCL_OK)  {
                    opserr << "WARNING invalid -shearDist value\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-doRayleigh") == 0)
                doRayleigh = 1;
        }
        for (i = 9+eleArgStart; i < argc; i++)  {
            if (i+1 < argc && strcmp(argv[i], "-mass") == 0)  {
                if (Tcl_GetDouble(interp, argv[i+1], &mass) != TCL_OK)  {
                    opserr << "WARNING invalid -mass value\n";
                    opserr << "elastomericBearing element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
        
        // now create the elastomericBearing
        theElement = new ElastomericBearingPlasticity3d(tag, iNode, jNode, kInit, fy, 
            alpha1, theMaterials, y, x, alpha2, mu, shearDistI, doRayleigh, mass);
        
        if (theElement == 0)  {
            opserr << "WARNING ran out of memory creating element\n";
            opserr << "elastomericBearing element: " << tag << endln;
            return TCL_ERROR;
        }
        
        // then add the elastomericBearing to the domain
        if (theTclDomain->addElement(theElement) == false)  {
            opserr << "WARNING could not add element to the domain\n";
            opserr << "elastomericBearing element: " << tag << endln;
            delete theElement;
            return TCL_ERROR;
        }       
    }
    
    else  {
        opserr << "WARNING elastomericBearing command only works when ndm is 2 or 3, ndm: ";
        opserr << ndm << endln;
        return TCL_ERROR;
    }
    
    // if get here we have sucessfully created the elastomericBearing and added it to the domain
    return TCL_OK;
}
示例#16
0
/*
** usage:   varint_test  START  MULTIPLIER  COUNT  INCREMENT
**
** This command tests the putVarint() and getVarint()
** routines, both for accuracy and for speed.
**
** An integer is written using putVarint() and read back with
** getVarint() and varified to be unchanged.  This repeats COUNT
** times.  The first integer is START*MULTIPLIER.  Each iteration
** increases the integer by INCREMENT.
**
** This command returns nothing if it works.  It returns an error message
** if something goes wrong.
*/
static int btree_varint_test(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  const char **argv      /* Text of each argument */
){
  u32 start, mult, count, incr;
  u64 in, out;
  int n1, n2, i, j;
  unsigned char zBuf[100];
  if( argc!=5 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
       " START MULTIPLIER COUNT INCREMENT\"", 0);
    return TCL_ERROR;
  }
  if( Tcl_GetInt(interp, argv[1], (int*)&start) ) return TCL_ERROR;
  if( Tcl_GetInt(interp, argv[2], (int*)&mult) ) return TCL_ERROR;
  if( Tcl_GetInt(interp, argv[3], (int*)&count) ) return TCL_ERROR;
  if( Tcl_GetInt(interp, argv[4], (int*)&incr) ) return TCL_ERROR;
  in = start;
  in *= mult;
  for(i=0; i<count; i++){
    char zErr[200];
    n1 = putVarint(zBuf, in);
    if( n1>9 || n1<1 ){
      sprintf(zErr, "putVarint returned %d - should be between 1 and 9", n1);
      Tcl_AppendResult(interp, zErr, 0);
      return TCL_ERROR;
    }
    n2 = getVarint(zBuf, &out);
    if( n1!=n2 ){
      sprintf(zErr, "putVarint returned %d and getVarint returned %d", n1, n2);
      Tcl_AppendResult(interp, zErr, 0);
      return TCL_ERROR;
    }
    if( in!=out ){
      sprintf(zErr, "Wrote 0x%016llx and got back 0x%016llx", in, out);
      Tcl_AppendResult(interp, zErr, 0);
      return TCL_ERROR;
    }
    if( (in & 0xffffffff)==in ){
      u32 out32;
      n2 = getVarint32(zBuf, out32);
      out = out32;
      if( n1!=n2 ){
        sprintf(zErr, "putVarint returned %d and GetVarint32 returned %d", 
                  n1, n2);
        Tcl_AppendResult(interp, zErr, 0);
        return TCL_ERROR;
      }
      if( in!=out ){
        sprintf(zErr, "Wrote 0x%016llx and got back 0x%016llx from GetVarint32",
            in, out);
        Tcl_AppendResult(interp, zErr, 0);
        return TCL_ERROR;
      }
    }

    /* In order to get realistic timings, run getVarint 19 more times.
    ** This is because getVarint is called about 20 times more often
    ** than putVarint.
    */
    for(j=0; j<19; j++){
      getVarint(zBuf, &out);
    }
    in += incr;
  }
  return TCL_OK;
}
示例#17
0
int
TkpUseWindow(
    Tcl_Interp *interp,		/* If not NULL, used for error reporting
				 * if string is bogus. */
    Tk_Window tkwin,		/* Tk window that does not yet have an
				 * associated X window. */
    CONST char *string)		/* String identifying an X window to use
				 * for tkwin;  must be an integer value. */
{
    TkWindow *winPtr = (TkWindow *) tkwin;
    TkWindow *usePtr;
    MacDrawable *parent, *macWin;
    Container *containerPtr;
    XEvent event;
    int result;

    if (winPtr->window != None) {
	panic("TkpUseWindow: X window already assigned");
    }
    
    /*
     * Decode the container pointer, and look for it among the 
     *list of available containers.
     *
     * N.B. For now, we are limiting the containers to be in the same Tk
     * application as tkwin, since otherwise they would not be in our list
     * of containers.
     *
     */
     
    if (Tcl_GetInt(interp, string, &result) != TCL_OK) {
	return TCL_ERROR;
    }

    usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, (Window) result);

    if (usePtr == NULL) {
        Tcl_AppendResult(interp, "Tk window does not correspond to id \"",
                string, "\"", (char *) NULL);
        return TCL_ERROR;
    } else {
        if (!(usePtr->flags & TK_CONTAINER)) {
	    Tcl_AppendResult(interp, "window \"", usePtr->pathName,
                    "\" doesn't have -container option set", (char *) NULL);
	    return TCL_ERROR;
        }
    }

    parent = (MacDrawable *) result;

    /*
     * Save information about the container and the embedded window
     * in a Container structure.  Currently, there must already be an existing
     * Container structure, since we only allow the case where both container 
     * and embedded app. are in the same process.
     */

    for (containerPtr = firstContainerPtr; containerPtr != NULL;
	    containerPtr = containerPtr->nextPtr) {
	if (containerPtr->parent == (Window) parent) {
	    winPtr->flags |= TK_BOTH_HALVES;
	    containerPtr->parentPtr->flags |= TK_BOTH_HALVES;
	    break;
	}
    }
    
    /*
     * Make the embedded window.  
     */

    macWin = (MacDrawable *) ckalloc(sizeof(MacDrawable));
    if (macWin == NULL) {
	winPtr->privatePtr = NULL;
	return TCL_ERROR;
    }
    
    macWin->winPtr = winPtr;
    winPtr->privatePtr = macWin;

    /*
     * The portPtr will be NULL for a Tk in Tk embedded window.
     * It is none of our business what it is for a Tk not in Tk embedded window,
     * but we will initialize it to NULL, and let the registerWinProc 
     * set it.  In any case, you must always use TkMacGetDrawablePort 
     * to get the portPtr.  It will correctly find the container's port.
     */

    macWin->portPtr = (GWorldPtr) NULL;

    macWin->clipRgn = NewRgn();
    macWin->aboveClipRgn = NewRgn();
    macWin->referenceCount = 0;
    macWin->flags = TK_CLIP_INVALID;
    macWin->toplevel = macWin;
    macWin->toplevel->referenceCount++;
   
    winPtr->flags |= TK_EMBEDDED;
    
    
    /*
     * Make a copy of the TK_EMBEDDED flag, since sometimes
     * we need this to get the port after the TkWindow structure
     * has been freed.
     */
     
    macWin->flags |= TK_EMBEDDED;
    
    /*
     * Now check whether it is embedded in another Tk widget.  If not (the first
     * case below) we see if there is an in-process embedding handler registered,
     * and if so, let that fill in the rest of the macWin.
     */
    
    if (containerPtr == NULL) {
	/*
	 * If someone has registered an in process embedding handler, then 
	 * see if it can handle this window...
	 */
	
	if (gMacEmbedHandler == NULL ||
		gMacEmbedHandler->registerWinProc(result, (Tk_Window) winPtr) != TCL_OK) {
	    Tcl_AppendResult(interp, "The window ID ", string,
	            " does not correspond to a valid Tk Window.",
		     (char *) NULL);
	    return TCL_ERROR;	
	} else {
	    containerPtr = (Container *) ckalloc(sizeof(Container));

	    containerPtr->parentPtr = NULL;
	    containerPtr->embedded = (Window) macWin;
	    containerPtr->embeddedPtr = macWin->winPtr;
	    containerPtr->nextPtr = firstContainerPtr;
	    firstContainerPtr = containerPtr;
	    
	}    
    } else {
        
	/* 
         * The window is embedded in another Tk window.
         */ 
	
	macWin->xOff = parent->winPtr->privatePtr->xOff +
	        parent->winPtr->changes.border_width +
	        winPtr->changes.x;
	macWin->yOff = parent->winPtr->privatePtr->yOff +
	        parent->winPtr->changes.border_width +
	        winPtr->changes.y;
    
    
        /*
         * Finish filling up the container structure with the embedded window's 
         * information.
         */
     
	containerPtr->embedded = (Window) macWin;
	containerPtr->embeddedPtr = macWin->winPtr;

	/*
         * Create an event handler to clean up the Container structure when
         * tkwin is eventually deleted.
         */

        Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc,
	        (ClientData) winPtr);

    }

   /* 
     * TODO: need general solution for visibility events.
     */
     
    event.xany.serial = Tk_Display(winPtr)->request;
    event.xany.send_event = False;
    event.xany.display = Tk_Display(winPtr);
	
    event.xvisibility.type = VisibilityNotify;
    event.xvisibility.window = (Window) macWin;;
    event.xvisibility.state = VisibilityUnobscured;
    Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL);

    
    /* 
     * TODO: need general solution for visibility events.
     */
     
    event.xany.serial = Tk_Display(winPtr)->request;
    event.xany.send_event = False;
    event.xany.display = Tk_Display(winPtr);
	
    event.xvisibility.type = VisibilityNotify;
    event.xvisibility.window = (Window) macWin;;
    event.xvisibility.state = VisibilityUnobscured;
    Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL);
     
    return TCL_OK;
}
示例#18
0
int
TclModelBuilder_addZeroLengthRocking(ClientData clientData, Tcl_Interp *interp,
                              int argc, TCL_Char **argv,
                              Domain *theDomain,
                              TclModelBuilder *theBuilder) {
    
    int ndm = theBuilder->getNDM(); // the spatial dimension of the problem
    
    //
    // first scan the command line to obtain eleID, iNode, jNode, and the orientation 
    // of ele xPrime and yPrime not along the global x and y axis
    //
    
    int eleTag, iNode, jNode;
    
    // a quick check on number of args
    if (argc < 9) {
        opserr << "WARNING too few arguments " <<
        "want - element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        
        return TCL_ERROR;
    }
    
    // get the ele tag 
    if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
        opserr << "WARNING invalied eleTag " << argv[2] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // get the two end nodes
    if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
        opserr << "WARNING invalied iNode " << argv[3] << 
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        
        return TCL_ERROR;
    }
    
    if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
        opserr << "WARNING invalid jNode " << argv[4] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // look for rocking required inputs
    double kr = 0;
    double R = 0;
    double theta = 0;
    double kap = 1.0e12;
    
    // rotational stiffness
    if (Tcl_GetDouble(interp, argv[5], &kr) != TCL_OK) {
        opserr << "WARNING invalid kr " << argv[5] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // rocking radius
    if (Tcl_GetDouble(interp, argv[6], &R) != TCL_OK) {
        opserr << "WARNING invalid radius " << argv[6] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // theta0
    if (Tcl_GetDouble(interp, argv[7], &theta) != TCL_OK) {
        opserr << "WARNING invalid theta0 " << argv[7] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // kappa
    if (Tcl_GetDouble(interp, argv[8], &kap) != TCL_OK) {
        opserr << "WARNING invalid kappa " << argv[8] <<
        "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
        return TCL_ERROR;
    }
    
    // create the vectors for the element orientation
    Vector x(3); x(0) = 1.0; x(1) = 0.0; x(2) = 0.0;
    Vector y(3); y(0) = 0.0; y(1) = 1.0; y(2) = 0.0;
    double xi = 1.0e-8;
    double dTol = 1.0e-7;
    double vTol = 1.0e-7;
    int argi = 9;
    
    while (argi < argc) {
        if (strcmp(argv[argi],"-orient") == 0) {
            if (argc < (argi+7)) {
                opserr << "WARNING not enough parameters after -orient flag for ele " << eleTag <<
                "- element ZeroLengthRocking eleTag? iNode? jNode? " <<
                "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";	      
                return TCL_ERROR;
                
            } else {
                argi++;
                double value;
                // read the x values
                for (int i=0; i<3; i++)  {
                    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
                        opserr << "WARNING invalid -orient value for ele  " << eleTag << argv[i] <<
                        "- element ZeroLength eleTag? iNode? jNode? " <<
                        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
                        return TCL_ERROR;
                    } else {
                        argi++;
                        x(i) = value;
                    }
                }
                // read the y values
                for (int j=0; j<3; j++)  {
                    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
                        opserr << "WARNING invalid -orient value for ele  " <<
                        eleTag << argv[argi] <<
                        "- element ZeroLength eleTag? iNode? jNode? " <<
                        "kr? radius? theta0? kappa? <-orient x1? x2? x3? y1? y2? y3?>\n";
                        return TCL_ERROR;
                    } else {
                        argi++;
                        y(j) = value;
                    }
                }
            }
            
        } else if (strcmp(argv[argi],"-xi") == 0) {
            if (argc < (argi+2)) {
                opserr << "WARNING not enough parameters after -xi flag for ele " << eleTag << endln;
                return TCL_ERROR;
            } else {
                argi++;
                if (Tcl_GetDouble(interp, argv[argi], &xi) != TCL_OK) {
                    opserr << "WARNING invalid -xi value for ele  " << eleTag << endln;
                    return TCL_ERROR;
                } else
                    argi++;
            }
            
        } else if (strcmp(argv[argi],"-dTol") == 0) {
            if (argc < (argi+2)) {
                opserr << "WARNING not enough parameters after -dTol flag for ele " << eleTag << endln;
                return TCL_ERROR;
            } else {
                argi++;
                if (Tcl_GetDouble(interp, argv[argi], &dTol) != TCL_OK) {
                    opserr << "WARNING invalid -dTol value for ele  " << eleTag << endln;
                    return TCL_ERROR;
                } else
                    argi++;
            }

        } else if (strcmp(argv[argi],"-vTol") == 0) {
            if (argc < (argi+2)) {
                opserr << "WARNING not enough parameters after -vTol flag for ele " << eleTag << endln;
                return TCL_ERROR;
            } else {
                argi++;
                if (Tcl_GetDouble(interp, argv[argi], &vTol) != TCL_OK) {
                    opserr << "WARNING invalid -vTol value for ele  " << eleTag << endln;
                    return TCL_ERROR;
                } else
                    argi++;
            }
            
        } else
            argi++;
    }
    
    //
    // now we create the element and add it to the domain
    //
    Element *theEle;
    theEle = new ZeroLengthRocking(eleTag, ndm, iNode, jNode, x, y, 
                                   kr, R, theta, kap, xi, dTol, vTol);
    if (theEle == 0)
        return TCL_ERROR;
    
    if (theDomain->addElement(theEle) == false)
        return TCL_ERROR;
     
    return TCL_OK;
}
示例#19
0
int
TclModelBuilder_addZeroLengthContact3D(ClientData clientData, Tcl_Interp *interp,
				       int argc, TCL_Char **argv,
				       Domain *theDomain,
				       TclModelBuilder *theBuilder) {
  
  
  int ndm = theBuilder->getNDM(); // the spatial dimension of the problem
  
  //
  // first scan the command line to obtain eleID, SlaveNode, MasterNode,
  
  int eleTag, iNode, jNode;
  
  
  //opserr << argc;
  
  // a quick check on number of args
  if (argc < 10) {
    opserr << "ZeroLengthContact3D::WARNING too few arguments " <<
      "want - element ZeroLengthContact3D eleTag? iNode? jNode? Kn? Kt? fs? c? dir?" ;
    return TCL_ERROR;
  }
  
  // get the ele tag
  if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalied eleTag " << argv[2] << "\n";
    return TCL_ERROR;
  }
  
  
  // get the two end nodes
  if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalied iNode " << argv[3] <<  "\n";
    
    return TCL_ERROR;
  }
  
  if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid jNode " << argv[4] << "\n" ;
    return TCL_ERROR;
  }
  
  double Kn, Kt, fs, c;
  
  // read the material properties
  if (Tcl_GetDouble(interp, argv[5], &Kn) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid Kn " << argv[5] << "\n" ;
    return TCL_ERROR;
  }
  
  if (Tcl_GetDouble(interp, argv[6], &Kt) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid Kt " << argv[6] << "\n" ;
    return TCL_ERROR;
  }
  
  if (Tcl_GetDouble(interp, argv[7], &fs) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid fs " << argv[7] << "\n" ;
    return TCL_ERROR;
  }
  
  if (Tcl_GetDouble(interp, argv[8], &c) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid c " << argv[8] << "\n" ;
    return TCL_ERROR;
  }
  
  int dir;
  
  if (Tcl_GetInt(interp, argv[9], &dir) != TCL_OK) {
    opserr << "ZeroLengthContact3D::WARNING invalid direction " << argv[9] << "\n" ;
    return TCL_ERROR;
  }
  
  //
  // now we create the element and add it to the domain
  //
  
  Element *theEle;
  
  double originX, originY;
  originX=0;
  originY=0;
  
  if (dir==0) {
    if (argc == 12) {
      if (Tcl_GetDouble(interp, argv[10], &originX) != TCL_OK) {
	opserr << "ZeroLengthContact3D::WARNING invalid originX " << argv[9] << "\n" ;
	return TCL_ERROR;
      }
      if (Tcl_GetDouble(interp, argv[11], &originY) != TCL_OK) {
	opserr << "ZeroLengthContact3D::WARNING invalid originY " << argv[10] << "\n" ;
	return TCL_ERROR;
      }
    }
  }
  
  
  theEle = new ZeroLengthContact3D(eleTag, iNode, jNode, dir, Kn, Kt,
				   fs, c, originX, originY);
  
  if (theEle == 0) {
    return TCL_ERROR;
  }
  
  if (theDomain->addElement(theEle) == false) {
    return TCL_ERROR;
  }
  
  // return the memory we stole and return OK
  return TCL_OK;
}
示例#20
0
int
TclModelBuilder_addZeroLength(ClientData clientData, Tcl_Interp *interp,
			      int argc, TCL_Char **argv,
			      Domain *theDomain,
			      TclModelBuilder *theBuilder) {

    int ndm = theBuilder->getNDM(); // the spatial dimension of the problem

    //
    // first scan the command line to obtain eleID, iNode, jNode, material ID's
    // and their directions, and the orientation of ele xPrime and yPrime not
    // along the global x and y axis
    //
    
    int eleTag, iNode, jNode;
    
    // a quick check on number of args
    if (argc < 9) {
      opserr << "WARNING too few arguments " <<
	"want - element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";

	return TCL_ERROR;
    }

    // get the ele tag 
    if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
      opserr << "WARNING invalied eleTag " << argv[2] <<
	"- element ZeroLength eleTag? iNode? jNode? -mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // get the two end nodes
    if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
      opserr << "WARNING invalied iNode " << argv[3] << 
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";

	return TCL_ERROR;
    }

    if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
      opserr << "WARNING invalid jNode " << argv[4] <<
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // create an array of material pointers, to do this first count
    // the materials to create the array then get matID's and from ModelBuilder
    // obtain pointers to the material objects

    // read the number of materials
    int numMat = 0;
    if (strcmp(argv[5],"-mat") != 0) {
      opserr << "WARNING expecting -mat flag %s %s %s %s\n" << argv[5] <<
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";

	return TCL_ERROR;	
    }

    int argi = 6; 
    while ((argi < argc) && (strcmp(argv[argi],"-dir") != 0)) {
	numMat++;
	argi++;
    }

    if (argi == argc) { // check we encountered the -dirn flag
      opserr << "WARNING no -dirn flag encountered " <<
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }	

    if (numMat == 0) {
      opserr << "WARNING no materials specified " << 
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat <matID1? ... -dir irMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // create the array
    UniaxialMaterial **theMats = new UniaxialMaterial *[numMat];
    UniaxialMaterial **theDampMats = new UniaxialMaterial *[numMat];

    if (theMats == 0) {
      opserr << "WARNING out of memory " <<
	"creating material array of size " << numMat <<
	"- element ZeroLength eleTag? iNode? jNode? " <<
	"-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // fill in the material array
    argi=6; 
    for (int i=0; i<numMat; i++) {
      theDampMats[i] = 0;

      int matID;	
      
      // read the material tag	
      if (Tcl_GetInt(interp, argv[argi], &matID) != TCL_OK) {
	opserr << "WARNING invalid matID " << argv[argi] <<
	  "- element ZeroLength eleTag? iNode? jNode? " <<
	  "-mat matID1? ... -dir dirMat1? .. " <<
	  "<-orient x1? x2? x3? y1? y2? y3?>\n";
	delete [] theMats;	    
        return TCL_ERROR;
      } else {

	// get a pointer to the material from the modelbuilder	    
	argi++;
	UniaxialMaterial *theMat = OPS_getUniaxialMaterial(matID);
	if (theMat == 0) {
	  opserr << "WARNING no material " << matID <<
	    "exitsts - element ZeroLength eleTag? iNode? jNode? " <<
	    "-mat matID1? ... -dir dirMat1? .. " <<
	    "<-orient x1? x2? x3? y1? y2? y3?>\n"  ;
	  delete [] theMats;		
	  return TCL_ERROR;		
	} else {
	  
		// add the material to the array
		theMats[i] = theMat;
	    }
	}
    }
    

    // now read the dirn ID's for the materials added
    argi = 6 + numMat;
    if (strcmp(argv[argi],"-dir") != 0) {
      opserr << "WARNING expecting -dirn flag " << argv[argi] << 
	  "- element ZeroLength eleTag? iNode? jNode? " <<
	  "-mat matID1? ... -dir dirMat1? .. " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";

    delete [] theMats;
	return TCL_ERROR;	
    }    
    if ((argi + numMat) > argc) {
	opserr << "WARNING not enough directions provided for ele " << eleTag <<
	  "- element ZeroLength eleTag? iNode? jNode? " <<
	  "-mat matID1? ... -dir dirMat1? .. " <<
	  "<-orient x1? x2? x3? y1? y2? y3?>\n";
	
	delete [] theMats;	
	return TCL_ERROR;		
    }
    
    // create an ID to hold the directions
    ID theDirns(numMat);
    argi++; 
    int dirnID;	

    // read the dirn identifiers
    for (int j=0; j<numMat; j++) {
	if (Tcl_GetInt(interp, argv[argi], &dirnID) != TCL_OK) {
	  opserr << "WARNING invalid directiion " << argv[argi] <<
	    "- element ZeroLength eleTag? iNode? jNode? " <<
	    "-mat matID1? ... -dir dirMat1? .. " <<
	    "<-orient x1? x2? x3? y1? y2? y3?>\n";	
	  
	  delete [] theMats;	    
	  return TCL_ERROR;
	} else {
	  theDirns[j] = dirnID -1; // the minus g3 to C++
	  argi++;
	}
    }

    // create the vectors for the element orientation
    Vector x(3); x(0) = 1.0; x(1) = 0.0; x(2) = 0.0;
    Vector y(3); y(0) = 0.0; y(1) = 1.0; y(2) = 0.0;

    // finally check the command line to see if user specified orientation
    int doRayleighDamping = 0;

    while (argi < argc) {
	if (strcmp(argv[argi],"-orient") == 0) {
	    if (argc < (argi+7)) {
	      opserr << "WARNING not enough parameters after -orient flag for ele " << eleTag <<
		"- element ZeroLength eleTag? iNode? jNode? " <<
		"-mat matID1? ... -dir dirMat1? .. " <<
		"<-orient x1? x2? x3? y1? y2? y3?>\n";	      
	      delete [] theMats;		
	      return TCL_ERROR;		
	    } else {
	      argi++;
	      double value;
	      // read the x values
	      for (int i=0; i<3; i++)  {
		if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
		  opserr << "WARNING invalid -orient value for ele  " << eleTag << argv[i] <<
		    "- element ZeroLength eleTag? iNode? jNode? " <<
		    "-mat matID1? ... -dir dirMat1? .. " <<
		    "<-orient x1? x2? x3? y1? y2? y3?>\n";	
		  delete [] theMats;			
		  return TCL_ERROR;
		} else {
		  argi++;
		  x(i) = value;
		}
	      }
	      // read the y values
	      for (int j=0; j<3; j++)  {
		if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
		  opserr << "WARNING invalid -orient value for ele  " <<
		    eleTag << argv[argi] <<
		    "- element ZeroLength eleTag? iNode? jNode? " <<
		    "-mat matID1? ... -dir dirMat1? .. " <<
		    "<-orient x1? x2? x3? y1? y2? y3?>\n";	
		  delete [] theMats;			
		  return TCL_ERROR;
		} else {
		  argi++;
		  y(j) = value;		
		}
	      }
	    }
	    
	    argi++;
	} else 	if (strcmp(argv[argi],"-doRayleigh") == 0)  {
	  doRayleighDamping = 1;
	  argi++;
	  if (argi < argc) 
	    if ((Tcl_GetInt(interp, argv[argi], &doRayleighDamping) == TCL_OK))
	      argi++;
	} else 	if (strcmp(argv[argi],"-dampMats") == 0)  {
	  doRayleighDamping = 2;
	  argi++;
	  for (int i=0; i<numMat; i++) {

	    int matID;	
      
	    // read the material tag	
	    if (Tcl_GetInt(interp, argv[argi], &matID) != TCL_OK) {
	      opserr << "WARNING invalid matID " << argv[argi] <<
		"- element ZeroLength eleTag? iNode? jNode? " <<
		"-mat matID1? ... -dir dirMat1? .. " <<
		"<-orient x1? x2? x3? y1? y2? y3?>\n";
	      delete [] theMats;	    
	      return TCL_ERROR;
	    } else {
	      UniaxialMaterial *theMat = OPS_getUniaxialMaterial(matID);
	      if (theMat == 0) {
		opserr << "WARNING no material " << matID <<
		  "exitsts - element ZeroLength eleTag? iNode? jNode? " <<
		  "-mat matID1? ... -dir dirMat1? .. " <<
		  "<-orient x1? x2? x3? y1? y2? y3?>\n"  ;
		delete [] theMats;		
		return TCL_ERROR;		
	      } else {
		theDampMats[i] = theMat;
	      }
	    }

	    argi++;
	  }

	}  else



	  argi++;
    }
    
    //
    // now we create the element and add it to the domain
    //

    Element *theEle;

    if (doRayleighDamping != 2) 
      theEle = new ZeroLength(eleTag, ndm, iNode, jNode, x, y, numMat, theMats, theDirns, doRayleighDamping);
    else
      theEle = new ZeroLength(eleTag, ndm, iNode, jNode, x, y, numMat, theMats, theDampMats, theDirns, doRayleighDamping);

    if (theEle == 0) {
	delete [] theMats;	
	return TCL_ERROR;
    }
   
    if (theDomain->addElement(theEle) == false) {
	delete [] theMats;
	return TCL_ERROR;
    }

    // return the memory we stole and return OK
    delete [] theMats;    
    delete [] theDampMats;
    return TCL_OK;
}
示例#21
0
int
NsTclConfigCmd(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
{
    char *value;
    int   i;
    int   fHasDefault = NS_FALSE;
    int	  defaultIndex = 0;

    if (argc < 3 || argc > 5) {
        Tcl_AppendResult(interp, "wrong # args:  should be \"",
            argv[0], " ?-exact | -bool | -int? section key ?default?\"", NULL);
        return TCL_ERROR;
    }

    if (argv[1][0] == '-') {
	if (argc == 5) {
	    fHasDefault = NS_TRUE;
	    defaultIndex = 4;
	}
    } else if (argc == 4) {
	fHasDefault = NS_TRUE;
	defaultIndex = 3;
    }
   
    if (STREQ(argv[1], "-exact")) {
        value = Ns_ConfigGetValueExact(argv[2], argv[3]);

	if (value == NULL && fHasDefault) {
	    value = argv[defaultIndex];
	}
    } else if (STREQ(argv[1], "-int")) {
        if (Ns_ConfigGetInt(argv[2], argv[3], &i)) {
            Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
            return TCL_OK;
        } else if (fHasDefault) {
	    if (Tcl_GetInt(interp, argv[defaultIndex], &i) != TCL_OK) {
		return TCL_ERROR;
	    }
            Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
	    return TCL_OK;
	}
        value = NULL;
    } else if (STREQ(argv[1], "-bool")) {
        int             iValue;

        if (Ns_ConfigGetBool(argv[2], argv[3], &iValue) == NS_FALSE) {
	    if (fHasDefault) {
		if (   Tcl_GetBoolean(interp, argv[defaultIndex], &iValue)
		    != TCL_OK) {
		    return TCL_ERROR;
		}

		value = (iValue) ? "1" : "0";
		
	    } else {
		value = NULL;
	    }
        } else {
	    value = (iValue) ? "1" : "0";
        }
    } else if (argc == 3 || argc == 4) {
        value = Ns_ConfigGetValue(argv[1], argv[2]);

	if (value == NULL && fHasDefault) {
	    value = argv[defaultIndex];
	}
    } else {
        Tcl_AppendResult(interp, "wrong # args:  should be \"",
            argv[0], " ?-exact | -bool | -int? section key ?default?\"", NULL);
        return TCL_ERROR;
    }
    if (value != NULL) {
	Tcl_SetResult(interp, value, TCL_STATIC);
    }
    return TCL_OK;
}
示例#22
0
BOOL CSemanticStrView::Create(LPCTSTR lpszClassName, LPCTSTR lpszWindowName, DWORD dwStyle, const RECT& rect, CWnd* pParentWnd, UINT nID, CCreateContext* pContext) 
{
	// TODO: Add your specialized code here and/or call the base class
   m_Menu.LoadMenu(IDR_ROSSDETYPE);
   pParentWnd->SetMenu( &m_Menu );
   char s[2000];
   CRect R = rect;
   //R.right = rect.right + 100;
   pParentWnd->SetWindowPos(0, 120, 120, 840, 500,0);
	
   BOOL ok = CWnd::Create(lpszClassName, lpszWindowName, dwStyle, R, pParentWnd, nID, pContext);

   if (ok) {

		int retcode;
		CString winhnd, cmd;

		m_tkname.Format(".tk%d",++TclWindowCounter);   // name this window .tk1 .tk2 etc

		winhnd.Format("0x%08X",m_hWnd);
		cmd.Format("toplevel %s -use %s",m_tkname,winhnd);
        strcpy (s, cmd);
		retcode = Tcl_Eval(theInterp,s);
		if (retcode!=TCL_OK) {
			Tcl_SetResult(theInterp,"Cannot create TK child window",TCL_VOLATILE);
			return ok;
		}

		Tk_Window tkmain = Tk_MainWindow(theInterp);
		if (tkmain) {
			
			//get the tk window token
			strcpy (s, m_tkname);
			m_tkwin = Tk_NameToWindow(theInterp, s, tkmain);
			Tcl_DoOneEvent(TCL_ALL_EVENTS|TCL_DONT_WAIT);   //force window creation
			
			// get the HWND
			cmd.Format("winfo id %s",m_tkname);
			strcpy (s, cmd);
			retcode = Tcl_Eval(theInterp,s);
			if (retcode==TCL_OK) {
				int i;
				retcode = Tcl_GetInt(theInterp,theInterp->result,&i);
				if (retcode==TCL_OK) {
				  m_tkhwnd = (HWND)i;
				}
			}
			SwitchGraph(m_tkname);

			CString cmd;
            cmd.Format("source $env(GRAPHLET_DIR)/lib/graphscript/ross/semstruct.tcl");
            strcpy (s, cmd);
            retcode = Tcl_Eval(theInterp,s);
	        if (retcode!=TCL_OK) {
				AfxMessageBox (theInterp->result);
				return FALSE;
			};

            cmd.Format("initialize_graphic $main");
            strcpy (s, cmd);
            retcode = Tcl_Eval(theInterp,s);
	        if (retcode!=TCL_OK) {
				AfxMessageBox (theInterp->result);
				return FALSE;
			};

			

		}
	}
	return ok;
	
}
示例#23
0
int
TclModelBuilder_addZeroLengthSection(ClientData clientData, Tcl_Interp *interp,
			      int argc, TCL_Char **argv,
			      Domain *theDomain,
			      TclModelBuilder *theBuilder) {

    int ndm = theBuilder->getNDM(); // the spatial dimension of the problem

    //
    // first scan the command line to obtain eleID, iNode, jNode, material ID's
    // and their directions, and the orientation of ele xPrime and yPrime not
    // along the global x and y axis
    //
    
    int eleTag, iNode, jNode;
    
    // a quick check on number of args
    if (argc < 6) {
	opserr << "WARNING too few arguments " <<
	  "want - element zeroLengthSection eleTag? iNode? jNode? " <<
	  "secTag? " <<
	  "<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // get the ele tag 
    if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
      opserr << "WARNING invalied eleTag " << argv[2] <<
	"- element zeroLengthSection eleTag? iNode? jNode? " <<
	"secTag? " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";	
	return TCL_ERROR;
    }

    // get the two end nodes
    if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
      opserr << "WARNING invalied iNode " << argv[3] <<
	"- element zeroLengthSection eleTag? iNode? jNode? " <<
	"secTag? " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";	

      return TCL_ERROR;
    }

    if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
      opserr << "WARNING invalid jNode " << argv[4] <<
	"- element zeroLengthSection eleTag? iNode? jNode? " <<
	"secTag? " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";	
      return TCL_ERROR;
    }

	int secTag;

    if (Tcl_GetInt(interp, argv[5], &secTag) != TCL_OK) {
      opserr << "WARNING invalid secTag " << argv[5] <<
	"- element zeroLengthSection eleTag? iNode? jNode? " <<
	"secTag? " <<
	"<-orient x1? x2? x3? y1? y2? y3?>\n";	
      return TCL_ERROR;
    }

    // create the vectors for the element orientation
    Vector x(3); x(0) = 1.0; x(1) = 0.0; x(2) = 0.0;
    Vector y(3); y(0) = 0.0; y(1) = 1.0; y(2) = 0.0;

    int argi = 6;
    int doRayleighDamping = 1;

    // finally check the command line to see if user specified orientation
    while (argi < argc) {
      if (strcmp(argv[argi],"-orient") == 0) {
	if (argc < (argi+7)) {
	  opserr << "WARNING not enough parameters after -orient flag for ele " <<
	    eleTag << "- element zeroLengthSection eleTag? iNode? jNode? secTag? " <<
	    "<-orient x1? x2? x3? y1? y2? y3?>\n";			
	  return TCL_ERROR;		
	} else {
	  argi++;
	  double value;
	  // read the x values
	  for (int i=0; i<3; i++)  {
	    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
	      opserr << "WARNING invalid -orient value for ele  " <<
		eleTag << argv[argi] <<
		"- element zeroLengthSection eleTag? iNode? jNode secTag? " <<
		"<-orient x1? x2? x3? y1? y2? y3?>\n";	
	      return TCL_ERROR;
	    } else {
	      argi++;
	      x(i) = value;
	    }
	  }
	  // read the y values
	  for (int j=0; j<3; j++)  {
	    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
	      opserr << "WARNING invalid -orient value for ele  " <<
		eleTag << argv[argi] <<
		"- element zeroLengthSection eleTag? iNode? jNode? secTag? " <<
		"<-orient x1? x2? x3? y1? y2? y3?>\n";	
	      return TCL_ERROR;
	    } else {
	      argi++;
	      y(j) = value;		
	    }
	  }
	}
	} else 	if (strcmp(argv[argi],"-doRayleigh") == 0)  {
	  doRayleighDamping = 1;
	  argi++;
	  if (argi < argc) 
	    if ((Tcl_GetInt(interp, argv[argi], &doRayleighDamping) == TCL_OK))
	      argi++;	    
	}  else
	  argi++;
    }
    
    //
    // now we create the element and add it to the domain
    //

    SectionForceDeformation *theSection = theBuilder->getSection(secTag);
    
    if (theSection == 0) {
      opserr << "zeroLengthSection -- no section with tag " << secTag << " exists in Domain\n";
      return TCL_ERROR;		
    }
    
    Element *theEle = new ZeroLengthSection(eleTag, ndm, iNode, jNode, x, y, *theSection, doRayleighDamping);
    
    if (theEle == 0)
      return TCL_ERROR;
    
    if (theDomain->addElement(theEle) == false)
      return TCL_ERROR;
    
    return TCL_OK;
}
示例#24
0
extern "C" void *vmd_mpi_parallel_for_scheduler(void *voidparms) {
  parallel_for_parms *parfor = (parallel_for_parms *) voidparms;

  // Run the for loop management code on node zero.
  // Do the work on all the other nodes...
#if defined(VMDTHREADS)
  int i;
  wkf_tasktile_t curtile;
  while (wkf_shared_iterator_next_tile(&parfor->iter, 1, &curtile) != WKF_SCHED_DONE) {
    i = curtile.start;
#else
  int i;
  for (i=parfor->loop.start; i<parfor->loop.end; i++) {
#endif
    int reqnode;
    MPI_Status rcvstat;
    MPI_Recv(&reqnode, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, 
             MPI_COMM_WORLD, &rcvstat); 
    MPI_Send(&i, 1, MPI_INT, reqnode, VMD_MPI_TAG_FOR_REQUEST, 
             MPI_COMM_WORLD);
  }

  // tell all nodes we're done with all of the work
  int node;
  for (node=1; node<parfor->numnodes; node++) {
    int reqnode;
    MPI_Status rcvstat;
    MPI_Recv(&reqnode, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, 
             MPI_COMM_WORLD, &rcvstat); 

    i=-1; // indicate that the for loop is completed
    MPI_Send(&i, 1, MPI_INT, reqnode, VMD_MPI_TAG_FOR_REQUEST, 
             MPI_COMM_WORLD);
  }

  return NULL;
}

#endif



int text_cmd_parallel(ClientData cd, Tcl_Interp *interp, int argc, const char *argv[]) {
  VMDApp *app = (VMDApp *)cd;

  if(argc<2) {
    Tcl_SetResult(interp,
      (char *)
      "Parallel job query commands:\n"
      "  parallel nodename\n"
      "  parallel noderank\n"
      "  parallel nodecount\n"
      "Parallel collective operations (all nodes MUST participate):\n"
      "  parallel allgather <object>\n"
      "  parallel allreduce <tcl reduction proc> <object>\n"
      "  parallel barrier\n"
      "  parallel for <startcount> <endcount> <tcl callback proc> <user data>",
      TCL_STATIC);
    return TCL_ERROR;
  }

  // XXX hack to make Swift/T cooperate with VMD when using VMD's MPI
  // communicator
  if (!strcmp(argv[1], "swift_clone_communicator")) {
    swift_mpi_init(interp);
    return TCL_OK;
  }

  // return the MPI node name
  if (!strcmp(argv[1], "nodename")) {
    Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(app->par_name(), strlen(app->par_name())));
    Tcl_SetObjResult(interp, tcl_result);
    return TCL_OK;
  }

  // return the MPI node rank
  if (!strcmp(argv[1], "noderank")) {
    Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_rank()));
    Tcl_SetObjResult(interp, tcl_result);
    return TCL_OK;
  }

  // return the MPI node count
  if (!strcmp(argv[1], "nodecount")) {
    Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_size()));
    Tcl_SetObjResult(interp, tcl_result);
    return TCL_OK;
  }

  // execute an MPI barrier
  if(!strupncmp(argv[1], "barrier", CMDLEN) && argc==2) {
    app->par_barrier();
    return TCL_OK;
  }

  // Execute a parallel for loop across all nodes
  //
  //  parallel for <startcount> <endcount> <callback proc> <user data>",
  //
  if(!strupncmp(argv[1], "for", CMDLEN)) {
    int isok = (argc == 6);
    int N = app->par_size();
    int start, end;

    if (Tcl_GetInt(interp, argv[2], &start) != TCL_OK ||
        Tcl_GetInt(interp, argv[3], &end) != TCL_OK) {
      isok = 0;
    }

    //
    // If there's only one node, short-circuit the parallel for
    //
    if (N == 1) {
      if (!isok) {
        Tcl_SetResult(interp, (char *) "invalid parallel for, missing parameter", TCL_STATIC);
        return TCL_ERROR;
      }

      // run for loop on one node...
      int i;
      for (i=start; i<=end; i++) { 
        char istr[128];
        sprintf(istr, "%d", i);
        if (Tcl_VarEval(interp, argv[4], " ", istr, " {",
                        argv[5], "} ", NULL) != TCL_OK) {
          Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC);
        }
      }

      return TCL_OK;
    }

#if defined(VMDMPI)
    int allok = 0;

    // Check all node result codes before we continue with the reduction
    MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);

    // XXX we may want to verify that all nodes are going to call the same
    // reduction proc here before continuing further.

    if (!allok) {
      Tcl_SetResult(interp, (char *) "invalid parallel for, missing parameter on one or more nodes", TCL_STATIC);
      return TCL_ERROR;
    }

    // Run the for loop management code on node zero.
    // Do the work on all the other nodes...
    int i;
    if (app->par_rank() == 0) {
      // use multithreaded code path
      parallel_for_parms parfor;
      memset(&parfor, 0, sizeof(parfor));
      parfor.numnodes = N;
      parfor.loop.start=start;
      parfor.loop.end=end+1;
      wkf_shared_iterator_init(&parfor.iter);
      wkf_shared_iterator_set(&parfor.iter, &parfor.loop);

#if defined(VMDTHREADS)
      // run the MPI scheduler in a new child thread
      wkf_thread_t pft;
      wkf_thread_create(&pft, vmd_mpi_parallel_for_scheduler, &parfor);

      // run the Tcl in the main thread
      wkf_tasktile_t curtile;
      while (wkf_shared_iterator_next_tile(&parfor.iter, 1, &curtile) != WKF_SCHED_DONE) {
        i = curtile.start;
        char istr[128];
        sprintf(istr, "%d", i);
        if (Tcl_VarEval(interp, argv[4], " ", istr, " {",
                        argv[5], "} ", NULL) != TCL_OK) {
          Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC);
        }
      }

      // join up with the MPI scheduler thread
      wkf_thread_join(pft, NULL);
#else
      // if no threads, node zero only runs the scheduler and doesn't do work
      vmd_mpi_parallel_for_scheduler(&parfor);
#endif

      wkf_shared_iterator_destroy(&parfor.iter);
    } else {
      char istr[128];
      int done=0;
      int mynode=app->par_rank();
      while (!done) {
        MPI_Send(&mynode, 1, MPI_INT, 0, VMD_MPI_TAG_FOR_REQUEST, 
                 MPI_COMM_WORLD);

        MPI_Status rcvstat;
        MPI_Recv(&i, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, 
                 MPI_COMM_WORLD, &rcvstat); 
        if (i == -1) {
          done = 1;
        } else {
          sprintf(istr, "%d", i);
          if (Tcl_VarEval(interp, argv[4], " ", istr, " {",
                          argv[5], "} ", NULL) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC);
          }
        }
      }
    }
#endif

    return TCL_OK;
  }

  // Execute an allgather producing a Tcl list of the per-node contributions
  //
  // parallel allgather <object>
  //
  if(!strupncmp(argv[1], "allgather", CMDLEN)) {
    int isok = (argc == 3);

#if defined(VMDMPI)
    int allok = 0;
    int i;

    // Check all node result codes before we continue with the gather
    MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);

    if (!allok) {
      Tcl_SetResult(interp, (char *) "invalid parallel gather, missing parameter on one or more nodes", TCL_STATIC);
      return TCL_ERROR;
    }

    // Collect parameter size data so we can allocate result buffers
    // before executing the gather
    int *szlist = new int[app->par_size()];
    szlist[app->par_rank()] = strlen(argv[2])+1;

#if defined(USE_MPI_IN_PLACE)
    // MPI >= 2.x implementations (e.g. NCSA/Cray Blue Waters)
    MPI_Allgather(MPI_IN_PLACE, 1, MPI_INT,
                  &szlist[0], 1, MPI_INT, MPI_COMM_WORLD);
#else
    // MPI 1.x
    MPI_Allgather(&szlist[app->par_rank()], 1, MPI_INT,
                  &szlist[0], 1, MPI_INT, MPI_COMM_WORLD);
#endif

    int totalsz = 0;
    int *displist = new int[app->par_size()];
    for (i=0; i<app->par_size(); i++) {
      displist[i]=totalsz;
      totalsz+=szlist[i];
    }

    char *recvbuf = new char[totalsz];
    memset(recvbuf, 0, totalsz);

    // Copy this node's data into the correct array position
    strcpy(&recvbuf[displist[app->par_rank()]], argv[2]);

    // Perform the parallel gather 
#if defined(USE_MPI_IN_PLACE)
    // MPI >= 2.x implementations (e.g. NCSA/Cray Blue Waters)
    MPI_Allgatherv(MPI_IN_PLACE, szlist[app->par_rank()], MPI_BYTE,
                   &recvbuf[0], szlist, displist, MPI_BYTE, MPI_COMM_WORLD);
#else
    // MPI 1.x
    MPI_Allgatherv(&recvbuf[displist[app->par_rank()]], szlist[app->par_rank()], MPI_BYTE,
                   &recvbuf[0], szlist, displist, MPI_BYTE, MPI_COMM_WORLD);
#endif

    // Build Tcl result from the array of results
    Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
    for (i=0; i<app->par_size(); i++) {
      Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(&recvbuf[displist[i]], szlist[i]-1));
    }
    Tcl_SetObjResult(interp, tcl_result);

    delete [] recvbuf;
    delete [] displist;
    delete [] szlist;
    return TCL_OK;
#else
    if (!isok) {
      Tcl_SetResult(interp, (char *) "invalid parallel gather, missing parameter on one or more nodes", TCL_STATIC);
      return TCL_ERROR;
    }

    Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(argv[2], strlen(argv[2])));
    Tcl_SetObjResult(interp, tcl_result);
    return TCL_OK;
#endif
  }


  //
  // Execute an All-Reduce across all of the nodes.
  // The user must provide a Tcl proc that performs the appropriate reduction
  // operation for a pair of data items, resulting in a single item.
  // Since the user may pass floating point data or perform reductions 
  // that give very slightly different answers depending on the order of
  // operations, the architecture or the host, or whether reductions on 
  // a given host are occuring on the CPU or on a heterogeneous accelerator 
  // or GPU of some kind, we must ensure that all nodes get a bit-identical
  // result.  When heterogeneous accelerators are involved, we can really 
  // only guarantee this by implementing the All-Reduce with a 
  // Reduce-then-Broadcast approach, where the reduction collapses the
  // result down to node zero, which then does a broadcast to all peers. 
  //
  // parallel allreduce <tcl reduction proc> <object>
  //
  if(!strupncmp(argv[1], "allreduce", CMDLEN)) {
    int isok = (argc == 4);
    int N = app->par_size();

    //
    // If there's only one node, short-circuit the full parallel reduction
    //
    if (N == 1) {
      if (!isok) {
        Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter", TCL_STATIC);
        return TCL_ERROR;
      }

      // return our result, no other reduction is necessary
      Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], strlen(argv[3])));
      return TCL_OK;
    }

#if 1 && defined(VMDMPI)
    //
    // All-Reduce implementation based on a ring reduction followed by a 
    // broadcast from node zero.  This implementation gaurantees strict
    // ordering and will properly handle the case where one or more nodes
    // perform their reduction with slightly differing floating point 
    // rounding than others (e.g. using GPUs, heterogeneous nodes, etc),
    // and it works with any number of nodes.  While NOT latency-optimal,
    // this implementation is close to bandwidth-optimal which is helpful
    // for workstation clusters on non-switched networks or networks with
    // switches that cannot operate in a fully non-blocking manner.
    //
    int allok = 0;

    // Check all node result codes before we continue with the reduction
    MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);

    // XXX we may want to verify that all nodes are going to call the same
    // reduction proc here before continuing further.

    if (!allok) {
      Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter on one or more nodes", TCL_STATIC);
      return TCL_ERROR;
    }

    // copy incoming data into initial "result" object
    Tcl_Obj *resultobj = Tcl_NewStringObj((const char *) argv[3], strlen(argv[3])+1);

    // A ring-based all-reduce implementation which should be 
    // close to bandwidth-optimal, at the cost of additional latency.
    int src=app->par_rank(); // src node is this node
    int Ldest = (N + src + 1) % N; // compute left peer
    int Rdest = (N + src - 1) % N; // compute right peer
    MPI_Status status;

    if (src != 0) {
      int recvsz = 0;

      // Post blocking receive for data size
      MPI_Recv(&recvsz, 1, MPI_INT, Ldest,
               VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &status);

      // Allocate or resize receive buffer 
      char * recvbuf = (char *) malloc(recvsz);

      // Post non-blocking receive for data
      MPI_Recv(recvbuf, recvsz, MPI_BYTE, Ldest,
               VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &status);

      // Perform reduction
      // Perform the reduction operation on our existing and incoming data.
      // We build a Tcl command string with the user-defined proc, this 
      // node's previous resultand, and the incoming data, and evaluate it.
      if (Tcl_VarEval(interp, argv[2], " ", 
                      Tcl_GetString(resultobj), " ", 
                      recvbuf, NULL) != TCL_OK) {
        printf("Error occured during reduction!\n");    
      }

      // Prep for next reduction step.  Set result object to result of
      // the latest communication/reduction phase.
      resultobj = Tcl_GetObjResult(interp);

      // Free the receive buffer
      free(recvbuf);
    } 
  
    //
    // All nodes
    //  
    char *sendbuf = Tcl_GetString(resultobj);
    int sendsz = strlen(sendbuf)+1;

    // Post blocking send for data size
    MPI_Send(&sendsz, 1, MPI_INT, Rdest,
             VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD);

    // Post blocking send for data
    MPI_Send(sendbuf, sendsz, MPI_BYTE, Rdest,
             VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD);

    if (src == 0) {
      int recvsz = 0;

      // Post blocking receive for data size
      MPI_Recv(&recvsz, 1, MPI_INT, Ldest,
               VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &status);

      // Allocate or resize receive buffer 
      char * recvbuf = (char *) malloc(recvsz);

      // Post non-blocking receive for data
      MPI_Recv(recvbuf, recvsz, MPI_BYTE, Ldest,
               VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &status);

      // Perform reduction
      // Perform the reduction operation on our existing and incoming data.
      // We build a Tcl command string with the user-defined proc, this 
      // node's previous result and the incoming data, and evaluate it.
      if (Tcl_VarEval(interp, argv[2], " ", 
                      Tcl_GetString(resultobj), " ", 
                      recvbuf, NULL) != TCL_OK) {
        printf("Error occured during reduction!\n");    
      }

      // Prep for next reduction step.  Set result object to result of
      // the latest communication/reduction phase.
      resultobj = Tcl_GetObjResult(interp);

      // Free the receive buffer
      free(recvbuf);
    } 

    //
    // Broadcast final result from root to peers
    //
    if (src == 0) {
      // update send buffer for root node before broadcast
      sendbuf = Tcl_GetString(resultobj);
      sendsz = strlen(sendbuf)+1;
      MPI_Bcast(&sendsz, 1, MPI_INT, 0, MPI_COMM_WORLD);
      MPI_Bcast(sendbuf, sendsz, MPI_BYTE, 0, MPI_COMM_WORLD);
    } else {
      int recvsz = 0;
      MPI_Bcast(&recvsz, 1, MPI_INT, 0, MPI_COMM_WORLD);

      // Allocate or resize receive buffer 
      char * recvbuf = (char *) malloc(recvsz);

      MPI_Bcast(recvbuf, recvsz, MPI_BYTE, 0, MPI_COMM_WORLD);

      // Set the final Tcl result if necessary
      Tcl_SetObjResult(interp, Tcl_NewStringObj(recvbuf, recvsz-1));

      // Free the receive buffer
      free(recvbuf);
    }

    return TCL_OK;

#elif defined(VMDMPI)

    //
    // Power-of-two-only hypercube/butterfly/recursive doubling 
    // All-Reduce implementation.  This implementation can't be used
    // in the case that we have either a non-power-of-two node count or
    // in the case where we have heterogeneous processing units that may
    // yield different floating point rounding.  For now we leave this
    // implementation in the code for performance comparisons until we work
    // out the changes necessary to make it closer to bandwidth-optimal,
    // heterogeneous-safe, and non-power-of-two capable.
    //
    int allok = 0;
    int i;

    // Check all node result codes before we continue with the reduction
    MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);

    // XXX we may want to verify that all nodes are going to call the same
    // reduction proc here before continuing further.

    if (!allok) {
      Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter on one or more nodes", TCL_STATIC);
      return TCL_ERROR;
    }

    // Calculate number of reduction phases required
    int log2N;
    for (log2N=0; N>1; N>>=1) {
      log2N++;

      // XXX bail out of we don't have a power-of-two node count, 
      //     at least until we implement 3-2 reduction phases
      if ((N & 1) && (N > 1)) {
        Tcl_SetResult(interp, (char *) "parallel allreduce only allowed for even power-of-two node count", TCL_STATIC);
        return TCL_ERROR;
      }
    }
    N = app->par_size();

    // copy incoming data into initial "result" object
    Tcl_Obj *resultobj = Tcl_NewStringObj((const char *) argv[3], strlen(argv[3])+1);

    // An all-reduce tree with hypercube connectivity with 
    // log2(N) communication/reduction phases.  At each phase, we compute
    // the peer/destination node we will communicate with using an XOR of
    // our node ID with the current hypercube dimension.  If we have an
    // incomplete hypercube topology (e.g. non-power-of-two node count), 
    // we have to do special 3-2 communication rounds (not implemented yet).
    // The current implementation requires that all existing nodes 
    // participate, and that they contribute a valid data item.
    // If we wish to support reductions where a node may not contribute,
    // we would need to handle that similarly to a peer node that doesn't 
    // exist, but we would likely determine this during the parameter length
    // exchange step.
    int src=app->par_rank(); // src node is this node
    for (i=0; i<log2N; i++) {
      int mask = 1 << i;     // generate bitmask to use in the XOR
      int dest = src ^ mask; // XOR src node with bitmask to find dest node
      Tcl_Obj *oldresultobj = resultobj; // track old result 

      // Check to make sure dest node exists for non-power-of-two 
      // node counts (an incomplete hypercube).  If not, skip to the next
      // communication/reduction phase.
      if (dest < N) {
        char *sendbuf = Tcl_GetString(oldresultobj);
        int sendsz = strlen(sendbuf)+1;
        int recvsz = 0;
        MPI_Request handle;
        MPI_Status status;

        //
        // Exchange required receive buffer size for data exchange with peer
        //

        // Post non-blocking receive for data size
        MPI_Irecv(&recvsz, 1, MPI_INT, dest,
                  VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &handle);

        // Post blocking send for data size
        MPI_Send(&sendsz, 1, MPI_INT, dest,
                 VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD);

        // Wait for non-blocking receive of data size to complete
        MPI_Wait(&handle, &status); 

// printf("src[%d], dest[%d], value '%s', recvsz: %d\n", src, dest, sendbuf, recvsz);

        // Allocate or resize receive buffer 
        char * recvbuf = (char *) malloc(recvsz);

        //
        // Exchange the data payload
        // 

        // Post non-blocking receive for data
        MPI_Irecv(recvbuf, recvsz, MPI_BYTE, dest,
                  VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &handle);
        
        // Post blocking send for data
        MPI_Send(sendbuf, sendsz, MPI_BYTE, dest,
                 VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD);

        // Wait for receive of data
        MPI_Wait(&handle, &status); 

        // Perform the reduction operation on our existing and incoming data.
        // We build a Tcl command string with the user-defined proc, this 
        // node's previous result and the incoming data, and evaluate it.
        if (Tcl_VarEval(interp, argv[2], " ", 
                        sendbuf, " ", recvbuf, NULL) != TCL_OK) {
          printf("Error occured during reduction!\n");    
        }

        // Free the receive buffer
        free(recvbuf);

        // Prep for next reduction step.  Set result object to result of
        // the latest communication/reduction phase.
        resultobj = Tcl_GetObjResult(interp);
      }
    }

    // Set the final Tcl result if necessary
    Tcl_SetObjResult(interp, resultobj);

    return TCL_OK;
#endif
  }
示例#25
0
int
TclModelBuilder_addZeroLengthContact2D(ClientData clientData, Tcl_Interp *interp,
				       int argc, TCL_Char **argv,
				       Domain *theDomain,
				       TclModelBuilder *theBuilder) {
  
  
  
  // need to write here.
  int ndm = theBuilder->getNDM(); // the spatial dimension of the problem
  
  //
  // first scan the command line to obtain eleID, SlaveNode, MasterNode,
  
  int eleTag, iNode, jNode;
  
  
  //opserr << argc;
  
  // a quick check on number of args
  if (argc < 11) {
    opserr << "ZeroLengthContact2D::WARNING too few arguments " <<
      "want - element ZeroLengthContact2D eleTag? iNode? jNode? Kn? Kt? fs? -normal Nx? Ny?" ;
    return TCL_ERROR;
  }
  
  // get the ele tag
  if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalied eleTag " << argv[2] << "\n";
    return TCL_ERROR;
  }
  
  
  // get the two end nodes
  if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalied iNode " << argv[3] <<  "\n";
    
    return TCL_ERROR;
  }
  
  if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalid jNode " << argv[4] << "\n" ;
    return TCL_ERROR;
  }
  
  double Kn, Kt, fs;
  
  // read the material properties
  if (Tcl_GetDouble(interp, argv[5], &Kn) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalid Kn " << argv[5] << "\n" ;
    return TCL_ERROR;
  }
  
  if (Tcl_GetDouble(interp, argv[6], &Kt) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalid Kt " << argv[6] << "\n" ;
    return TCL_ERROR;
  }
  
  if (Tcl_GetDouble(interp, argv[7], &fs) != TCL_OK) {
    opserr << "ZeroLengthContact2D::WARNING invalid fs " << argv[7] << "\n" ;
    return TCL_ERROR;
  }
  
  ///// changed to specify any contact normal direction
  if (strcmp(argv[8],"-normal") != 0) {
    opserr << "ZeroLengthContact2D:: expecting "<<
      "- element ZeroLengthContact2D eleTag? iNode? jNode? Kn? Kt? fs? -normal Nx? Ny? \n" ;
    return TCL_ERROR;
  }
  
  Vector  NormalDir(2);
  
  int argi=9;
  
  double value;
  // read the NormalDir values
  for (int i=0; i<2; i++)  {
    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
      opserr << "ZeroLengthContact2D:: invalid -normal value for ele " <<
	eleTag <<
	"- element ZeroLengthContact2D eleTag? iNode? jNode? Kn? Kt? fs? -normal Nx? Ny? \n" ;
      
      return TCL_ERROR;
    } else {
      argi++;
      NormalDir(i) = value;
    }
  }
  
  
  //
  // now we create the element and add it to the domain
  //
  
  Element *theEle;
  
  
  theEle = new ZeroLengthContact2D(eleTag, iNode, jNode, Kn, Kt,
				   fs, NormalDir);
  
  if (theEle == 0) {
    return TCL_ERROR;
  }
  
  if (theDomain->addElement(theEle) == false) {
    return TCL_ERROR;
  }
  
  // return the memory we stole and return OK
  return TCL_OK;
}
示例#26
0
int
cross_services(ClientData clientData,
		Tcl_Interp *interp, /* Current interpreter. */
		int argc,           /* Number of arguments. */
		char **argv)        /* Argument strings.    */
{
    Tcl_CmdInfo infoPtr;
    ClientData  wcdata;
    Tcl_CmdProc* wcmd;
    char *wname;
    char *command, *contents;
    int pargc, i, size;
    char *pline, *q;
    int result, ret = TCL_OK;

    wname = argv[1];
    if (wname[0])
    {
	if (!Tcl_GetCommandInfo(interp, wname, &infoPtr))
	{
	    Tcl_AppendResult(interp, "wrong # \"",
		wname, "\" does not exist", (char *) NULL);
	    return TCL_ERROR;
	}
	wcdata = infoPtr.clientData;
	wcmd = (Tcl_CmdProc *)infoPtr.proc;
    }
    Tcl_ResetResult (interp);

    pargc = 2;
    command   = argv[pargc++];
    contents  = argv[pargc++];

    if (argc == 12 && *command == 'f' && strcmp (command, "filter") == 0)
    {
	char *refartStr, *testline, *shown_scopes, *ref_access;
	char    *file = NULL;
	enum RefTypes refart;
	char **tfields, **lfields=NULL, **oldfields=NULL;
	char *tmpline;
	int tmpline_size = 512;
	int uniq, have, accept_static, accept_param, fsize, tsize;
	int AddRefArt=0;
	int length;
	char *line[line_arg_count], AddRefartStr[16] = {0};
	Tcl_DString res, erg;
	
	refartStr = argv[pargc++];
	testline  = argv[pargc++];
	uniq      = atoi (argv[pargc++]);
	have      = atoi (argv[pargc++]);
	accept_param = atoi (argv[pargc++]);
	accept_static= atoi (argv[pargc++]);
	shown_scopes = argv[pargc++];
	ref_access   = argv[pargc++];
	
	if (accept_static)
	{
	    /* Information to the actual scope */
	    if (Tcl_SplitList (interp, testline, &tsize, &tfields) != TCL_OK)
	    {
		return TCL_ERROR;
	    }
	    file = tfields[file1_pos];
	}
	if (strcmp (refartStr, "to") == 0)
	{
	    refart = REF_TO;
	}
	else
	{
	    refart = REF_BY;
	}
	
	/* init some variables */
	for (i=0; i<line_arg_count; i++)
	{
	    line[i] = "";
	}
	Tcl_DStringInit(&res);
	Tcl_DStringInit(&erg);
	tmpline = (char*)ckalloc (tmpline_size); tmpline[0] = 0;
	
	for (length=strlen(contents), q = contents; 1;)
        {
        	char    *prevlist = q;
	    result = TclFindElement(interp, q, length, &pline, &q, &size, NULL);
	    if (result != TCL_OK || size == 0)
	    {
		break;
	    }
	    length -= q - prevlist;
	    if (size > tmpline_size)
	    {
		tmpline_size += size;
		tmpline = ckrealloc (tmpline, tmpline_size);
	    }
	    memcpy (tmpline, pline, size);
	    tmpline[size] = 0;
	    if (Tcl_SplitList (interp, tmpline, &fsize, &lfields) != TCL_OK)
	    {
		continue;
	    }
	    if (fsize != DB_COUNT)
	    {
		ckfree ((char*)lfields);
		continue;
	    }
	
	    if (*shown_scopes && strstr (shown_scopes, lfields[DB_SCP2]) == NULL)
	    {
		continue;
	    }
	
	    if (*ref_access && strstr (ref_access, lfields[DB_REFA]) == NULL)
	    {
		continue;
	    }
	
	    if (uniq && oldfields)
	    {
		if (strcmp (oldfields[DB_CLS2], lfields[DB_CLS2]) == 0 &&
		    strcmp (oldfields[DB_SYM2], lfields[DB_SYM2]) == 0 &&
		    strcmp (oldfields[DB_SCP2], lfields[DB_SCP2]) == 0 &&
		    (! accept_param ||
		    (accept_param && strcmp (oldfields[DB_PRM2], lfields[DB_PRM2]) == 0)))
		{
		    if (!AddRefartStr[0] ||
			(lfields[DB_REFA][0] && strchr (AddRefartStr, lfields[DB_REFA][0]) == NULL))
		    {
			strcat (AddRefartStr, lfields[DB_REFA]);
		    }
		    ckfree ((char *) lfields);
		    continue;
		}
	    }

	    /* Static functions and variables */
	    if (accept_static && refart == REF_TO && lfields[DB_REFA][0] != 0 && ! cross_is_type_with_classes(lfields[DB_SCP2]))
	    {
		int attr;
		if (Tcl_GetInt(interp, lfields[DB_REFA], &attr) == TCL_OK &&
		    (! (attr&PAF_STATIC) || strcmp (lfields[DB_FILE], file) != 0))
		{
		    ckfree ((char*)lfields);
		    continue;
		}
	    }
	
	    if (have)
	    {
		ckfree ((char *) lfields);
		Tcl_DStringAppendElement (&erg, "yes");
		break;
	    }
	
	    if (AddRefArt)
	    {
		Tcl_DStringAppendElement(&res, AddRefartStr);
		Tcl_DStringAppendElement(&erg, Tcl_DStringValue(&res));
	    }
	    else
	    {
		AddRefArt = 1;
	    }
	    strcpy (AddRefartStr, lfields[DB_REFA]);
	
	    line[class1_pos] = lfields[DB_CLS2];
	    line[item1_pos]  = lfields[DB_SYM2];
	    line[what1_pos]  = lfields[DB_SCP2];
	    line[param1_pos] = lfields[DB_PRM2];

	    line[file_pos]   = lfields[DB_FILE];
	    line[file_line_pos] = lfields[DB_LINE];
	
	    Tcl_DStringFree (&res);
	    for (i=0; i<refart_pos; i++)
	    {
		Tcl_DStringAppendElement (&res, line[i]);
	    }

	    /* Store last line */
	    if (oldfields)
	    {
		ckfree ((char*)oldfields);
	    }
	    oldfields = lfields;
	}
	if (AddRefArt)
	{
	    Tcl_DStringAppendElement(&res, AddRefartStr);
	    Tcl_DStringAppendElement(&erg, Tcl_DStringValue(&res));
	    AddRefartStr[0] = 0;
	}
	Tcl_DStringFree (&res);
	
	if (accept_static)
	{
	    ckfree ((char*)tfields);
	}
	if (oldfields)
	{
	    ckfree ((char*)oldfields);
	}
	ckfree (tmpline);
	
	Tcl_DStringResult(interp, &erg);
	Tcl_DStringFree  (&erg);
    }
    else if (argc == 7 && *command == 'i' && strcmp (command, "insert") == 0)
    {
    }
    else
    {
	char tmp[32];
	sprintf (tmp, "%i", argc);
	Tcl_AppendResult(interp, "wrong # args(", tmp, "): should be \"", argv[0],
	     " filter \"\" contents RefArt line unique have accept_param accept_static shown_scopes ref_access |\n"
	     "insert widget contents RefArt id line\n",
	     "\"",
	     (char *) NULL);
	ret = TCL_ERROR;
    }
    return ret;
}
示例#27
0
int
TclModelBuilder_addZeroLengthND(ClientData clientData, Tcl_Interp *interp,
			      int argc, TCL_Char **argv,
			      Domain *theDomain,
			      TclModelBuilder *theBuilder) {

    int ndm = theBuilder->getNDM(); // the spatial dimension of the problem

    //
    // first scan the command line to obtain eleID, iNode, jNode, material ID's
    // and their directions, and the orientation of ele xPrime and yPrime not
    // along the global x and y axis
    //
    
    int eleTag, iNode, jNode;
    
    // a quick check on number of args
    if (argc < 6) {
	opserr << "WARNING too few arguments %s %s %s\n" <<
				"want - element zeroLengthND eleTag? iNode? jNode? " <<
				"NDTag? <1DTag?>" <<
				"<-orient x1? x2? x3? y1? y2? y3?>\n";
	return TCL_ERROR;
    }

    // get the ele tag 
    if (Tcl_GetInt(interp, argv[2], &eleTag) != TCL_OK) {
	opserr << "WARNING invalied eleTag " << 
	  argv[2] << " - element zeroLengthND eleTag? iNode? jNode? NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n";	
	  
	return TCL_ERROR;
    }

    // get the two end nodes
    if (Tcl_GetInt(interp, argv[3], &iNode) != TCL_OK) {
	opserr << "WARNING invalied iNode " << 
	  argv[3] <<
	  "- element zeroLengthND eleTag? iNode? jNode? " <<
	  "NDTag? <1DTag?>" <<
	  "<-orient x1? x2? x3? y1? y2? y3?>\n";	
	return TCL_ERROR;
    }

    if (Tcl_GetInt(interp, argv[4], &jNode) != TCL_OK) {
      opserr << "WARNING invalid jNode " << 
	argv[4] << "- element zeroLengthND eleTag? iNode? jNode? " <<
	"NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n";	
	return TCL_ERROR;
    }

	int NDTag;

    if (Tcl_GetInt(interp, argv[5], &NDTag) != TCL_OK) {
	opserr << "WARNING invalid NDTag %s %s %s %s\n" << 
	  argv[5] << "- element zeroLengthND eleTag? iNode? jNode? " <<
	  "NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n"; 
	
	return TCL_ERROR;
    }

	UniaxialMaterial *the1DMat = 0;

	int argi = 6;

	if (argc > 6 && strcmp(argv[6],"-orient") != 0) {

		int uniTag;

		if (Tcl_GetInt(interp, argv[6], &uniTag) != TCL_OK) {
			opserr << "WARNING invalid NDTag " << 
			  argv[5] << "- element zeroLengthND eleTag? iNode? jNode? " <<
			  "NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n"; 
			return TCL_ERROR;
		}

		the1DMat = OPS_getUniaxialMaterial(uniTag);

		if (the1DMat == 0)
		  opserr << "WARNING UniaxialMaterial " << uniTag << " not found in model, proceeding without\n";

		argi = 7;
	}

    // create the vectors for the element orientation
    Vector x(3); x(0) = 1.0; x(1) = 0.0; x(2) = 0.0;
    Vector y(3); y(0) = 0.0; y(1) = 1.0; y(2) = 0.0;

    // finally check the command line to see if user specified orientation
    if (argi < argc) {
	if (strcmp(argv[argi],"-orient") == 0) {
	    if (argc < (argi+7)) {
		opserr << "WARNING not enough parameters after -orient flag for ele "  << 
		  eleTag << "- element zeroLengthND eleTag? iNode? jNode? " <<
		  "NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n";	
		return TCL_ERROR;		
	    } else {
		argi++;
		double value;
		// read the x values
		for (int i=0; i<3; i++)  {
		    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
			opserr << "WARNING invalid -orient value for ele  " <<
			  eleTag << argv[argi] << "- element zeroLengthND eleTag? iNode? jNode? " <<
			  "NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n";	
						
			return TCL_ERROR;
		    } else {
			argi++;
			x(i) = value;
		    }
		}
		// read the y values
		for (int j=0; j<3; j++)  {
		    if (Tcl_GetDouble(interp, argv[argi], &value) != TCL_OK) {
			opserr << "WARNING invalid -orient value for ele  " <<
			  eleTag << " " << argv[argi] << 
			  "- element zeroLengthND eleTag? iNode? jNode? " <<
			  "NDTag? <1DTag?> <-orient x1? x2? x3? y1? y2? y3?>\n";	
			return TCL_ERROR;
		    } else {
			argi++;
			y(j) = value;		
		    }
		}
	    }
	}
    }
    
    //
    // now we create the element and add it to the domain
    //

	NDMaterial *theNDMat = OPS_getNDMaterial(NDTag);

	if (theNDMat == 0) {
	  opserr << "zeroLengthND -- no NDMaterial with tag " << NDTag << " exists in Domain\n";
	  return TCL_ERROR;		
	}

	Element *theEle = 0;

	if (the1DMat == 0)
	  theEle = new ZeroLengthND(eleTag, ndm, iNode, jNode, x, y, *theNDMat);
	else
	  theEle = new ZeroLengthND(eleTag, ndm, iNode, jNode, x, y, *theNDMat, *the1DMat);
    
	if (theEle == 0)
	  return TCL_ERROR;
	
	if (theDomain->addElement(theEle) == false)
	  return TCL_ERROR;
	
	return TCL_OK;
}
示例#28
0
int
class_browser_insert(ClientData clientData,
    Tcl_Interp *interp,             /* Current interpreter. */
    int argc,                       /* Number of arguments. */
    Tcl_Obj *objv[])            /* Argument strings. */
{
    Tcl_CmdInfo     infoPtr;
    char    *textwid;
    register void*textPtr = NULL;
    char image [64];
    char *protected_font, *public_font, *private_font, font[512];
    int del;
    Tcl_CmdProc *text_wdgcmd;

    char    *linebuf;
    int linebuf_pos, linebuf_size = 1024;

    char    *data;
    int data_pos, data_size = 1024;
    int len;
    char    *tag_name;
    char    *imageptr;
    unsigned int attr;
    
    Tcl_Obj *objlist, *next;
    int objlistc, oi;
    
    int wargc;
    char *wargv[12];
    int fld_cou;
    int j, fnd1, fnd2;
    char **flds;
    char *p, * base_classes_of, * sub_classes_of, * viewed_classes;
    char *browsed_class;
    int overridden;
    unsigned int filter, filter1;
    int flags_and;

    char **prev_flds=NULL, **actu_flds=NULL, **next_flds=NULL;

    if (argc < 13 || argc > 14)
    {
	Tcl_AppendResult(interp, "wrong # args:  should be ",
	    Tcl_GetString(objv[0]),
	    " ?-delete? textwidget list base_class_tree"
	    " sub_class_tree viewed_classes"
	    " overridden filter "
	    " protected_font private_font, public_font"
	    " browsed_class, and/or"
	    ,
	    NULL);

	return TCL_ERROR;
    }

    if (Tcl_GetString(objv[1])[0] == '-')
    {
	del = TRUE;
	argc--;
	objv++;
    }
    else
	del = FALSE;
	
    textwid         = Tcl_GetString(objv[1]);        /* tree pathname */
    objlist         = objv[2];        /* list of entries */

    base_classes_of = Tcl_GetString(objv[3]);        /* base classes filter */
    sub_classes_of  = Tcl_GetString(objv[4]);        /* sub classes filter */
    viewed_classes  = Tcl_GetString(objv[5]);        /* list of viewed classes */
    overridden      = atoi (Tcl_GetString(objv[6])); /* overridden flag */
    filter          = atoi (Tcl_GetString(objv[7])); /* member filter */
    filter1         = filter&(~(PAF_OVERRIDE|PAF_OVERLOADED)); /* flags without group flags */

    public_font     = Tcl_GetString(objv[8]);        /* font for public members */
    protected_font  = Tcl_GetString(objv[9]);        /* font for protected members */
    private_font    = Tcl_GetString(objv[10]);       /* font for private members */
    browsed_class   = Tcl_GetString(objv[11]);       /* browsed class in the browser */
    flags_and       = atoi(Tcl_GetString(objv[12])); /* Flag if all flags must be seted */

    if (!Tcl_GetCommandInfo(interp, textwid, &infoPtr))
    {
	Tcl_AppendResult(interp, "unknown widget \"",
	    textwid,"\"",NULL);
	return TCL_ERROR;
    }

    textPtr = (void*)infoPtr.clientData;
    text_wdgcmd = (Tcl_CmdProc *)infoPtr.proc;

    /* set widget state as normal */
    wargc = 0;
    wargv[wargc++] = textwid;
    wargv[wargc++] = "configure";
    wargv[wargc++] = "-state";
    wargv[wargc++] = "normal";
    (*text_wdgcmd)((ClientData)textPtr,interp,wargc,wargv);

    /* delete old items */
    if (del)
    {
	wargc = 0;
	wargv[wargc++] = textwid;
	wargv[wargc++] = "delete";
	wargv[wargc++] = "0";
	wargv[wargc++] = "end";

	(*text_wdgcmd)((ClientData)textPtr,interp,wargc,wargv);
    }

    if (Tcl_ListObjLength(interp, objlist, &objlistc) != TCL_OK)
    {
        return TCL_ERROR;
    }
    if (objlistc == 0)
    {
	return TCL_OK;
    }

    /* using of dynamic buffers */
    linebuf = ckalloc (linebuf_size);
    data    = ckalloc (data_size);

    /* options for inserting items */
    wargc = 0;
    wargv[wargc++] = textwid;
    wargv[wargc++] = "insert";
    wargv[wargc++] = "end";
    wargv[wargc++] = "-image";
    wargv[wargc++] = image;
    wargv[wargc++] = "-font";
    wargv[wargc++] = font;
    wargv[wargc++] = "-data";
    wargv[wargc  ] = data; data_pos = wargc++;
    wargv[wargc++] = "-text";
    wargv[wargc  ] = linebuf; linebuf_pos = wargc++;


    for (j=0, oi=0; oi<=objlistc; j++, oi++)
    {
	/* line scanning is complicated, because at least two lines are
	 * to be stored to compare for overloaded and overridden flags
	 */
	if (oi == objlistc)
	{
	    if (j > 1)
	    {
		if (prev_flds)
		{
		    ckfree ((char *) prev_flds);
		}
		prev_flds = actu_flds;
		actu_flds = next_flds;
		next_flds = NULL;
	    }
	    if (actu_flds == NULL)
	    {
		break;
	    }
	}
	else
	{
	    if (Tcl_ListObjIndex (interp, objlist, oi, &next) != TCL_OK)
	    {
		continue;
	    }
	    if (Tcl_SplitList(interp, Tcl_GetString(next), &fld_cou, &flds) != TCL_OK)
	    {
		continue;
	    }
	
	    if (fld_cou < LIST_CNT)
	    {
		ckfree((char *)flds);
		continue;
	    }
	    if (actu_flds == NULL)
	    {
		actu_flds = flds;
		continue;
	    }
	    if (next_flds == NULL)
	    {
		next_flds = flds;
	    }
	    else
	    {
		if (prev_flds)
		{
		    ckfree ((char *) prev_flds);
		}
		prev_flds = actu_flds;
		actu_flds = next_flds;
		next_flds = flds;
	    }
	}
	if (Tcl_GetInt(interp, actu_flds[ATTR_POS],(int *)&attr) != TCL_OK)
	{
	    continue;
	}

 	/* verify if the class is selected */
	p = Tcl_GetVar2 (interp, viewed_classes, CLASS(actu_flds[CLASS_POS]), TCL_LIST_ELEMENT);
	if (p != NULL && atoi (p) == 0)    /* class not selected */
	{
	    continue;
	}
	
	/* if filter enabled, view only selected member types */
	if (filter1)
	{
	    if (flags_and)
	    {
		if ((filter1&attr)!=filter1)
		{
		    continue;
		}
	    }
	    else
	    {
		int cnt = 0;
		if ((filter1&PAF_STATIC    )!=0 && (attr&PAF_STATIC    )!=0) cnt++;
		if ((filter1&PAF_STRUCT_DEF)!=0 && (attr&PAF_STRUCT_DEF)!=0) cnt++;
		if ((filter1&PAF_INLINE    )!=0 && (attr&PAF_INLINE    )!=0) cnt++;
		if ((filter1&PAF_VIRTUAL   )!=0 && (attr&PAF_VIRTUAL   )!=0) cnt++;
		if ((filter1&PAF_PUREVIRTUAL)==PAF_PUREVIRTUAL && (attr&PAF_PUREVIRTUAL)==PAF_PUREVIRTUAL) cnt ++;
		if (cnt == 0)
		{
		    continue;
		}
	    }
	}

	/* verif if overloaded flag is enabled */
	if (filter & PAF_OVERLOADED)
	{
	    if ((prev_flds && strcmp (actu_flds[MEMBER_POS], prev_flds[MEMBER_POS]) == 0) ||
	        (next_flds && strcmp (actu_flds[MEMBER_POS], next_flds[MEMBER_POS]) == 0))
	    {
	    }
	    else
	    {
		continue;
	    }
	}
	
	/* we need this to build correct image name */
	strcpy (image, "cls_br_");
     	imageptr = image+7;
	if (attr & PAF_PROTECTED)
	{
	   *imageptr++ = 'p';
	}
	if (attr & PAF_STATIC)
	{
	    *imageptr++ = 's';
	}
	if (attr & PAF_VIRTUAL)
	{
	    *imageptr++ = 'v';
	}
	
       /* verify if the member overides a member on the base method
         * or is being overridden by a sub class
         */
         fnd1 = fnd2 = 0;
	/* override flag */
	if (next_flds &&
	    strcmp (next_flds[MEMBER_POS], actu_flds[MEMBER_POS]) == 0 &&
	    strcmp (CLASS(next_flds[CLASS_POS]), CLASS(actu_flds[CLASS_POS])) != 0 && /* different classes */
	    strcmp (next_flds[PARAM_POS ], actu_flds[PARAM_POS ]) == 0)
	{
	    *imageptr++ = OVERRIDE;
	    fnd1 = 0;
	}
	
	/* overridden flag */
	if (prev_flds &&
	    strcmp (prev_flds[MEMBER_POS], actu_flds[MEMBER_POS]) == 0 &&
	    strcmp (CLASS(prev_flds[CLASS_POS]), CLASS(actu_flds[CLASS_POS])) != 0 && /* different classes */
	    strcmp (prev_flds[PARAM_POS ], actu_flds[PARAM_POS ]) == 0)
	{
	    *imageptr++ = OVERRIDDEN;
	    fnd2 = 1;
	}
	
	/* if we don't view the overridden members
	 * or when we view only override/overridden members
	 */
	if ((fnd2 && overridden == 0) ||
	     ((filter & PAF_OVERRIDE) && fnd1 == 0 && fnd2 == 0))
	{
	    continue;
	}

        /* A private member uses a special empty image */
        if (attr & PAF_PRIVATE) {
            char * pstr = "private";
            strcpy (imageptr, pstr);
            imageptr += strlen(pstr);
        }

	/* finish image name */
	strcpy (imageptr, "_image");

	/* make text */
	tag_name= strchr(actu_flds[MEMBER_POS],'(');
	/* function */
	if (tag_name && (strncmp(tag_name + 1,"md",2) == 0 ||
	    strncmp(tag_name + 1,"fr",2) == 0))
	{
	    if (tag_name[1] == 'f')      /* Friend use the private tag. */
	    {
		attr &= ~(PAF_PUBLIC|PAF_PROTECTED); 
	    }
	
	    /* using dynamic buffers */
	    len = strlen (actu_flds[MEMBER_POS]) +
		    strlen (actu_flds[CLASS_POS]) +
		    strlen (actu_flds[TYPE_POS]) +
		    strlen (actu_flds[PARAM_POS]) + 6;
	    if (len > linebuf_size)
	    {
		linebuf_size += len;
		linebuf = ckrealloc (linebuf, linebuf_size);
		wargv[linebuf_pos] = linebuf;
	    }
	    sprintf(linebuf,"%s\t%s\t%s\t(%s)",
		    actu_flds[MEMBER_POS],
		    actu_flds[CLASS_POS],
		    actu_flds[TYPE_POS],
		    actu_flds[PARAM_POS]);
	}
	/* variable */
	else
	{
	    /* using dynamic buffers */
	    len = strlen (actu_flds[MEMBER_POS]) +
		    strlen (actu_flds[CLASS_POS]) +
		    strlen (actu_flds[TYPE_POS]) + 3;
	    if (len > linebuf_size)
	    {
		linebuf_size += len;
		linebuf = ckrealloc (linebuf, linebuf_size);
		wargv[linebuf_pos] = linebuf;
	    }
	    sprintf(linebuf,"%s\t%s\t%s",
		    actu_flds[MEMBER_POS],
		    actu_flds[CLASS_POS],
		    actu_flds[TYPE_POS]);
	}
	
	/* using dynamic buffers */
	len = strlen (actu_flds[FILENAME_POS]) + strlen (actu_flds[FILEPOS_POS]) + 2;
	if (len > data_size)
	{
	    data_size += len;
	    data = ckrealloc (data, data_size);
	    wargv[data_pos] = data;
	}
	/* Add file name and position in the data section */
	sprintf (data, "%s\t%s", actu_flds[FILENAME_POS], actu_flds[FILEPOS_POS]);
	
	if (attr & PAF_PUBLIC)
	    strcpy (font, public_font);
	else if (attr & PAF_PROTECTED)
	    strcpy (font, protected_font);
	else if (attr & PAF_PRIVATE)
	    strcpy (font, private_font);
	
	/*
	 * Add line to browser list
	 */
	(*text_wdgcmd)((ClientData)textPtr,interp,wargc,wargv);	/* Insert ! */
    }

    /* free dynamic buffers */
    ckfree ((void*)linebuf);
    ckfree ((void*)data);

    if (prev_flds) ckfree ((void*)prev_flds);
    if (actu_flds) ckfree ((void*)actu_flds);
    if (next_flds) ckfree ((void*)next_flds);

    return TCL_OK;
}	
示例#29
0
int tclcommand_setmd(ClientData data, Tcl_Interp *interp,
	  int argc, char **argv)
{
  union {
    int    intbuf[MAX_DIMENSION];
    double doublebuf[MAX_DIMENSION];
  } databuf;
  char buffer[TCL_DOUBLE_SPACE + 5];
  int i, j;
  int all = (argc == 1), writing = (argc >= 3);

  /* loop over all global variables. Has two purposes:
     either we write al variables or search for the one
     to write */
  for (i = 0; fields[i].data != NULL; i++) {
    if (all || !strncmp(argv[1], fields[i].name, strlen(argv[1]))) {
      if (!all) {
	if ((int)strlen(argv[1]) < fields[i].min_length) {
	  Tcl_AppendResult(interp, "Argument \"",argv[1],"\" not long ", (char *) NULL);
	  Tcl_AppendResult(interp, "enough to identify a setmd variable!", (char *) NULL);
	  return (TCL_ERROR);
	}
	if (writing) {
	  /* set */
	  /* parse in data */
	  if (argc != 2 + fields[i].dimension) {
	    sprintf(buffer, "%d", fields[i].dimension);	  
	    Tcl_AppendResult(interp, "\"", argv[1],
			     "\" has dimension ",
			     buffer, (char *) NULL);
	    sprintf(buffer, " not %d", argc - 2);	  
	    Tcl_AppendResult(interp, buffer, (char *) NULL);
	    return (TCL_ERROR);
	  }

	  /* get new value */
	  for (j = 0; j < fields[i].dimension; j++) {
	    switch (fields[i].type) {
	    case TYPE_INT:
	      if (Tcl_GetInt(interp, argv[2 + j], databuf.intbuf + j) == TCL_ERROR)
		return (TCL_ERROR);
	      break;
	    case TYPE_BOOL: {
	      int dta;
	      if (Tcl_GetInt(interp, argv[2 + j], &dta))
		return (TCL_ERROR);
	      if (dta) {
		databuf.intbuf[0] |= (1L << j);
	      } else {
		databuf.intbuf[0] &= ~(1L << j);
	      }
	      break;
	    }
	    case TYPE_DOUBLE:
	      if (Tcl_GetDouble(interp, argv[2 + j], databuf.doublebuf + j))
		return (TCL_ERROR);
	      break;
	    default: ;
	    }
	  }

	  if (find_callback(i)(interp, databuf.intbuf) != TCL_OK)
	    return gather_runtime_errors(interp, TCL_ERROR);
	  /* fall through to write out the set value immediately again */
	}
      }

      /* get */
      if (all) {
	if (i != 0)
	  Tcl_AppendResult(interp, " ", (char *)NULL);
	Tcl_AppendResult(interp, "{", fields[i].name, " ", (char *)NULL);
      }
      for (j = 0; j < fields[i].dimension; j++) {
	switch (fields[i].type) {
	case TYPE_INT:
	  sprintf(buffer, "%d", ((int *)fields[i].data)[j]);
	  break;
	case TYPE_BOOL: {
	  if ((*(int *)fields[i].data) & (1L << j))
	    strcpy(buffer, "1");
	  else
	    strcpy(buffer, "0");
	  break;
	}
	case TYPE_DOUBLE:
	  Tcl_PrintDouble(interp, ((double *)fields[i].data)[j], buffer);
	  break;
	default: ;
	}
	Tcl_AppendResult(interp, buffer, (char *) NULL);
	if (j < fields[i].dimension - 1)
	  Tcl_AppendResult(interp, " ", (char *) NULL);
      }
      
      if (all)
	Tcl_AppendResult(interp, "}", (char *)NULL);
      /* wrote out one value, so skip rest */
      if (!all) {
	if (writing)
	  return gather_runtime_errors(interp, TCL_OK);
	else
	  return (TCL_OK);
      }
    }
  }
  if (all)
    return TCL_OK;

  Tcl_AppendResult(interp, "unknown md variable \"",
		   argv[1], "\"", (char *) NULL);
  return (TCL_ERROR);
}
示例#30
0
int TclModelBuilder_addGenericClient(ClientData clientData, Tcl_Interp *interp,  int argc, 
    TCL_Char **argv, Domain*theTclDomain,
    TclModelBuilder *theTclBuilder, int eleArgStart)
{
    // ensure the destructor has not been called
    if (theTclBuilder == 0)  {
        opserr << "WARNING builder has been destroyed - genericClient\n";
        return TCL_ERROR;
    }
    
    // check the number of arguments is correct
    if ((argc-eleArgStart) < 8)  {
        opserr << "WARNING insufficient arguments\n";
        printCommand(argc, argv);
        opserr << "Want: element genericClient eleTag -node Ndi Ndj ... -dof dofNdi -dof dofNdj ... -server ipPort <ipAddr> <-ssl> <-udp> <-dataSize size> <-noRayleigh>\n";
        return TCL_ERROR;
    }
    
    Element *theElement = 0;
    int ndm = theTclBuilder->getNDM();
    
    // get the id and end nodes
    int tag, node, dof, ipPort, argi, i, j;
    int numNodes = 0, numDOFj = 0, numDOF = 0;
    char *ipAddr = 0;
    int ssl = 0, udp = 0;
    int dataSize = 256;
    int doRayleigh = 1;
    
    if (Tcl_GetInt(interp, argv[1+eleArgStart], &tag) != TCL_OK)  {
        opserr << "WARNING invalid genericClient eleTag\n";
        return TCL_ERROR;
    }
    // read the number of nodes
    if (strcmp(argv[2+eleArgStart], "-node") != 0)  {
        opserr << "WARNING expecting -node flag\n";
        opserr << "genericClient element: " << tag << endln;
        return TCL_ERROR;
    }
    argi = 3+eleArgStart;
    i = argi;
    while (strcmp(argv[i], "-dof") != 0  && i < argc)  {
        numNodes++;
        i++;
    }
    if (numNodes == 0)  {
        opserr << "WARNING no nodes specified\n";
        opserr << "genericClient element: " << tag << endln;
        return TCL_ERROR;
    }
    // create the ID arrays to hold the nodes and dofs
    ID nodes(numNodes);
    ID *dofs = new ID [numNodes];
    if (dofs == 0)  {
        opserr << "WARNING out of memory\n";
        opserr << "genericClient element: " << tag << endln;
        return TCL_ERROR;
    }
    // fill in the nodes ID
    for (i=0; i<numNodes; i++)  {
        if (Tcl_GetInt(interp, argv[argi], &node) != TCL_OK)  {
            opserr << "WARNING invalid node\n";
            opserr << "genericClient element: " << tag << endln;
            return TCL_ERROR;
        }
        nodes(i) = node;
        argi++; 
    }
    for (j=0; j<numNodes; j++)  {
        // read the number of dofs per node j
        numDOFj = 0;
        if (strcmp(argv[argi], "-dof") != 0)  {
            opserr << "WARNING expect -dof\n";
            opserr << "genericClient element: " << tag << endln;
            return TCL_ERROR;
        }
        argi++;
        i = argi;
        while (strcmp(argv[i], "-dof") != 0 &&
            strcmp(argv[i], "-server") != 0 &&
            strcmp(argv[i], "-doRayleigh") != 0 &&
            strcmp(argv[i], "-noRayleigh") != 0 &&
            i < argc)  {
                numDOFj++;
                numDOF++;
                i++;
        }
        // fill in the dofs ID array
        ID dofsj(numDOFj);
        for (i=0; i<numDOFj; i++)  {
            if (Tcl_GetInt(interp, argv[argi], &dof) != TCL_OK)  {
                opserr << "WARNING invalid dof\n";
                opserr << "genericClient element: " << tag << endln;
                return TCL_ERROR;
            }
            dofsj(i) = dof-1;
            argi++;
        }
        dofs[j] = dofsj;
    }
    if (strcmp(argv[argi], "-server") == 0)  {
        argi++;
        if (Tcl_GetInt(interp, argv[argi], &ipPort) != TCL_OK)  {
            opserr << "WARNING invalid ipPort\n";
            opserr << "genericClient element: " << tag << endln;
            return TCL_ERROR;
        }
        argi++;
        if (argi < argc &&
            strcmp(argv[argi], "-doRayleigh") != 0 &&
            strcmp(argv[argi], "-noRayleigh") != 0 &&
            strcmp(argv[argi], "-dataSize") != 0 &&
            strcmp(argv[argi], "-ssl") != 0 &&
            strcmp(argv[argi], "-udp") != 0)  {
                ipAddr = new char [strlen(argv[argi])+1];
                strcpy(ipAddr,argv[argi]);
                argi++;
        }
        else  {
            ipAddr = new char [9+1];
            strcpy(ipAddr,"127.0.0.1");
        }
        for (i = argi; i < argc; i++)  {
            if (strcmp(argv[i], "-ssl") == 0)  {
                ssl = 1; udp = 0;
            }
            else if (strcmp(argv[i], "-udp") == 0)  {
                udp = 1; ssl = 0;
            }
            else if (strcmp(argv[i], "-dataSize") == 0)  {
                if (Tcl_GetInt(interp, argv[i+1], &dataSize) != TCL_OK)  {
                    opserr << "WARNING invalid dataSize\n";
                    opserr << "genericClient element: " << tag << endln;
                    return TCL_ERROR;
                }
            }
        }
    }
    else  {
        opserr << "WARNING expecting -server string but got ";
        opserr << argv[argi] << endln;
        opserr << "genericClient element: " << tag << endln;
        return TCL_ERROR;
    }
    for (i = argi; i < argc; i++)  {
        if (strcmp(argv[i], "-doRayleigh") == 0)  {
            doRayleigh = 1;
        } else if (strcmp(argv[i], "-noRayleigh") == 0)  {
            doRayleigh = 0;
        }
    }
    
    // now create the GenericClient
    theElement = new GenericClient(tag, nodes, dofs, ipPort, ipAddr,
        ssl, udp, dataSize, doRayleigh);
    
    // cleanup dynamic memory
    if (dofs != 0)
        delete [] dofs;
    
    if (theElement == 0)  {
        opserr << "WARNING ran out of memory creating element\n";
        opserr << "genericClient element: " << tag << endln;
        return TCL_ERROR;
    }
    
    // then add the GenericClient to the domain
    if (theTclDomain->addElement(theElement) == false)  {
        opserr << "WARNING could not add element to the domain\n";
        opserr << "genericClient element: " << tag << endln;
        delete theElement;
        return TCL_ERROR;
    }
    
    // if get here we have sucessfully created the genericClient and added it to the domain
    return TCL_OK;
}