static void GetTNworker(int nArgs, int cycs) { IOStream *file; long i, n= 0; long *ncycs= 0; double *times= 0; Array *array; HistoryInfo *history; Dimension *dims; if (nArgs!=1) YError("get_times/get_ncycs takes exactly one argument"); file= yarg_file(0); history= file->history; if (history) { n= history->nRecords; if (cycs) ncycs= history->ncyc; else times= history->time; } if (n<=0 || (cycs? (!ncycs) : (!times))) { PushDataBlock(RefNC(&nilDB)); return; } dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(n, 1L, (Dimension *)0); array= PushDataBlock(NewArray(cycs? &longStruct : &doubleStruct, tmpDims)); if (cycs) for (i=0 ; i<n ; i++) array->value.l[i]= ncycs[i]; else for (i=0 ; i<n ; i++) array->value.d[i]= times[i]; }
void Y_get_primitives(int nArgs) { IOStream *file; Dimension *dims; Array *array; long *p; FPLayout *fpl; int i, j; if (nArgs!=1) YError("get_primitives requires exactly one argument"); file = yarg_file(0); dims = tmpDims; tmpDims = 0; FreeDimension(dims); tmpDims = NewDimension(32L, 1L, (Dimension *)0); array = PushDataBlock(NewArray(&longStruct, tmpDims)); p = array->value.l; for (i=j=0 ; i<6 ; i++) { p[j++] = file->structList[i]->size; p[j++] = file->structList[i]->alignment; p[j++] = file->structList[i]->order; } p[1] = file->structAlign; for (i=4 ; i<6 ; i++) { fpl = file->structList[i]->fpLayout; p[j++] = fpl->sgnAddr; p[j++] = fpl->expAddr; p[j++] = fpl->expSize; p[j++] = fpl->manAddr; p[j++] = fpl->manSize; p[j++] = fpl->manNorm; p[j++] = fpl->expBias; } }
void Y_get_vars(int nArgs) { IOStream *file, *child; Array *array; char **pNames= 0, **cNames= 0; long i, nParent, nChild; Dimension *dims; if (nArgs!=1) YError("get_vars takes exactly one argument"); file= yarg_file(0); child= file->history? file->history->child : 0; /* create result array */ dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(2L, 1L, (Dimension *)0); array= PushDataBlock(NewArray(&pointerStruct, tmpDims)); nParent= file->dataTable.nItems; nChild= child? child->dataTable.nItems : 0; if (nParent) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nParent, 1L, (Dimension *)0); array->value.p[0]= pNames= NewArray(&stringStruct, tmpDims)->value.q; } if (nChild) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nChild, 1L, (Dimension *)0); array->value.p[1]= cNames= NewArray(&stringStruct, tmpDims)->value.q; } /* and fill it */ for (i=0 ; i<nParent ; i++) pNames[i]= p_strcpy(file->dataTable.names[i]); for (i=0 ; i<nChild ; i++) cNames[i]= p_strcpy(child->dataTable.names[i]); }
void Y_set_tolerances(int nArgs) { double *tols, t1, t2, t3; Dimension *dims; Array *array; if (nArgs!=1) YError("set_tolerances takes exactly one argument"); tols= YGet_D(sp, 1, &dims); if (tols && (!dims || dims->number!=3 || dims->next)) YError("argument to set_tolerances must be nil or array(double,3)"); /* get current tolerances */ if (polishRoot) { t1= polishTol1; t2= polishTol2; } else { t1= t2= -1.0; } t3= findRayTol; if (tols) { /* set tolerances to new values */ if (tols[0]>=0.0) { if (tols[0]>0.0) polishTol1= tols[0]; else polishTol1= 1.0e-3; /* default value as set in track.c */ if (tols[1]>0.0) polishTol2= tols[1]; else polishTol2= 1.0e-6; /* default value as set in track.c */ polishRoot= 1; } else { polishRoot= 0; } if (tols[2]>0.0) findRayTol= tols[2]; else findRayTol= 0.0; /* default value as set in track.c */ } dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(3L, 1L, (Dimension *)0); array= (Array *)PushDataBlock(NewArray(&doubleStruct, tmpDims)); tols= array->value.d; tols[0]= t1; tols[1]= t2; tols[2]= t3; }
void Y_indgen(int nArgs) { long number, origin, stride, i; Array *array; Dimension *tmp; Operand op; if (nArgs != 1) YError("indgen takes exactly one argument"); sp->ops->FormOperand(sp, &op); if (op.ops==&rangeOps) { Range *range= op.value; if (range->rf || range->nilFlags) YError("range function and/or nil range component in indgen"); origin= range->min; stride= range->inc; if (stride>0) number= (range->max-origin)/stride; else number= (origin-range->max)/(-stride); number++; /* number of footprints, not number of strides */ } else if (op.ops->promoteID<=T_LONG && !op.type.dims) { op.ops->ToLong(&op); number= *(long *)op.value; origin= 1L; stride= 1; } else { YError("indgen argument must be range or scalar integer"); return; } if (number>0) { tmp= tmpDims; tmpDims= 0; FreeDimension(tmp); tmpDims= NewDimension(number, 1L, (Dimension *)0); array= PushDataBlock(NewArray(&longStruct, tmpDims)); for (i=0 ; i<number ; i++) { array->value.l[i]= origin; origin+= stride; } } else { /* indgen(0) returns default origin */ PushLongValue(1L); } }
void Y_ml4read(int nArgs) { char *filename=""; char *varname=""; int leave_open = 0; if (nArgs==2) { filename=YGetString(sp-nArgs+1); varname=YGetString(sp-nArgs+2); leave_open = 0; } else if (nArgs==3) { filename=YGetString(sp-nArgs+1); varname=YGetString(sp-nArgs+2); leave_open=YGetInteger(sp-nArgs+3); } unsigned long bytes_read; int type,namelen; unsigned long nElements,nBytesToRead; int mrows,mcols,imagf; FILE *fs; int fileptr; int endian = 'L'; int size=0,i; fs = openmat(filename); if (fs == NULL) YError(p_strncat("Can't open file ",filename,0)); if (!matfind(fs,varname,50000)) YError(p_strncat("No Such variable ",varname,0)); fileptr = ftell(fs); if (DEBUG) printf("@ position %d\n",fileptr); bytes_read = fread(&type,sizeof(int),1,fs); if (bytes_read==0) { matclose(filename); YError("Premature end of file");; // end of file } fread(&mrows,sizeof(int),1,fs); fread(&mcols,sizeof(int),1,fs); fread(&imagf,sizeof(int),1,fs); fread(&namelen,sizeof(int),1,fs); if (namelen & 0xffff0000) { if (DEBUG) printf("Big endian file\n"); endian = 'B'; SWAP_INT(type); SWAP_INT(mrows); SWAP_INT(mcols); SWAP_INT(imagf); SWAP_INT(namelen); } type = type%1000; if (DEBUG) printf("rows,cols,namelen= %d %d %d\n",mrows,mcols,namelen); if (namelen>255) { fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable matclose(filename); YError("Variable name too long!"); } fread(tempvarname,(unsigned int)namelen,1,fs); // if ((*varname!='*') && strcmp(varname,tempvarname)) { // error if not same varname if (!matchvarname(tempvarname,varname)) { // error if not same varname fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable matclose(filename); YError(p_strncat("Can't find variable",varname,0)); } nElements = (unsigned)mrows*(unsigned)mcols; Dimension *tmp=tmpDims; tmpDims=0; FreeDimension(tmp); if (mrows<=1) { tmpDims= NewDimension(mcols, 1L, (Dimension *)0); } else if (mcols<=1) { tmpDims= NewDimension(mrows, 1L, (Dimension *)0); } else { tmpDims= NewDimension(mrows, 1L, (Dimension *)0); tmpDims= NewDimension(mcols, 1L, tmpDims); } if (type==0) { // 8-byte doubles size = 8; Array *a= PushDataBlock(NewArray(&doubleStruct, tmpDims)); double *data = a->value.d; bytes_read = fread((void *)data,size,nElements,fs); if (endian=='B') { for (i=0;i<nElements;i++) SWAP_DOUBLE(data[i]); } } else if (type==10) { // 4-byte reals size = 4; Array *a= PushDataBlock(NewArray(&floatStruct, tmpDims)); float *data = a->value.f; bytes_read = fread((void *)data,size,nElements,fs); if (endian=='B') { for (i=0;i<nElements;i++) SWAP_FLOAT(data[i]); } } else if ((type==120) || (type==20)) { // 4-byte int size = 4; Array *a= PushDataBlock(NewArray(&intStruct, tmpDims)); int *data = a->value.l; bytes_read = fread((void *)data,size,nElements,fs); if (endian=='B') { for (i=0;i<nElements;i++) SWAP_INT(data[i]); } } else if (type==30) { // 2-byte signed (30) shorts size = 2; Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims)); short *data = a->value.s; bytes_read = fread((void *)data,size,nElements,fs); if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); } } else if (type==40) { // 2-byte unsigned (40) shorts size = 2; Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims)); short *data = a->value.s; Array *b= PushDataBlock(NewArray(&longStruct, tmpDims)); long *data2 = b->value.l; bytes_read = fread((void *)data,size,nElements,fs); if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); } for (i=1;i<=nElements;i++) *(data2++) = (((long)*(data++))|0xFFFF0000)+65535; } else if (type==50) { // 1-byte signed or unsigned chars (50) size = 1; Array *a= PushDataBlock(NewArray(&charStruct, tmpDims)); char *data = a->value.c; bytes_read = fread((void *)data,size,nElements,fs); } else if (type==51) { // text (51) size = 1; Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0)); char *buf; a->value.q[0] = buf = p_malloc(nElements+1); if (DEBUG) printf("strlen: %d\n",(int)strlen((void *)a->value.q[0])); // bytes_read = fread(a->value.q[0],1,nElements,fs); bytes_read = fread(buf,1,nElements,fs); *((char *)buf + nElements) = 0; // append a NULL to text string } else { matclose(filename); sprintf(message,"Unknown type %d",type); YError(message); } if (bytes_read!=nElements) { fseek(fs,nElements*size,SEEK_CUR); matclose(filename); if (DEBUG) printf("read:%ld expected:%ld\n",bytes_read,nBytesToRead); YError("Premature end of file"); } if (!leave_open) matclose(filename); }
void Y_get_addrs(int nArgs) { IOStream *file, *child; Array *array; long *pAddrs= 0, *cAddrs= 0, *rAddrs= 0; int *rFiles= 0; char **rNames= 0; long i, nParent, nChild, nFamily, nRecords; HistoryInfo *history; Dimension *dims; if (nArgs!=1) YError("get_addrs takes exactly one argument"); file= yarg_file(0); history= file->history; child= history? history->child : 0; /* create result array */ dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(5L, 1L, (Dimension *)0); array= PushDataBlock(NewArray(&pointerStruct, tmpDims)); nParent= file->dataTable.nItems; nChild= child? child->dataTable.nItems : 0; nRecords= child? history->nRecords : 0; nFamily= child? history->nFamily : 0; if (nParent) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nParent, 1L, (Dimension *)0); array->value.p[0]= pAddrs= NewArray(&longStruct, tmpDims)->value.l; } if (nChild) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nChild, 1L, (Dimension *)0); array->value.p[1]= cAddrs= NewArray(&longStruct, tmpDims)->value.l; } if (nRecords>0) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nRecords, 1L, (Dimension *)0); array->value.p[2]= rAddrs= NewArray(&longStruct, tmpDims)->value.l; array->value.p[3]= rFiles= NewArray(&intStruct, tmpDims)->value.i; } if (nFamily>0) { dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(nFamily, 1L, (Dimension *)0); array->value.p[4]= rNames= NewArray(&stringStruct, tmpDims)->value.q; } /* and fill it */ for (i=0 ; i<nParent ; i++) pAddrs[i]= file->addresses[i]+file->offset; for (i=0 ; i<nChild ; i++) cAddrs[i]= child->addresses[i]; for (i=0 ; i<nRecords ; i++) rAddrs[i]= history->offset[i]; for (i=0 ; i<nRecords ; i++) rFiles[i]= history->ifile[i]; for (i=0 ; i<nFamily ; i++) rNames[i]= p_strcpy(history->famNames[i]); }
void Y_lsdir(int nArgs) { Symbol *stack = sp-nArgs+1; Symbol *glob = 0; Dimension *dims; y_dirlist *dlist; char *name, **list; long i; int is_dir = 0; if (nArgs<1 || nArgs>2) YError("lsdir takes one or two arguments"); if (nArgs==2) { if (!stack->ops || sp->ops!=&referenceSym) YError("lsdir second argument not simple variable reference"); glob = &globTab[sp->index]; sp--; } dlist = y_new_tmpobj(sizeof(y_dirlist), y_zap_dirlist); dlist->dir = 0; dlist->fils = dlist->subs = 0; dlist->nfils = dlist->nsubs = 0; PushDataBlock(dlist); name = YGetString(stack); if (!name) YError("first argument to lsdir must be a non-nil scalar string"); dlist->dir = p_dopen(name); if (!dlist->dir) { Drop(1); PushLongValue(0); return; } while ((name = p_dnext(dlist->dir, &is_dir))) { if (is_dir && nArgs==2) y_add_item(&dlist->subs, &dlist->nsubs, p_strcpy(name)); else y_add_item(&dlist->fils, &dlist->nfils, p_strcpy(name)); } if (stack->ops==&dataBlockSym) { stack->ops = &intScalar; Unref(stack->value.db); } if (dlist->nfils) { char *nm; dims = tmpDims; tmpDims = 0; FreeDimension(dims); tmpDims = NewDimension(dlist->nfils, 1L, (Dimension *)0); stack->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims); stack->ops = &dataBlockSym; list = ((Array *)stack->value.db)->value.q; for (i=0 ; i<dlist->nfils ; i++) { nm = dlist->fils[i]; dlist->fils[i] = 0; list[i] = nm; } list = dlist->fils; dlist->fils = 0; p_free(list); } else { stack->value.db = (DataBlock *)(RefNC(&nilDB)); stack->ops = &dataBlockSym; } if (glob) { if (glob->ops==&dataBlockSym) { glob->ops = &intScalar; Unref(glob->value.db); } if (dlist->nsubs) { char *nm; dims = tmpDims; tmpDims = 0; FreeDimension(dims); tmpDims = NewDimension(dlist->nsubs, 1L, (Dimension *)0); glob->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims); glob->ops = &dataBlockSym; list = ((Array *)glob->value.db)->value.q; for (i=0 ; i<dlist->nsubs ; i++) { nm = dlist->subs[i]; dlist->subs[i] = 0; list[i] = nm; } list = dlist->subs; dlist->subs = 0; p_free(list); } else { glob->value.db = (DataBlock *)(RefNC(&nilDB)); glob->ops = &dataBlockSym; } } Drop(1); }
void Y__raw_track(int nArgs) { long nrays; Ray *rays; DratMesh *dm; double *slimits; Array *array; Ray_Path *result; long ncuts, i; long *zone, *pt1, *pt2; double *ds, *f; EraseRayPath(&path); if (nArgs!=4) YError("_raw_track takes exactly four arguments"); /* no validity checking -- leave it to interpreted wrapper */ nrays= YGetInteger(sp-3); rays= (Ray *)YGet_D(sp-2, 0, (Dimension **)0); dm= YGetDMesh(sp-1, 0); slimits= YGet_D(sp, 0, (Dimension **)0); /* push result array onto stack */ array= (Array *)PushDataBlock(NewArray(sdRay_Path, NewDimension(nrays, 1L, (Dimension *)0))); array->type.dims->references--; result= (Ray_Path *)array->value.c; while (nrays>0) { TrackRay(&dm->mesh, rays, slimits, &path); result->fi= path.fi; result->ff= path.ff; ncuts= path.ncuts; if (ncuts>1) { Dimension *dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(ncuts, 1L, (Dimension *)0); result->zone= zone= (NewArray(&longStruct, tmpDims))->value.l; result->ds= ds= (NewArray(&doubleStruct, tmpDims))->value.d; result->pt1= pt1= (NewArray(&longStruct, tmpDims))->value.l; result->pt2= pt2= (NewArray(&longStruct, tmpDims))->value.l; result->f= f= (NewArray(&doubleStruct, tmpDims))->value.d; /* convert zone, pt1, and pt2 to 1-origin index lists */ for (i=0 ; i<ncuts ; i++) { zone[i]= path.zone[i]+1; ds[i]= path.ds[i]; pt1[i]= path.pt1[i]+1; pt2[i]= path.pt2[i]+1; f[i]= path.f[i]; } } rays++; slimits+= 2; result++; nrays--; } EraseRayPath(&path); }
void Y_find_boundary(int nArgs) { DratMesh *dm; int region, sense; Array *array; if (liveBoundary) { liveBoundary= 0; EraseBoundary(&boundary); } if (nArgs<1 || nArgs>3) YError("update_mesh takes exactly one, two, or three arguments"); dm= YGetDMesh(sp-nArgs+1, 0); if (nArgs>1) { if (YNotNil(sp-nArgs+2)) region= (int)YGetInteger(sp-nArgs+2); else region= 0; if (nArgs>2 && YNotNil(sp)) sense= (int)YGetInteger(sp); else sense= 0; } else { /* here are the values used in UpdateMesh call to FindBoundaryPoints */ region= 0; sense= 1; } boundary.zsym= dm->mesh.boundary.zsym; if (region!=0 || sense!=1) { /* must calculate boundary now */ boundary.nk= boundary.nl= boundary.npoints= 0; boundary.zone= 0; boundary.side= 0; boundary.z= boundary.r= 0; liveBoundary= 1; FindBoundaryPoints(&dm->mesh.mesh, region, sense, &boundary, dm->mesh.work); } else { /* boundary already calculated */ boundary.nk= dm->mesh.boundary.nk; boundary.nl= dm->mesh.boundary.nl; boundary.npoints= dm->mesh.boundary.npoints; boundary.zone= dm->mesh.boundary.zone; boundary.side= dm->mesh.boundary.side; boundary.z= dm->mesh.boundary.z; boundary.r= dm->mesh.boundary.r; } /* form result -- 1-origin array of 4 pointers */ array= (Array *)PushDataBlock(NewArray(&pointerStruct, NewDimension(4L, 1L, (Dimension *)0))); array->type.dims->references--; if (boundary.npoints>0) { long npoints= boundary.npoints; long i; void **result= array->value.p; long *zone; int *side; double *z, *r; Dimension *dims= tmpDims; tmpDims= 0; FreeDimension(dims); tmpDims= NewDimension(npoints, 1L, (Dimension *)0); result[0]= zone= (NewArray(&longStruct, tmpDims))->value.l; result[1]= side= (NewArray(&intStruct, tmpDims))->value.i; result[2]= z= (NewArray(&doubleStruct, tmpDims))->value.d; result[3]= r= (NewArray(&doubleStruct, tmpDims))->value.d; /* convert zone to 1-origin index list */ for (i=0 ; i<npoints ; i++) { zone[i]= boundary.zone[i]+1; side[i]= boundary.side[i]; z[i]= boundary.z[i]; r[i]= boundary.r[i]; } } if (liveBoundary) EraseBoundary(&boundary); }
void Y_grow(int nArgs) { Symbol *s0, *s= sp-nArgs+1; long index= s->index; Array *array; Dimension *dims; StructDef *base; Operand op; long extra, number; int nDims; DataBlock *db; int amSubroutine= CalledAsSubroutine(); if (nArgs < 2) YError("grow function needs at least two arguments"); if (amSubroutine && s->ops!=&referenceSym) YError("1st argument to grow must be a variable reference"); if (!s->ops) YError("unxepected keyword argument in grow"); dims= growDims; growDims= 0; FreeDimension(dims); /* scan argument list to find first non-nil argument */ base= 0; s0= 0; for (;;) { if (!s0 && amSubroutine) array= (Array *)ForceToDB(&globTab[index]); else array= (Array *)ForceToDB(s); /* does ReplaceRef if required */ s0= s; if (array->ops==&lvalueOps) array= FetchLValue(array, s); if (array->ops->isArray) { base= array->type.base; if (array->references) { /* the grow operation is destructive, must copy 1st arg */ Array *copy= PushDataBlock(NewArray(base, array->type.dims)); base->Copy(base, copy->value.c, array->value.c, array->type.number); PopTo(s); array= copy; } if (array->type.dims) { growDims= NewDimension(1L, 1L, Ref(array->type.dims->next)); } else { growDims= NewDimension(1L, 1L, (Dimension *)0); array->type.dims= NewDimension(1L, 1L, (Dimension *)0); } break; } else if (array->ops!=&voidOps) { YError("bad data type in function grow"); } if (++s > sp) { /* all arguments void, will return nil */ Drop(nArgs-1); PopTo(sp-1); return; } } nDims= CountDims(growDims); /* scan through remaining arguments to force right-conformability with growDims and count the number of extra dimensions */ extra= 0; while (s<sp) { s++; if (!s->ops) YError("unxepected keyword argument in grow"); s->ops->FormOperand(s, &op); if (op.ops->isArray) { if (nDims==CountDims(op.type.dims)) growDims->number= op.type.dims->number; else growDims->number= 1; if (RightConform(growDims, &op)) YError("later arguments not conformable with 1st in grow"); extra+= growDims->number; } else if (op.ops!=&voidOps) { YError("illegal data type in function grow"); } } if (extra) { LValue lvalue; long size; BinaryOp *Assign= base->dataOps->Assign; /* phony LValue necessary for Assign virtual function */ lvalue.references= nArgs; /* NEVER want to free this */ lvalue.ops= &lvalueOps; lvalue.owner= 0; /* not true, but safer */ lvalue.type.base= base; /* NOT Ref(base) -- won't be freed */ lvalue.address.m= 0; lvalue.strider= 0; size= base->size; /* copy 1st non-nil argument */ number= array->type.number; array= PushDataBlock(GrowArray(array, extra)); lvalue.address.m= array->value.c + size*number; /* second pass through argument list copies 2nd-Nth arguments into result array using the Assign virtual function */ s= s0; while (++s<sp) { /* note that sp is bigger than for previous loop */ s->ops->FormOperand(s, &op); if (op.ops->isArray) { lvalue.type.dims= op.type.dims; /* NOT Ref(dims) -- won't be freed */ lvalue.type.number= op.type.number; /* Assign virtual functions assume their first parameter is an LValue* rather than an Operation* (like all other BinaryOps). */ (*Assign)((Operand *)&lvalue, &op); lvalue.address.m+= size*lvalue.type.number; } } } /* store result back to first reference -- will also be left on stack by EvalBI */ if (amSubroutine) { s= &globTab[index]; /* guaranteed this is a dataBlockSym by ForceToDB */ db= s->value.db; s->value.db= (DataBlock *)Ref(array); Unref(db); if (extra) Drop(nArgs); else Drop(nArgs-1); ReplaceRef(sp); /* result is 1st argument */ PopTo(sp-1); } else { if (extra) { /* result is on top of stack */ PopTo(sp-nArgs-1); Drop(nArgs); } else { /* result is unchanged s0 argument */ int nAbove= sp-s0; Drop(nAbove); nArgs-= nAbove; PopTo(sp-nArgs); Drop(nArgs-1); } } }
void Y_span(int nArgs) { long which, nDims, number, nfast, i, j, k, kx; double rnumber, dp, *p0, *p1, *p; Array *array; Dimension *tmp; Operand op0, op1; if (nArgs!=3 && nArgs!=4) YError("span takes exactly three or four arguments"); if (nArgs==4) { which= YGetInteger(sp)-1; Drop(1); } else which= 0; /* use 0-origin which here */ number= YGetInteger(sp); if (number<1) YError("3rd argument to span function must be >0"); Drop(1); sp->ops->FormOperand(sp, &op1); (sp-1)->ops->FormOperand(sp-1, &op0); op1.ops->ToDouble(&op1); op0.ops->ToDouble(&op0); if (BinaryConform(&op1, &op0) & 4) YError("start and stop not conformable in span function"); tmp= tmpDims; tmpDims= 0; FreeDimension(tmp); /* compute dimensions of result -- nfast-by-number-by-(slow), where nfast are the first which indices of op0 (or op1), and (slow) are the rest */ nDims= CountDims(op0.type.dims); if (which<0) which= nDims+1+which; /* handle which<0 like array index<0 */ if (which>8 || nDims-which>8) YError("the 4th argument to span is unreasonably large"); while (which<0) { tmpDims= NewDimension(1L, 1L, tmpDims); which++; } if (which>=nDims) { /* can just tack new element of dimension list onto old */ tmpDims= Ref(op0.type.dims); while (which>nDims) { tmpDims= NewDimension(1L, 1L, tmpDims); which--; } tmpDims= NewDimension(number, 1L, tmpDims); nfast= op0.type.number; } else { /* make a fresh copy of the index list, then insert new element */ Dimension *prev; which= nDims-which; /* guaranteed this is >0 */ tmpDims= tmp= CopyDims(op0.type.dims, tmpDims, 1); do { prev= tmp; tmp= tmp->next; } while (--which); prev->next= NewDimension(number, 1L, tmp); nfast= TotalNumber(tmp); } /* create result array and fill it */ array= PushDataBlock(NewArray(&doubleStruct, tmpDims)); p= array->value.d; p0= op0.value; p1= op1.value; rnumber= 1.0/(double)(number-1); kx= array->type.number - nfast; for (i=0 ; i<op0.type.number ; i+=nfast) { for (j=0 ; j<nfast ; j++) { dp= (p1[i+j]-p0[i+j])*rnumber; k= j+number*i; p[k]= p0[i+j]; for (k+=nfast ; k<kx ; k+=nfast) p[k]= p[k-nfast]+dp; p[k]= p1[i+j]; /* do after loop to assure exact equality */ } } }
void Y_transpose(int nArgs) { Symbol *stack= sp-nArgs+1; Operand op, opp; int i, nDims, order[10]; long numbers[10], origins[10], strides[10]; long stride, *cycle, index, prev, next, last; Dimension *dims; LValue *lvalue; Strider *strider; if (nArgs < 1) YError("transpose needs at least argument"); stack->ops->FormOperand(stack, &op); if (!op.ops->isArray) YError("1st argument to transpose must be array"); nDims= CountDims(op.type.dims); if (nDims>10) YError("transpose fails for arrays with >10 dimensions"); if (nDims<1) { if (nArgs>1) Drop(nArgs-1); return; } /* collect dimension lengths and strides into arrays to be permuted */ dims= op.type.dims; stride= 1; for (i=0 ; i<nDims ; i++) { numbers[nDims-1-i]= dims->number; origins[nDims-1-i]= dims->origin; dims= dims->next; } stride= op.type.base->size; for (i=0 ; i<nDims ; i++) { strides[i]= stride; stride*= numbers[i]; } /* compute the permutation from the remaining arguments */ for (i=0 ; i<nDims ; i++) order[i]= i; if (nArgs<2) { /* default is to swap first and last indices */ if (nDims) { prev= order[0]; order[0]= order[nDims-1]; order[nDims-1]= prev; } } else { /* read permutation list */ while (stack<sp) { stack++; stack->ops->FormOperand(stack, &opp); if (opp.ops->promoteID>T_LONG || (opp.type.dims && opp.type.dims->next)) YError("bad permutation list in transpose"); opp.ops->ToLong(&opp); cycle= opp.value; if (opp.type.dims) { /* this is a cycle list */ last= cycle[0]-1; if (last<0) last+= nDims; if (last<0 || last>=nDims) YError("permutation list references non-existent dimension " "in transpose"); prev= order[last]; for (i=1 ; i<opp.type.number ; i++) { index= cycle[i]-1; if (index<0) index+= nDims; if (index<0 || index>=nDims) YError("permutation list references non-existent dimension " "in transpose"); next= order[index]; order[index]= prev; prev= next; } order[last]= prev; } else { /* this is a cyclic permutation of all nDims indices */ long inc= cycle[0]-1; /* index which 0 should go to */ long now; if (inc<0) inc= nDims - (-inc)%nDims; if (inc>=nDims) inc%= nDims; prev= order[0]; now= inc; last= now; for (i=0 ; i<nDims ; i++) { next= order[now]; order[now]= prev; prev= next; now+= inc; if (now>=nDims) now-= nDims; if (last==now) { /* handle case of several independent cycles when nDims is evenly divisible by inc */ prev= order[++now]; now+= inc; if (now>=nDims) now-= nDims; last= now; } } } } Drop(nArgs-1); } /* build re-ordered dimension list */ dims= tmpDims; tmpDims= 0; FreeDimension(dims); for (i=0 ; i<nDims ; i++) tmpDims= NewDimension(numbers[order[i]], origins[order[i]], tmpDims); /* push LValue describing result onto stack */ lvalue= PushDataBlock(NewLValueM((Array *)sp->value.db, op.value, op.type.base, tmpDims)); /* build strider list describing re-ordering */ for (i=0 ; i<nDims ; i++) { strider= NewStrider(strides[order[i]], numbers[order[i]]); strider->next= lvalue->strider; lvalue->strider= strider; } PopTo(sp-2); Drop(1); FetchLValue(lvalue, sp); }
//============================================================================== /// Constructor. /// UnitSystem::UnitSystem() { Dimension *scalar_dim_p = NewDimension( "Scalar", DimensionId() ); NewUnit( "Scalar", scalar_dim_p ); }