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