void deleteScene (pScene sc) {
/* default */
if (ddebug) printf("deleteScene\n");
M_free(sc->view);
M_free(sc->clip);
M_free(sc->persp);
M_free(sc->camera);
M_free(sc->material);
M_free(sc->matsort);
M_free(sc);
}
int DoSetups()
{
UBYTE *setbuffer, *s, *t, *u /*, c */;
int errors = 0;
setbuffer = LoadInputFile((UBYTE *)setupfilename,SETUPFILE);
if ( setbuffer ) {
/*
The contents of the file are now in setbuffer.
Each line is commentary or a single command.
The buffer is terminated with a zero.
*/
s = setbuffer;
while ( *s ) {
if ( *s == ' ' || *s == '\t' || *s == '*' || *s == '#' || *s == '\n' ) {
while ( *s && *s != '\n' ) s++;
}
else if ( tolower(*s) < 'a' || tolower(*s) > 'z' ) {
t = s;
while ( *s && *s != '\n' ) s++;
/*
c = *s; *s = 0;
Error1("Setup file: Illegal statement: ",t);
errors++; *s = c;
*/
}
else {
t = s; /* name of the option */
while ( tolower(*s) >= 'a' && tolower(*s) <= 'z' ) s++;
*s++ = 0;
while ( *s == ' ' || *s == '\t' ) s++;
u = s; /* 'value' of the option */
while ( *s && *s != '\n' && *s != '\r' ) s++;
if ( *s ) *s++ = 0;
errors += ProcessOption(t,u,0);
}
while ( *s == '\n' || *s == '\r' ) s++;
}
M_free(setbuffer,"setup file buffer");
}
if ( errors ) return(1);
else return(0);
}
int DoTail(int argc, UBYTE **argv)
{
int errorflag = 0, onlyversion = 1;
UBYTE *s, *t, *copy;
int threadnum = 0;
argc--; argv++;
AM.LogType = -1;
AM.HoldFlag = AM.qError = AM.Interact = AM.FileOnlyFlag = 0;
AM.InputFileName = AM.LogFileName = AM.IncDir = AM.TempDir = AM.TempSortDir =
#ifdef WITHMPI
AM.SetupDir = AM.SetupFile = 0;
#else
AM.SetupDir = AM.SetupFile = AM.Path = 0;
#endif
if ( argc < 1 ) {
onlyversion = 0;
goto printversion;
}
while ( argc >= 1 ) {
s = *argv++; argc--;
if ( *s == '-' || ( *s == '/' && ( argc > 0 || AM.Interact ) ) ) {
s++;
switch (*s) {
case 'c': /* Error checking only */
AM.qError = 1; break;
case 'D':
case 'd': /* Next arg is define preprocessor var. */
t = copy = strDup1(*argv,"Dotail");
while ( *t && *t != '=' ) t++;
if ( *t == 0 ) {
if ( PutPreVar(copy,(UBYTE *)"1",0,0) < 0 ) return(-1);
}
else {
*t++ = 0;
if ( PutPreVar(copy,t,0,0) < 0 ) return(-1);
t[-1] = '=';
}
M_free(copy,"-d prevar");
argv++; argc--; break;
case 'f': /* Output only to regular log file */
AM.FileOnlyFlag = 1; AM.LogType = 0; break;
case 'F': /* Output only to log file. Further like L. */
AM.FileOnlyFlag = 1; AM.LogType = 1; break;
case 'h': /* For old systems: wait for key before exit */
AM.HoldFlag = 1; break;
#ifdef WITHINTERACTION
case 'i': /* Interactive session (not used yet) */
AM.Interact = 1; break;
#endif
case 'I': /* Next arg is dir for inc/prc/sub files */
TAKEPATH(AM.IncDir) break;
case 'l': /* Make regular log file */
if ( s[1] == 'l' ) AM.LogType = 1; /*compatibility! */
else AM.LogType = 0;
break;
case 'L': /* Make log file with only final statistics */
AM.LogType = 1; break;
case 'M': /* Multirun. Name of tempfiles will contain PID */
AM.MultiRun = 1;
break;
case 'm': /* Read number of threads */
case 'w': /* Read number of workers */
t = s++;
threadnum = 0;
while ( *s >= '0' && *s <= '9' )
threadnum = 10*threadnum + *s++ - '0';
if ( *s ) {
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal value for option m or w: %s\n",t);
errorflag++;
}
/* if ( threadnum == 1 ) threadnum = 0; */
threadnum++;
break;
/*
case 'n':
Reserved for number of slaves without MPI
*/
case 'p':
#ifdef WITHEXTERNALCHANNEL
/*There are two possibilities: -p|-pipe*/
if(s[1]=='i'){
if( (s[2]=='p')&&(s[3]=='e')&&(s[4]=='\0') ){
argc--;
/*Initialize pre-set external channels, see
the file extcmd.c:*/
if(initPresetExternalChannels(*argv++,AX.timeout)<1){
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Error initializing preset external channels\n");
errorflag++;
}
AX.timeout=-1;/*This indicates that preset channels
are initialized from cmdline*/
}else{
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal option in call of FORM: %s\n",s);
errorflag++;
}
}else
#else
if ( s[1] ) {
if ( ( s[1]=='i' ) && ( s[2] == 'p' ) && (s[3] == 'e' )
&& ( s[4] == '\0' ) ){
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal option: Pipes not supported on this system.\n");
}
else {
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal option: %s\n",s);
}
errorflag++;
}
else
#endif
{
/* Next arg is a path variable like in environment */
TAKEPATH(AM.Path)
}
break;
case 'q': /* Quiet option. Only output. Same as -si */
AM.silent = 1; break;
case 'R': /* recover from saved snapshot */
AC.CheckpointFlag = -1;
break;
case 's': /* Next arg is dir with form.set to be used */
if ( ( s[1] == 'o' ) && ( s[2] == 'r' ) && ( s[3] == 't' ) ) {
if(s[4]== '=' ) {
AM.TempSortDir = s+5;
}
else {
AM.TempSortDir = *argv++;
argc--;
}
}
else if ( s[1] == 'i' ) { /* compatibility: silent/quiet */
AM.silent = 1;
}
else {
TAKEPATH(AM.SetupDir)
}
break;
case 'S': /* Next arg is setup file */
TAKEPATH(AM.SetupFile) break;
case 't': /* Next arg is directory for temp files */
if ( s[1] == 's' ) {
s++;
AM.havesortdir = 1;
TAKEPATH(AM.TempSortDir)
}
else {
TAKEPATH(AM.TempDir)
}
break;
case 'T': /* Print the total size used at end of job */
AM.PrintTotalSize = 1; break;
case 'v':
printversion:;
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
{
char buffer[100], *s = buffer;
sprintf(s,"%s %s (%s)",FORMNAME,VERSIONSTR,PRODUCTIONDATE);
while ( *s ) s++;
sprintf(s," %d-bits",(WORD)(sizeof(WORD)*16));
while ( *s ) s++;
printf("%s\n",buffer);
}
if ( onlyversion ) return(1);
goto NoFile;
case 'y': /* Preprocessor dumps output. No compilation. */
AP.PreDebug = PREPROONLY; break;
default:
if ( FG.cTable[*s] == 1 ) {
AM.SkipClears = 0; t = s;
while ( FG.cTable[*t] == 1 )
AM.SkipClears = 10*AM.SkipClears + *t++ - '0';
if ( *t != 0 ) {
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal numerical option in call of FORM: %s\n",s);
errorflag++;
}
}
else {
#ifdef WITHMPI
if ( PF.me == MASTER )
#endif
printf("Illegal option in call of FORM: %s\n",s);
errorflag++;
}
break;
}
int AllocSetups()
{
SETUPPARAMETERS *sp;
LONG LargeSize, SmallSize, SmallEsize, TermsInSmall, IOsize;
int MaxPatches, MaxFpatches, error = 0, i, size;
UBYTE *s;
#ifndef WITHPTHREADS
int j;
#endif
sp = GetSetupPar((UBYTE *)"threads");
if ( sp->value > 0 ) AM.totalnumberofthreads = sp->value+1;
AM.OutBuffer = (UBYTE *)Malloc1(AM.OutBufSize+1,"OutputBuffer");
AP.PreAssignStack =(LONG *)Malloc1(AP.MaxPreAssignLevel*sizeof(LONG *),"PreAssignStack");
for ( i = 0; i < AP.MaxPreAssignLevel; i++ ) AP.PreAssignStack[i] = 0;
AC.iBuffer = (UBYTE *)Malloc1(AC.iBufferSize+1,"statement buffer");
AC.iStop = AC.iBuffer + AC.iBufferSize-2;
AP.preStart = (UBYTE *)Malloc1(AP.pSize,"instruction buffer");
AP.preStop = AP.preStart + AP.pSize - 3;
/* AP.PreIfStack is already allocated in StartPrepro(), but to be sure we
"if" the freeing */
if ( AP.PreIfStack ) M_free(AP.PreIfStack,"PreIfStack");
AP.PreIfStack = (int *)Malloc1(AP.MaxPreIfLevel*sizeof(int),
"Preprocessor if stack");
AP.PreIfStack[0] = EXECUTINGIF;
sp = GetSetupPar((UBYTE *)"insidefirst");
AM.ginsidefirst = AC.minsidefirst = AC.insidefirst = sp->value;
/*
We need to consider eliminating this variable
*/
sp = GetSetupPar((UBYTE *)"maxtermsize");
AM.MaxTer = sp->value*sizeof(WORD);
if ( AM.MaxTer < 200*(LONG)(sizeof(WORD)) ) AM.MaxTer = 200*(LONG)(sizeof(WORD));
if ( AM.MaxTer > MAXPOSITIVE - 200*(LONG)(sizeof(WORD)) ) AM.MaxTer = MAXPOSITIVE - 200*(LONG)(sizeof(WORD));
AM.MaxTer /= (LONG)sizeof(WORD);
AM.MaxTer *= (LONG)sizeof(WORD);
/*
Allocate workspace.
*/
sp = GetSetupPar((UBYTE *)"workspace");
AM.WorkSize = sp->value;
#ifdef WITHPTHREADS
#else
AT.WorkSpace = (WORD *)Malloc1(AM.WorkSize*sizeof(WORD),(char *)(sp->parameter));
AT.WorkTop = AT.WorkSpace + AM.WorkSize;
AT.WorkPointer = AT.WorkSpace;
#endif
/*
Fixed indices
*/
sp = GetSetupPar((UBYTE *)"constindex");
if ( ( sp->value+100+5*WILDOFFSET ) > MAXPOSITIVE ) {
MesPrint("Setting of %s in setupfile too large","constindex");
AM.OffsetIndex = MAXPOSITIVE - 5*WILDOFFSET - 100;
MesPrint("value corrected to maximum allowed: %d",AM.OffsetIndex);
}
else AM.OffsetIndex = sp->value + 1;
AC.FixIndices = (WORD *)Malloc1((AM.OffsetIndex)*sizeof(WORD),(char *)(sp->parameter));
AM.WilInd = AM.OffsetIndex + WILDOFFSET;
AM.DumInd = AM.OffsetIndex + 2*WILDOFFSET;
AM.IndDum = AM.DumInd + WILDOFFSET;
#ifndef WITHPTHREADS
AR.CurDum = AN.IndDum = AM.IndDum;
#endif
AM.mTraceDum = AM.IndDum + 2*WILDOFFSET;
sp = GetSetupPar((UBYTE *)"parentheses");
AM.MaxParLevel = sp->value+1;
AC.tokenarglevel = (WORD *)Malloc1((sp->value+1)*sizeof(WORD),(char *)(sp->parameter));
/*
Space during calculations
*/
sp = GetSetupPar((UBYTE *)"maxnumbersize");
/*
size = ( sp->value + 11 ) & (-4);
AM.MaxTal = size - 2;
if ( AM.MaxTal > (AM.MaxTer/sizeof(WORD)-2)/2 )
AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2;
if ( AM.MaxTal < (AM.MaxTer/sizeof(WORD)-2)/4 )
AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/4;
*/
/*
There is too much confusion about MaxTal cq maxnumbersize.
It seems better to fix it at its maximum value. This way we only worry
about maxtermsize. This can be understood better by the 'innocent' user.
*/
if ( sp->value == 0 ) {
AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2;
}
else {
size = ( sp->value + 11 ) & (-4);
AM.MaxTal = size - 2;
if ( (size_t)AM.MaxTal > (size_t)((AM.MaxTer/sizeof(WORD)-2)/2) )
AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2;
}
AM.MaxTal &= -sizeof(WORD)*2;
sp->value = AM.MaxTal;
AC.cmod = (UWORD *)Malloc1(AM.MaxTal*4*sizeof(UWORD),(char *)(sp->parameter));
AM.gcmod = AC.cmod + AM.MaxTal;
AC.powmod = AM.gcmod + AM.MaxTal;
AM.gpowmod = AC.powmod + AM.MaxTal;
/*
The IO buffers for the input and output expressions.
Fscr[2] will be assigned in a later stage for hiding expressions from
the regular action. That will make the program faster.
*/
sp = GetSetupPar((UBYTE *)"scratchsize");
AM.ScratSize = sp->value/sizeof(WORD);
if ( AM.ScratSize < 4*AM.MaxTer ) AM.ScratSize = 4*AM.MaxTer;
AM.HideSize = AM.ScratSize;
sp = GetSetupPar((UBYTE *)"hidesize");
if ( sp->value > 0 ) {
AM.HideSize = sp->value/sizeof(WORD);
if ( AM.HideSize < 4*AM.MaxTer ) AM.HideSize = 4*AM.MaxTer;
}
sp = GetSetupPar((UBYTE *)"factorizationcache");
AM.fbuffersize = sp->value;
#ifdef WITHPTHREADS
sp = GetSetupPar((UBYTE *)"threadscratchsize");
AM.ThreadScratSize = sp->value/sizeof(WORD);
sp = GetSetupPar((UBYTE *)"threadscratchoutsize");
AM.ThreadScratOutSize = sp->value/sizeof(WORD);
#endif
#ifndef WITHPTHREADS
for ( j = 0; j < 2; j++ ) {
WORD *ScratchBuf;
ScratchBuf = (WORD *)Malloc1(AM.ScratSize*sizeof(WORD),"scratchsize");
AR.Fscr[j].POsize = AM.ScratSize * sizeof(WORD);
AR.Fscr[j].POfull = AR.Fscr[j].POfill = AR.Fscr[j].PObuffer = ScratchBuf;
AR.Fscr[j].POstop = AR.Fscr[j].PObuffer + AM.ScratSize;
PUTZERO(AR.Fscr[j].POposition);
}
AR.Fscr[2].PObuffer = 0;
#endif
sp = GetSetupPar((UBYTE *)"threadbucketsize");
AC.ThreadBucketSize = AM.gThreadBucketSize = AM.ggThreadBucketSize = sp->value;
sp = GetSetupPar((UBYTE *)"threadloadbalancing");
AC.ThreadBalancing = AM.gThreadBalancing = AM.ggThreadBalancing = sp->value;
sp = GetSetupPar((UBYTE *)"threadsortfilesynch");
AC.ThreadSortFileSynch = AM.gThreadSortFileSynch = AM.ggThreadSortFileSynch = sp->value;
/*
The size for shared memory window for oneside MPI2 communications
*/
sp = GetSetupPar((UBYTE *)"shmwinsize");
AM.shmWinSize = sp->value/sizeof(WORD);
if ( AM.shmWinSize < 4*AM.MaxTer ) AM.shmWinSize = 4*AM.MaxTer;
/*
The sort buffer
*/
sp = GetSetupPar((UBYTE *)"smallsize");
SmallSize = sp->value;
sp = GetSetupPar((UBYTE *)"smallextension");
SmallEsize = sp->value;
sp = GetSetupPar((UBYTE *)"largesize");
LargeSize = sp->value;
sp = GetSetupPar((UBYTE *)"termsinsmall");
TermsInSmall = sp->value;
sp = GetSetupPar((UBYTE *)"largepatches");
MaxPatches = sp->value;
sp = GetSetupPar((UBYTE *)"filepatches");
MaxFpatches = sp->value;
sp = GetSetupPar((UBYTE *)"sortiosize");
IOsize = sp->value;
if ( IOsize < AM.MaxTer ) { IOsize = AM.MaxTer; sp->value = IOsize; }
#ifndef WITHPTHREADS
#ifdef WITHZLIB
for ( j = 0; j < 2; j++ ) { AR.Fscr[j].ziosize = IOsize; }
#endif
#endif
AM.S0 = 0;
AM.S0 = AllocSort(LargeSize,SmallSize,SmallEsize,TermsInSmall
,MaxPatches,MaxFpatches,IOsize);
#ifdef WITHZLIB
AM.S0->file.ziosize = IOsize;
#ifndef WITHPTHREADS
AR.FoStage4[0].ziosize = IOsize;
AR.FoStage4[1].ziosize = IOsize;
AT.S0 = AM.S0;
#endif
#else
#ifndef WITHPTHREADS
AT.S0 = AM.S0;
#endif
#endif
#ifndef WITHPTHREADS
AR.FoStage4[0].POsize = ((IOsize+sizeof(WORD)-1)/sizeof(WORD))*sizeof(WORD);
AR.FoStage4[1].POsize = ((IOsize+sizeof(WORD)-1)/sizeof(WORD))*sizeof(WORD);
#endif
sp = GetSetupPar((UBYTE *)"subsmallsize");
AM.SSmallSize = sp->value;
sp = GetSetupPar((UBYTE *)"subsmallextension");
AM.SSmallEsize = sp->value;
sp = GetSetupPar((UBYTE *)"sublargesize");
AM.SLargeSize = sp->value;
sp = GetSetupPar((UBYTE *)"subtermsinsmall");
AM.STermsInSmall = sp->value;
sp = GetSetupPar((UBYTE *)"sublargepatches");
AM.SMaxPatches = sp->value;
sp = GetSetupPar((UBYTE *)"subfilepatches");
AM.SMaxFpatches = sp->value;
sp = GetSetupPar((UBYTE *)"subsortiosize");
AM.SIOsize = sp->value;
sp = GetSetupPar((UBYTE *)"spectatorsize");
AM.SpectatorSize = sp->value;
/*
The next code is just for the moment (26-jan-1997) because we have
the new parts combined with the old. Once the old parts are gone
from the program, we can eliminate this code too.
*/
sp = GetSetupPar((UBYTE *)"functionlevels");
AM.maxFlevels = sp->value + 1;
#ifdef WITHPTHREADS
#else
AT.Nest = (NESTING)Malloc1((LONG)sizeof(struct NeStInG)*AM.maxFlevels,"functionlevels");
AT.NestStop = AT.Nest + AM.maxFlevels;
AT.NestPoin = AT.Nest;
#endif
sp = GetSetupPar((UBYTE *)"maxwildcards");
AM.MaxWildcards = sp->value;
#ifdef WITHPTHREADS
#else
AT.WildMask = (WORD *)Malloc1((LONG)AM.MaxWildcards*sizeof(WORD),"maxwildcards");
#endif
sp = GetSetupPar((UBYTE *)"compresssize");
if ( sp->value < 2*AM.MaxTer ) sp->value = 2*AM.MaxTer;
AM.CompressSize = sp->value;
#ifndef WITHPTHREADS
AR.CompressBuffer = (WORD *)Malloc1((AM.CompressSize+10)*sizeof(WORD),"compresssize");
AR.CompressPointer = AR.CompressBuffer;
AR.ComprTop = AR.CompressBuffer + AM.CompressSize;
#endif
sp = GetSetupPar((UBYTE *)"bracketindexsize");
if ( sp->value < 20*AM.MaxTer ) sp->value = 20*AM.MaxTer;
AM.MaxBracketBufferSize = sp->value/sizeof(WORD);
sp = GetSetupPar((UBYTE *)"dotchar");
AO.FortDotChar = ((UBYTE *)(sp->value))[0];
sp = GetSetupPar((UBYTE *)"commentchar");
AP.cComChar = AP.ComChar = ((UBYTE *)(sp->value))[0];
sp = GetSetupPar((UBYTE *)"procedureextension");
/*
Check validity first.
*/
s = (UBYTE *)(sp->value);
if ( FG.cTable[*s] != 0 ) {
MesPrint(" Illegal string for procedure extension %s",(UBYTE *)sp->value);
error = -2;
}
else {
s++;
while ( *s ) {
if ( *s == ' ' || *s == '\t' || *s == '\n' ) {
MesPrint(" Illegal string for procedure extension %s",(UBYTE *)sp->value);
error = -2;
break;
}
s++;
}
}
AP.cprocedureExtension = strDup1((UBYTE *)(sp->value),"procedureExtension");
AP.procedureExtension = strDup1(AP.cprocedureExtension,"procedureExtension");
sp = GetSetupPar((UBYTE *)"totalsize");
if ( sp->value != 2 ) AM.PrintTotalSize = sp->value;
sp = GetSetupPar((UBYTE *)"continuationlines");
AM.FortranCont = sp->value;
if ( AM.FortranCont <= 0 ) AM.FortranCont = 1;
sp = GetSetupPar((UBYTE *)"oldorder");
AM.OldOrderFlag = sp->value;
sp = GetSetupPar((UBYTE *)"resettimeonclear");
AM.resetTimeOnClear = sp->value;
sp = GetSetupPar((UBYTE *)"nospacesinnumbers");
AO.NoSpacesInNumbers = AM.gNoSpacesInNumbers = AM.ggNoSpacesInNumbers = sp->value;
sp = GetSetupPar((UBYTE *)"indentspace");
AO.IndentSpace = AM.gIndentSpace = AM.ggIndentSpace = sp->value;
sp = GetSetupPar((UBYTE *)"nwritestatistics");
AC.StatsFlag = AM.gStatsFlag = AM.ggStatsFlag = 1-sp->value;
sp = GetSetupPar((UBYTE *)"nwritefinalstatistics");
AC.FinalStats = AM.gFinalStats = AM.ggFinalStats = 1-sp->value;
sp = GetSetupPar((UBYTE *)"nwritethreadstatistics");
AC.ThreadStats = AM.gThreadStats = AM.ggThreadStats = 1-sp->value;
sp = GetSetupPar((UBYTE *)"nwriteprocessstatistics");
AC.ProcessStats = AM.gProcessStats = AM.ggProcessStats = 1-sp->value;
sp = GetSetupPar((UBYTE *)"oldparallelstatistics");
AC.OldParallelStats = AM.gOldParallelStats = AM.ggOldParallelStats = sp->value;
sp = GetSetupPar((UBYTE *)"oldfactarg");
AC.OldFactArgFlag = AM.gOldFactArgFlag = AM.ggOldFactArgFlag = sp->value;
sp = GetSetupPar((UBYTE *)"oldgcd");
AC.OldGCDflag = AM.gOldGCDflag = AM.ggOldGCDflag = sp->value;
sp = GetSetupPar((UBYTE *)"wtimestats");
if ( sp->value == 2 ) sp->value = AM.ggWTimeStatsFlag;
AC.WTimeStatsFlag = AM.gWTimeStatsFlag = AM.ggWTimeStatsFlag = sp->value;
sp = GetSetupPar((UBYTE *)"sorttype");
if ( StrICmp((UBYTE *)"lowfirst",(UBYTE *)sp->value) == 0 ) {
AC.lSortType = SORTLOWFIRST;
}
else if ( StrICmp((UBYTE *)"highfirst",(UBYTE *)sp->value) == 0 ) {
AC.lSortType = SORTHIGHFIRST;
}
else {
MesPrint(" Illegal SortType specification: %s",(UBYTE *)sp->value);
error = -2;
}
sp = GetSetupPar((UBYTE *)"processbucketsize");
AM.hProcessBucketSize = AM.gProcessBucketSize =
AC.ProcessBucketSize = AC.mProcessBucketSize = sp->value;
/*
The store caches (code installed 15-aug-2006 JV)
*/
sp = GetSetupPar((UBYTE *)"numstorecaches");
AM.NumStoreCaches = sp->value;
sp = GetSetupPar((UBYTE *)"sizestorecache");
AM.SizeStoreCache = sp->value;
#ifndef WITHPTHREADS
/*
Install the store caches (15-aug-2006 JV)
Note that in the case of PTHREADS this is done in InitializeOneThread
*/
AT.StoreCache = AT.StoreCacheAlloc = 0;
if ( AM.NumStoreCaches > 0 ) {
STORECACHE sa, sb;
size = sizeof(struct StOrEcAcHe)+AM.SizeStoreCache;
size = ((size-1)/sizeof(size_t)+1)*sizeof(size_t);
AT.StoreCacheAlloc = (STORECACHE)Malloc1(size*AM.NumStoreCaches,"StoreCaches");
AT.StoreCache = AT.StoreCacheAlloc;
sa = AT.StoreCache;
for ( j = 0; j < AM.NumStoreCaches; j++ ) {
sb = (STORECACHE)(VOID *)((UBYTE *)sa+size);
if ( j == AM.NumStoreCaches-1 ) {
sa->next = 0;
}
else {
sa->next = sb;
}
SETBASEPOSITION(sa->position,-1);
SETBASEPOSITION(sa->toppos,-1);
sa = sb;
}
}
#endif
/*
And now some order sensitive things
*/
if ( AM.Path == 0 ) {
sp = GetSetupPar((UBYTE *)"path");
AM.Path = strDup1((UBYTE *)(sp->value),"path");
}
if ( AM.IncDir == 0 ) {
sp = GetSetupPar((UBYTE *)"incdir");
AM.IncDir = strDup1((UBYTE *)(sp->value),"incdir");
}
/*
if ( AM.TempDir == 0 ) {
sp = GetSetupPar((UBYTE *)"tempdir");
AM.TempDir = strDup1((UBYTE *)(sp->value),"tempdir");
}
*/
return(error);
}
int ProcessOption(UBYTE *s1, UBYTE *s2, int filetype)
{
SETUPPARAMETERS *sp;
int n, giveback = 0, error = 0;
UBYTE *s, *t, *s2ret;
LONG x;
sp = GetSetupPar(s1);
if ( sp ) {
/*
We check now whether there are `' variables to be looked up in the
environment. This is new (30-may-2008). This is only allowed in s2.
*/
restart:;
{
UBYTE *s3,*s4,*s5,*s6, c, *start;
int n1,n2,n3;
s = s2;
while ( *s ) {
if ( *s == '\\' ) s += 2;
else if ( *s == '`' ) {
start = s; s++;
while ( *s && *s != '\'' ) {
if ( *s == '\\' ) s++;
s++;
}
if ( *s == 0 ) {
MesPrint("%s: Illegal use of ` character for parameter %s"
,proop1[filetype],s1);
return(1);
}
c = *s; *s = 0;
s3 = (UBYTE *)getenv((char *)(start+1));
if ( s3 == 0 ) {
MesPrint("%s: Cannot find environment variable %s for parameter %s"
,proop1[filetype],start+1,s1);
return(1);
}
*s = c; s++;
n1 = start - s2; s4 = s3; n2 = 0;
while ( *s4 ) {
if ( *s4 == '\\' ) { s4++; n2++; }
s4++; n2++;
}
s4 = s; n3 = 0;
while ( *s4 ) {
if ( *s4 == '\\' ) { s4++; n3++; }
s4++; n3++;
}
s4 = (UBYTE *)Malloc1((n1+n2+n3+1)*sizeof(UBYTE),"environment in setup");
s5 = s2; s6 = s4;
while ( n1-- > 0 ) *s6++ = *s5++;
s5 = s3;
while ( n2-- > 0 ) *s6++ = *s5++;
s5 = s;
while ( n3-- > 0 ) *s6++ = *s5++;
*s6 = 0;
if ( giveback ) M_free(s2,"environment in setup");
s2 = s4;
giveback = 1;
goto restart;
}
else s++;
}
}
n = sp->type;
s2ret = s2;
switch ( n ) {
case NUMERICALVALUE:
ParseNumber(x,s2);
if ( *s2 == 'K' ) { x = x * 1000; s2++; }
else if ( *s2 == 'M' ) { x = x * 1000000; s2++; }
else if ( *s2 == 'G' ) { x = x * 1000000000; s2++; }
else if ( *s2 == 'T' ) { x = x * 1000000000000; s2++; }
if ( *s2 && *s2 != ' ' && *s2 != '\t' ) {
MesPrint("%s: Numerical value expected for parameter %s"
,proop1[filetype],s1);
error = 1; break;
}
sp->value = x;
sp->flags = USEDFLAG;
break;
case STRINGVALUE:
if ( StrICmp(s1,(UBYTE *)"tempsortdir") == 0 ) AM.havesortdir = 1;
s = s2; t = s2;
while ( *s ) {
if ( *s == ' ' || *s == '\t' ) break;
if ( *s == '\\' ) s++;
*t++ = *s++;
}
*t = 0;
if ( sp->flags == USEDFLAG && sp->value != 0 )
M_free((VOID *)(sp->value),"Process option");
sp->value = (LONG)strDup1(s2,"Process option");
sp->flags = USEDFLAG;
break;
case PATHVALUE:
if ( StrICmp(s1,(UBYTE *)"incdir") == 0 ) {
AM.IncDir = 0;
}
else if ( StrICmp(s1,(UBYTE *)"path") == 0 ) {
if ( AM.Path ) M_free(AM.Path,"path");
AM.Path = 0;
}
else {
MesPrint("Setups: %s not yet implemented",s1);
error = 1;
break;
}
if ( sp->flags == USEDFLAG && sp->value != 0 )
M_free((VOID *)(sp->value),"Process option");
sp->value = (LONG)strDup1(s2,"Process option");
sp->flags = USEDFLAG;
break;
case ONOFFVALUE:
if ( tolower(*s2) == 'o' && tolower(s2[1]) == 'n'
&& ( s2[2] == 0 || s2[2] == ' ' || s2[2] == '\t' ) )
sp->value = 1;
else if ( tolower(*s2) == 'o' && tolower(s2[1]) == 'f'
&& tolower(s2[2]) == 'f'
&& ( s2[3] == 0 || s2[3] == ' ' || s2[3] == '\t' ) )
sp->value = 0;
else {
MesPrint("%s: Unrecognized option for parameter %s: %s"
,proop1[filetype],s1,s2);
error = 1; break;
}
sp->flags = USEDFLAG;
break;
case DEFINEVALUE:
/*
if ( sp->value ) M_free((UBYTE *)(sp->value),"Process option");
sp->value = (LONG)strDup1(s2,"Process option");
*/
if ( TheDefine(s2,2) ) error = 1;
break;
default:
Error1("Error in setupparameter table for:",s1);
error = 1;
break;
}
}
else {
MesPrint("%s: Keyword not recognized: %s",proop1[filetype],s1);
error = 1;
}
if ( giveback ) M_free(s2ret,"environment in setup");
return(error);
}
void MMG_freeBucket(pBucket bucket) {
M_free(bucket->head);
M_free(bucket->link);
M_free(bucket);
}
int MMG_mmg3d1(pMesh mesh,pSol sol,int *alert) {
pBucket bucket;
int base,na,nd,nf,nna,nnd,dd,it,maxtou;
int naold,ndold;
//double q,declicw;
//pTetra pt;
//int nw;
if ( abs(mesh->info.imprim) > 3 )
fprintf(stdout," ** SIZE OPTIMIZATION\n");
if ( mesh->info.imprim < 0 ) {
MMG_outqua(mesh,sol);
MMG_prilen(mesh,sol);
}
base = mesh->flag;
*alert = 0;
nna = 0;
nnd = 0;
nf = 0;
it = 0;
maxtou = 100;
MMG_npdtot=0;
MMG_npuisstot=0;
MMG_nprestot=0;
MMG_nvoltot=0;
/* 2. field points */
if ( mesh->info.imprim < -4 ) {
MMG_prilen(mesh,sol);
fprintf(stdout," -- FIELD POINTS\n");
}
/* create filter */
bucket = MMG_newBucket(mesh,M_MAX(mesh->info.bucksiz,BUCKSIZ));
if ( !bucket ) return(0);
naold = ndold = 0;
do {
base = mesh->flag;
nf = 0;
MMG_analar(mesh,sol,bucket,&na,&nd,&nf,alert);
nna += na;
nnd += nd;
if ( *alert ) {
if ( nd < 1000 ) break;
else *alert = 0;
}
/*test avec comme critere de qualite les longueurs*/
/*if( it < 7 && !(it%3) ) {
ns = 0;
declic = 120.; //attention c'est 60*len
if ( !*alert && !mesh->info.noswap ) {
declicw = 180.;
nw += MMG_opttyp(mesh,sol,declicw,&alert);
ns = MMG_cendellong(mesh,sol,declic,-1);
if ( ns < 0 ) {
*alert = 1;
ns = -ns;
}
}
if ( mesh->info.imprim && ns )
fprintf(stdout," %8d SWAPPED\n",ns);
//puts("on arrete la");exit(0);
}
if( it > 5 ) {
//printf("on traite moins 1%% : %d %d %e\n",na,nd,(na+nd)/(double)mesh->np);
//printf("delold/ins %e %e\n",ndold / (double) (na+1),naold / (double) (nd+1));
if( it > 10 ) {
q = ndold / (double) (na+1);
if( q < 1.7 && q > 0.57) {
break;
}
q = naold / (double) (nd+1);
if( q < 1.7 && q > 0.57) {
break;
}
}
q = ndold / (double) (na+1);
if( q < 1.1 && q > 0.9) {
break;
}
q = naold / (double) (nd+1);
if( q < 1.1 && q > 0.9) {
break;
}
}
naold = na;
ndold = nd;
*/
if ( it > 5 ) {
dd = abs(nd-na);
if ( dd < 5 || dd < 0.05*nd ) break;
else if ( it > 12 && nd >= na ) break;
}
if ( na + nd > 0 && mesh->info.imprim )
fprintf(stdout," %8d INSERTED %8d REMOVED %8d FILTERED\n",
na,nd,nf);
}
while ( na+nd > 0 && ++it < maxtou );
if ( nna+nnd && mesh->info.imprim ) {
fprintf(stdout," %7d INSERTED %7d REMOVED %7d FILTERED\n",nna,nnd,nf);
}
if(MMG_npdtot>0) {
fprintf(stdout," REJECTED : %5d\n",MMG_npdtot);
fprintf(stdout," VOL : %6.2f %% %5d \n",
100*(MMG_nvoltot/(float)
MMG_npdtot),MMG_nvoltot);
fprintf(stdout," PUISS : %6.2f %% %5d \n",
100*(MMG_npuisstot/(float) MMG_npdtot),MMG_npuisstot);
fprintf(stdout," PROCHE : %6.2f %% %5d \n",
100*(MMG_nprestot/(float) MMG_npuisstot),MMG_nprestot);
MMG_npdtot=0;
MMG_npuisstot=0;
MMG_nvoltot=0;
}
if ( mesh->info.imprim < 0 ) {
MMG_outqua(mesh,sol);
MMG_prilen(mesh,sol);
}
M_free(bucket->head);
M_free(bucket->link);
M_free(bucket);
return(1);
}
int StudyPattern(WORD *lhs)
{
GETIDENTITY
WORD *fullproto, *pat, *p, *p1, *p2, *pstop, *info, f, nn;
int numfun = 0, numsym = 0, allwilds = 0, i, j, k, nc;
FUN_INFO *finf, *fmin, *f1, *f2, funscratch;
fullproto = lhs + IDHEAD;
/* if ( *lhs == TYPEIF ) fullproto--; */
pat = fullproto + fullproto[1];
info = pat + *pat;
p = pat + 1;
while ( p < info ) {
if ( *p >= FUNCTION ) {
numfun++;
nn = *p - FUNCTION;
if ( nn >= WILDOFFSET ) nn -= WILDOFFSET;
/*
We check here for cases that are not allowed like ?a inside
symmetric functions or tensors.
*/
if ( ( functions[nn].symmetric == SYMMETRIC ) ||
( functions[nn].symmetric == ANTISYMMETRIC ) ) {
p2 = p+p[1]; p1 = p+FUNHEAD;
if ( functions[nn].spec ) {
while ( p1 < p2 ) {
if ( *p1 == FUNNYWILD ) {
MesPrint("&Argument field wildcards are not allowed inside (anti)symmetric functions or tensors");
return(1);
}
p1++;
}
}
else {
while ( p1 < p2 ) {
if ( *p1 == -ARGWILD ) {
MesPrint("&Argument field wildcards are not allowed inside (anti)symmetric functions or tensors");
return(1);
}
NEXTARG(p1);
}
}
}
}
p += p[1];
}
if ( numfun == 0 ) return(0);
if ( ( lhs[2] & SUBMASK ) == SUBALL ) {
p = pat + 1;
while ( p < info ) {
if ( *p == SYMBOL || *p == VECTOR || *p == DOTPRODUCT || *p == INDEX ) {
MesPrint("&id,all can have only functions and/or tensors in the lhs.");
return(1);
}
p += p[1];
}
}
/*
We need now some room for the information about the functions
*/
if ( numfun > AN.numfuninfo ) {
if ( AN.FunInfo ) M_free(AN.FunInfo,"funinfo");
AN.numfuninfo = numfun + 10;
AN.FunInfo = (FUN_INFO *)Malloc1(AN.numfuninfo*sizeof(FUN_INFO),"funinfo");
}
/*
Now collect the information. First the locations.
*/
p = pat + 1; i = 0;
while ( p < info ) {
if ( *p >= FUNCTION ) AN.FunInfo[i++].location = p;
p += p[1];
}
for ( i = 0, finf = AN.FunInfo; i < numfun; i++, finf++ ) {
p = finf->location;
pstop = p + p[1];
f = *p;
if ( f > FUNCTION+WILDOFFSET ) f -= WILDOFFSET;
finf->numargs = finf->numfunnies = finf->numwildcards = 0;
finf->symmet = functions[f-FUNCTION].symmetric;
finf->tensor = functions[f-FUNCTION].spec;
finf->commute = functions[f-FUNCTION].commute;
if ( finf->tensor >= TENSORFUNCTION ) {
p += FUNHEAD;
while ( p < pstop ) {
if ( *p == FUNNYWILD ) {
finf->numfunnies++; p+= 2; continue;
}
else if ( *p < 0 ) {
if ( *p >= AM.OffsetVector + WILDOFFSET && *p < MINSPEC ) {
finf->numwildcards++;
}
}
else {
if ( *p >= AM.OffsetIndex + WILDOFFSET &&
*p <= AM.OffsetIndex + 2*WILDOFFSET ) finf->numwildcards++;
}
finf->numargs++;
p++;
}
}
else {
p += FUNHEAD;
while ( p < pstop ) {
if ( *p > 0 ) { finf->numargs++; p += *p; continue; }
if ( *p <= -FUNCTION ) {
if ( *p <= -FUNCTION - WILDOFFSET ) finf->numwildcards++;
p++;
}
else if ( *p == -SYMBOL ) {
if ( p[1] >= 2*MAXPOWER ) finf->numwildcards++;
p += 2;
}
else if ( *p == -INDEX ) {
if ( p[1] >= AM.OffsetIndex + WILDOFFSET &&
p[1] <= AM.OffsetIndex + 2*WILDOFFSET ) finf->numwildcards++;
p += 2;
}
else if ( *p == -VECTOR || *p == -MINVECTOR ) {
if ( p[1] >= AM.OffsetVector + WILDOFFSET && p[1] < MINSPEC ) {
finf->numwildcards++;
}
p += 2;
}
else if ( *p == -ARGWILD ) {
finf->numfunnies++;
p += 2;
}
else { p += 2; }
finf->numargs++;
}
}
if ( finf->symmet ) {
numsym++;
allwilds += finf->numwildcards + finf->numfunnies;
}
}
if ( numsym == 0 ) return(0);
if ( allwilds == 0 ) return(0);
/*
We have the information in the array AN.FunInfo.
We sort things and then write the sorted pattern.
Of course we may not play with the order of the noncommuting functions.
Of course we have to become even smarter in the future and look during
the sorting which wildcards are asigned when.
But for now this should do.
*/
for ( nc = numfun-1; nc >= 0; nc-- ) { if ( AN.FunInfo[nc].commute ) break; }
finf = AN.FunInfo;
for ( i = nc+2; i < numfun; i++ ) {
fmin = finf; finf++;
if ( ( finf->symmet < fmin->symmet ) || (
( finf->symmet == fmin->symmet ) &&
( ( finf->numwildcards+finf->numfunnies < fmin->numwildcards+fmin->numfunnies )
|| ( ( finf->numwildcards+finf->numfunnies == fmin->numwildcards+fmin->numfunnies )
&& ( finf->numwildcards < fmin->numfunnies ) ) ) ) ) {
funscratch = AN.FunInfo[i];
AN.FunInfo[i] = AN.FunInfo[i-1];
AN.FunInfo[i-1] = funscratch;
for ( j = i-1; j > nc && j > 0; j-- ) {
f1 = AN.FunInfo+j;
f2 = f1-1;
if ( ( f1->symmet < f2->symmet ) || (
( f1->symmet == f2->symmet ) &&
( ( f1->numwildcards+f1->numfunnies < f2->numwildcards+f2->numfunnies )
|| ( ( f1->numwildcards+f1->numfunnies == f2->numwildcards+f2->numfunnies )
&& ( f1->numwildcards < f2->numfunnies ) ) ) ) ) {
funscratch = AN.FunInfo[j];
AN.FunInfo[j] = AN.FunInfo[j-1];
AN.FunInfo[j-1] = funscratch;
}
else break;
}
}
}
/*
Now we rewrite the pattern. First into the space after it and then we
copy it back. Be careful with the non-commutative functions. There the
worst one should decide.
*/
p = pat + 1;
p2 = info;
for ( i = 0; i < numfun; i++ ) {
if ( i == nc ) {
for ( k = 0; k <= nc; k++ ) {
if ( AN.FunInfo[k].commute ) {
p1 = AN.FunInfo[k].location; j = p1[1];
NCOPY(p2,p1,j)
}
}
}
else if ( AN.FunInfo[i].commute == 0 ) {
/* optimisation based on edge lengths */
int MMG_analar(pMesh mesh,pSol sol,pBucket bucket,int *na,int *nd,int *nf,int *alert) {
pTetra pt;
pPoint pa,pb;
List list;
double len,coef,siz,t1,declic,*ma,*mb,*mip,*ca,*cb,mp[6],c[3];
//double *malog,*mblog,mplog[6];
int i,k,lon,nad,ndd,npp,npd,ia,ib,ip,ipa,ipb,nedep,base,ifilt;
int *adja,adj,ret,vois[4],ref,tag,iadr,j,imax;
char tabar,tagedg;
int MMG_ncavity;
/* for Delaunay cavity */
if ( !MMG_zaldy4(&list.hedg,3*LONMAX) ) {
fprintf(stdout," ## MEMORY ALLOCATION PROBLEM.\n");
return(0);
}
MMG_npuiss=0;
MMG_npres=0;
MMG_nvol=0;
MMG_ncavity=0;
MMG_nplen=0;
MMG_npref=0;
MMG_nlen = 0;
MMG_ncal = 0;
MMG_ntopo = 0;
MMG_nex = 0;
MMG_bouffe = 0;
npp = 0;
nad = 0;
ndd = 0;
npd = 0;
coef = QDEGRAD;//1.;//QDEGRAD;
ifilt = 0;
nedep = mesh->ne;
base = ++mesh->flag;
declic = 1.5/ALPHAD;// 60.*LLONG;
for (k=1; k<=nedep; k++) {
pt = &mesh->tetra[k];
if ( !pt->v[0] ) continue;
// else if ( pt->flag != base-1 ) continue;
if ( pt->qual < declic ) continue;
pt->flag = base-2;
/* mark internal edges */
tabar = 0;
tagedg = 0;
iadr = 4*(k-1) + 1;
adja = &mesh->adja[iadr];
vois[0] = adja[0] >> 2;
vois[1] = adja[1] >> 2;
vois[2] = adja[2] >> 2;
vois[3] = adja[3] >> 2;
for (i=0; i<4; i++) {
adj = vois[i];
ref = mesh->tetra[adj].ref;
tag = mesh->tetra[adj].flag;
if ( !adj || pt->ref != ref ) {
tabar |= 1 << MMG_iarf[i][0];
tabar |= 1 << MMG_iarf[i][1];
tabar |= 1 << MMG_iarf[i][2];
}
if ( adj && tag == base - 2 ) {
tagedg |= 1 << MMG_iarf[i][0];
tagedg |= 1 << MMG_iarf[i][1];
tagedg |= 1 << MMG_iarf[i][2];
}
}
if ( (tabar == ALL_BDRY) || (tagedg == ALL_BDRY) ) continue;
//imax = ((int) pt->qual)%6;
imax = 0;
for (j=imax; j<imax+6; j++) {
i = j;
if ( (tabar & 1<<i) || (tagedg & 1<<i) ) continue;
/* edge length */
ia = MMG_iare[i][0];
ib = MMG_iare[i][1];
ipa = pt->v[ia];
ipb = pt->v[ib];
ca = &mesh->point[ipa].c[0];
cb = &mesh->point[ipb].c[0];
iadr = (ipa-1)*sol->offset + 1;
ma = &sol->met[iadr];
iadr = (ipb-1)*sol->offset + 1;
mb = &sol->met[iadr];
len = MMG_length(ca,cb,ma,mb);
if ( len > LLONG && *alert != 1 ) {
npp++;
siz=0.5;
/* metric interpolation */
if ( sol->offset==1 ) {
if(!MMG_interp(ma,mb,mp,siz) ) continue;
}
else {
iadr = (ipa-1)*sol->offset + 1;
//malog = &sol->metold[iadr];
iadr = (ipb-1)*sol->offset + 1;
//mblog = &sol->metold[iadr];
//if ( !MMG_interplog(malog,mblog,mp,mplog,siz) ) continue;
if ( !MMG_interp_ani(ma,mb,mp,siz) ) continue;
}
t1 = 1.0 - siz;
c[0] = t1*ca[0] + siz*cb[0];
c[1] = t1*ca[1] + siz*cb[1];
c[2] = t1*ca[2] + siz*cb[2];
//printf("siz %e new len %e - %e (%e) %d %d\n", siz,MMG_length(ca,c,ma,mb),MMG_length(cb,c,ma,mb),len,(int)(len+0.5),nbp);
ip = MMG_newPt(mesh,c);
if ( ip < 1 ) {
*alert = 1;
break;
}
else {
iadr = (ip-1)*sol->offset + 1;
//mipold = &sol->metold[iadr];
//memcpy(mipold,mplog,sol->offset*sizeof(double));
mip = &sol->met[iadr];
memcpy(mip,mp,sol->offset*sizeof(double));
/* bucket filter */
if (!MMG_buckin(mesh,sol,bucket,ip) ) {
MMG_delPt(mesh,ip);
ifilt++;
continue;
}
/* Delaunay kernel */
lon = MMG_coquil(mesh,k,i,&list);
lon = MMG_cavity(mesh,sol,k,ip,&list,lon);
if ( lon < 1 ) {
MMG_delPt(mesh,ip);
npd++;
if ( lon == -1 ) {
MMG_ncavity++;
//printf("cavity pete\n");
*alert = 2;
} else if ( lon < 0 ) {
*alert = 1;
break;
}
else {
continue;
}
}
else {
ret = MMG_delone(mesh,sol,ip,&list,lon);
if ( ret > 0 ) {
MMG_addBucket(mesh,bucket,ip);
nad++;
*alert = 0;
}
else if ( ret == 0 ) {
MMG_delPt(mesh,ip);
npd++;
*alert = 1;
break;
}
else {
MMG_delPt(mesh,ip);
npd++;
MMG_bouffe++;
}
}
}
break;
}
else if ( len < LSHORT ) {
npp++;
pa = &mesh->point[ipa];
pb = &mesh->point[ipb];
if ( MMG_colpoi(mesh,sol,k,ia,ib,coef) ) {
MMG_delBucket(mesh,bucket,ipb);
MMG_delPt(mesh,ipb);
ndd++;
break;
}
else if ( MMG_colpoi(mesh,sol,k,ib,ia,coef) ) {
MMG_delBucket(mesh,bucket,ipa);
MMG_delPt(mesh,ipa);
ndd++;
break;
}
}
}
if ( *alert == 1 ) break;
}
*na = nad;
*nd = ndd;
*nf += ifilt;
if ( abs(mesh->info.imprim) > 5 || mesh->info.ddebug ) {
printf("analyzed %d \n",npp);
printf("rejected colpoi : cal %d , len %d , topo %d , ex %d\n",MMG_ncal,MMG_nlen,MMG_ntopo,MMG_nex);
MMG_npdtot+=npd;
MMG_nvoltot+=MMG_nvol;
MMG_npuisstot+=MMG_npuiss;
MMG_nprestot+=MMG_npres;
if (npd>0) {
printf("rejected %d : cavity %d vol %d , puiss %d , pres %d bouffe %d\n",npd,MMG_ncavity,MMG_nvol,MMG_npuiss,MMG_npres,MMG_bouffe);
}
}
if ( *alert == 1 ) {
fprintf(stdout," ## UNABLE TO CREATE NEW ELEMENT %d , %d\n",
mesh->np,mesh->ne);
} else *alert = 0;
M_free(list.hedg.item);
return(1);
}
int MMG_opt2peau(pMesh mesh,pSol sol,pQueue queue,int k,double declic) {
pTetra pt,pt1;
pPoint pa,pb,pc,pd;
List list;
double abx,aby,abz,acx,acy,acz,adx,ady,adz,v1,v2,v3,vol;
double bcx,bcy,bcz,bdx,bdy,bdz,cdx,cdy,cdz,h[6];
double crit;
double s[4],dd,rapmin,rapmax;
int i,ia,ib,ic,id,iarmax,iarmin;
int lon,l,iel,ier;
ier = 0;
pt = &mesh->tetra[k];
if ( !pt->v[0] ) return(-1);
ia = pt->v[0];
ib = pt->v[1];
ic = pt->v[2];
id = pt->v[3];
pa = &mesh->point[ia];
pb = &mesh->point[ib];
pc = &mesh->point[ic];
pd = &mesh->point[id];
/* volume */
abx = pb->c[0] - pa->c[0];
aby = pb->c[1] - pa->c[1];
abz = pb->c[2] - pa->c[2];
acx = pc->c[0] - pa->c[0];
acy = pc->c[1] - pa->c[1];
acz = pc->c[2] - pa->c[2];
adx = pd->c[0] - pa->c[0];
ady = pd->c[1] - pa->c[1];
adz = pd->c[2] - pa->c[2];
v1 = acy*adz - acz*ady;
v2 = acz*adx - acx*adz;
v3 = acx*ady - acy*adx;
vol = abx * v1 + aby * v2 + abz * v3;
/* max edge */
h[0] = abx*abx + aby*aby + abz*abz;
h[1] = acx*acx + acy*acy + acz*acz;
h[2] = adx*adx + ady*ady + adz*adz;
bcx = pc->c[0] - pb->c[0];
bcy = pc->c[1] - pb->c[1];
bcz = pc->c[2] - pb->c[2];
bdx = pd->c[0] - pb->c[0];
bdy = pd->c[1] - pb->c[1];
bdz = pd->c[2] - pb->c[2];
cdx = pd->c[0] - pc->c[0];
cdy = pd->c[1] - pc->c[1];
cdz = pd->c[2] - pc->c[2];
h[3] = bcx*bcx + bcy*bcy + bcz*bcz;
h[4] = bdx*bdx + bdy*bdy + bdz*bdz;
h[5] = cdx*cdx + cdy*cdy + cdz*cdz;
/* face areas */
dd = cdy*bdz - cdz*bdy;
s[0] = dd * dd;
dd = cdz*bdx - cdx*bdz;
s[0] = s[0] + dd * dd;
dd = cdx*bdy - cdy*bdx;
s[0] = s[0] + dd * dd;
s[0] = sqrt(s[0]);
s[1] = sqrt(v1*v1 + v2*v2 + v3*v3);
dd = bdy*adz - bdz*ady;
s[2] = dd * dd;
dd = bdz*adx - bdx*adz;
s[2] = s[2] + dd * dd;
dd = bdx*ady - bdy*adx;
s[2] = s[2] + dd * dd;
s[2] = sqrt(s[2]);
dd = aby*acz - abz*acy;
s[3] = dd * dd;
dd = abz*acx - abx*acz;
s[3] = s[3] + dd * dd;
dd = abx*acy - aby*acx;
s[3] = s[3] + dd * dd;
s[3] = sqrt(s[3]);
/* classification */
rapmin = h[0];
rapmax = h[0];
iarmin = 0;
iarmax = 0;
for (i=1; i<6; i++) {
if ( h[i] < rapmin ) {
rapmin = h[i];
iarmin = i;
}
else if ( h[i] > rapmax ) {
rapmax = h[i];
iarmax = i;
}
}
rapmin = sqrt(rapmin);
rapmax = sqrt(rapmax);
if(mesh->info.imprim < -9) printf("edge : %d %d\n",pt->v[MMG_iare[iarmax][0]],pt->v[MMG_iare[iarmax][1]]);
/*split edge*/
lon = MMG_coquil(mesh,k,iarmax,&list);
if(mesh->info.imprim < 0) {
//printf("lon %d\n",lon);
//if(!lon) printf("colle peau, edge peau\n");
}
if(!lon) {
for(i=0 ; i<6 ; i++) {
lon = MMG_coquil(mesh,k,i,&list);
if ( lon > 2 ) {
if ( !MMG_zaldy4(&list.hedg,3*LONMAX) ) {
fprintf(stdout," ## MEMORY ALLOCATION PROBLEM MMG_optbdry.\n");
MMG_kiufree(queue);
return(0);
}
crit = pt->qual;
for (l=2; l<=lon; l++) {
iel = list.tetra[l] / 6;
pt1 = &mesh->tetra[iel];
if ( pt1->qual > crit ) crit = pt1->qual;
}
crit *= OCRIT;
//crit = min(1000/ALPHAD,crit*1.3);
ier = MMG_swapar(mesh,sol,queue,&list,lon,crit,1e9);
if(ier) {/*printf("on a reussi a l'enlever par MMG_swap\n");*/break;}
if ( ier == 0 && !mesh->info.noinsert) {
crit = M_MIN(100./ALPHAD,crit*1.5);
ier = MMG_spledg(mesh,sol,queue,&list,lon,/*1.8**/crit,declic);
}
if(ier) {/*printf("on a reussi a l'enlever par split \n");*/break;}
M_free(list.hedg.item);
}
}
//M_free(list.hedg.item);
if(ier) {
M_free(list.hedg.item);
return(1);
}
else return(0);
} else {
if ( !MMG_zaldy4(&list.hedg,3*LONMAX) ) {
fprintf(stdout," ## MEMORY ALLOCATION PROBLEM MMG_optbdry.\n");
MMG_kiufree(queue);
return(0);
}
if ( lon > 2 ) {
crit = pt->qual;
for (l=2; l<=lon; l++) {
iel = list.tetra[l] / 6;
pt1 = &mesh->tetra[iel];
if ( pt1->qual > crit ) crit = pt1->qual;
}
crit *= OCRIT;
// crit = min(1000/ALPHAD,crit*1.3);
ier = MMG_swapar(mesh,sol,queue,&list,lon,crit,1e9);
if ( ier == 0 && !mesh->info.noinsert) {
crit = M_MIN(100./ALPHAD,crit*1.5);
ier = MMG_spledg(mesh,sol,queue,&list,lon,/*1.8**/crit,declic);
}
}
M_free(list.hedg.item);
if(ier) return(1);
else return(0);
}
return(1);
}
/* Internal function : biPartBoxCompute
* it computes a new numbering of graph vertices, using a bipartitioning.
*
* - graf : the input graph
* - vertNbr : the number of vertices
* - boxVertNbr : the number of vertices of each box
* - permVrtTab : the new numbering
*
* returning 0 if OK, 1 else
*/
int biPartBoxCompute(SCOTCH_Graph graf, int vertNbr, int boxVertNbr, SCOTCH_Num *permVrtTab) {
int boxNbr, vertIdx, boxIdx;
SCOTCH_Num tmp, tmp2, *partTab, *partNumTab, *partPrmTab;
SCOTCH_Strat strat ;
/* Computing the number of boxes */
boxNbr = vertNbr / boxVertNbr;
if (boxNbr * boxVertNbr != vertNbr) {
boxNbr = boxNbr + 1;
}
/* Initializing SCOTCH functions */
CHECK_SCOTCH(SCOTCH_stratInit(&strat), "scotch_stratInit", 0) ;
CHECK_SCOTCH(SCOTCH_stratGraphMap(&strat, "r{job=t,map=t,poli=S,sep=m{type=h,vert=80,low=h{pass=10}f{bal=0.005,move=0},asc=b{bnd=f{bal=0.05,move=0},org=f{bal=0.05,move=0}}}|m{type=h,vert=80,low=h{pass=10}f{bal=0.005,move=0},asc=b{bnd=f{bal=0.05,move=0},org=f{bal=0.05,move=0}}}}"), "scotch_stratGraphMap", 0) ;
partTab = (SCOTCH_Num *)M_calloc(vertNbr, sizeof(SCOTCH_Num), "boxCompute");
/* Partionning the graph */
CHECK_SCOTCH(SCOTCH_graphPart(&graf, boxNbr, &strat, partTab), "scotch_graphPart", 0);
partNumTab = (SCOTCH_Num *)M_calloc(boxNbr, sizeof(SCOTCH_Num), "boxCompute");
if (!memset(partNumTab, 0, boxNbr*sizeof(SCOTCH_Num))) {
perror("memset");
return 0;
}
/* Computing the number of elements of each box */
for( vertIdx = 0 ; vertIdx< vertNbr ;vertIdx++)
partNumTab[partTab[vertIdx]] += 1;
/* partition permutation tabular */
partPrmTab = (SCOTCH_Num *)M_calloc(vertNbr + 1, sizeof(SCOTCH_Num), "boxCompute");
/* Copying the previous tabular in order to have the index of the first
* element of each box
* */
tmp = partNumTab[0];
partNumTab[0] = 0;
for(boxIdx = 1; boxIdx < boxNbr ; boxIdx++) {
tmp2 = partNumTab[boxIdx];
partNumTab[boxIdx] = partNumTab[boxIdx-1] + tmp;
tmp = tmp2;
}
/* partPrmTab is built such as each vertex belongs to his box */
for( vertIdx = 0;vertIdx< vertNbr;vertIdx++)
partPrmTab[partNumTab[partTab[vertIdx]]++] = vertIdx;
/* Infering the new numbering */
for (vertIdx = 0; vertIdx < vertNbr ; vertIdx++)
permVrtTab[partPrmTab[vertIdx] + 1] = vertIdx + 1;
M_free(partTab);
M_free(partNumTab);
M_free(partPrmTab);
SCOTCH_stratExit(&strat) ;
return 0;
}
/* Function : renumbering
* it modifies the numbering of each node to prevent from cache missing.
*
* - boxVertNbr : number of vertices by box
* - mesh : the input mesh which is modified
*
* returning 0 if OK, 1 else
*/
int renumbering(int boxVertNbr, MMG_pMesh mesh, MMG_pSol sol) {
MMG_pPoint ppt;
MMG_pPoint points;
MMG_pTria ptri, trias;
MMG_pTetra ptet, tetras;
SCOTCH_Num edgeNbr;
SCOTCH_Num *vertTab, *vendTab, *edgeTab, *permVrtTab;
SCOTCH_Graph graf ;
int vertNbr, nodeGlbIdx, triaIdx, tetraIdx, ballTetIdx;
int i, j, k, addrNew, addrOld;
int edgeSiz;
int *vertOldTab, *permNodTab, ntreal, nereal, npreal;
int *adja,iadr;
double *metNew;
/* Computing the number of vertices and a contiguous tabular of vertices */
vertNbr = 0;
vertOldTab = (int *)M_calloc(mesh->ne + 1, sizeof(int), "renumbering");
if (!memset(vertOldTab, 0, sizeof(int)*(mesh->ne+1))) {
perror("memset");
return 1;
}
for(tetraIdx = 1 ; tetraIdx < mesh->ne + 1 ; tetraIdx++) {
/* Testing if the tetra exists */
if (!mesh->tetra[tetraIdx].v[0]) continue;
vertOldTab[tetraIdx] = vertNbr+1;
vertNbr++;
}
/* Allocating memory to compute adjacency lists */
vertTab = (SCOTCH_Num *)M_calloc(vertNbr + 1, sizeof(SCOTCH_Num), "renumbering");
if (!memset(vertTab, ~0, sizeof(SCOTCH_Num)*(vertNbr + 1))) {
perror("memset");
return 1;
}
vendTab = (SCOTCH_Num *)M_calloc(vertNbr + 1, sizeof(SCOTCH_Num), "renumbering");
edgeNbr = 1;
edgeSiz = vertNbr*2;
edgeTab = (SCOTCH_Num *)M_calloc(edgeSiz, sizeof(SCOTCH_Num), "renumbering");
/* Computing the adjacency list for each vertex */
for(tetraIdx = 1 ; tetraIdx < mesh->ne + 1 ; tetraIdx++) {
/* Testing if the tetra exists */
if (!mesh->tetra[tetraIdx].v[0]) continue;
iadr = 4*(tetraIdx-1) + 1;
adja = &mesh->adja[iadr];
for (i=0; i<4; i++) {
ballTetIdx = adja[i] >> 2;
if (!ballTetIdx) continue;
/* Testing if one neighbour of tetraIdx has already been added */
if (vertTab[vertOldTab[tetraIdx]] < 0)
vertTab[vertOldTab[tetraIdx]] = edgeNbr;
vendTab[vertOldTab[tetraIdx]] = edgeNbr+1;
/* Testing if edgeTab memory is enough */
if (edgeNbr >= edgeSiz) {
edgeSiz += EDGEGAP;
edgeTab = (SCOTCH_Num *)M_realloc(edgeTab, edgeSiz * sizeof(SCOTCH_Num), "renumbering");
}
edgeTab[edgeNbr++] = vertOldTab[ballTetIdx];
}
}
edgeNbr--;
/* Building the graph by calling Scotch functions */
SCOTCH_graphInit(&graf) ;
CHECK_SCOTCH(SCOTCH_graphBuild(&graf, (SCOTCH_Num) 1, vertNbr, vertTab+1, vendTab+1, NULL, NULL, edgeNbr, edgeTab+1, NULL), "scotch_graphbuild", 0) ;
CHECK_SCOTCH(SCOTCH_graphCheck(&graf), "scotch_graphcheck", 0) ;
permVrtTab = (SCOTCH_Num *)M_calloc(vertNbr + 1, sizeof(SCOTCH_Num), "renumbering");
CHECK_SCOTCH(kPartBoxCompute(graf, vertNbr, boxVertNbr, permVrtTab), "boxCompute", 0);
SCOTCH_graphExit(&graf) ;
M_free(vertTab);
M_free(vendTab);
M_free(edgeTab);
permNodTab = (int *)M_calloc(mesh->np + 1, sizeof(int), "renumbering");
/* Computing the new point list and modifying the sol structures*/
tetras = (MMG_pTetra)M_calloc(mesh->nemax+1,sizeof(MMG_Tetra),"renumbering");
points = (MMG_pPoint)M_calloc(mesh->npmax+1,sizeof(MMG_Point),"renumbering");
metNew = (double*)M_calloc(sol->npmax+1,sol->offset*sizeof(double),"renumbering");
nereal = 0;
npreal = 1;
for(tetraIdx = 1 ; tetraIdx < mesh->ne + 1 ; tetraIdx++) {
ptet = &mesh->tetra[tetraIdx];
/* Testing if the tetra exists */
if (!ptet->v[0]) continue;
/* Building the new point list */
tetras[permVrtTab[vertOldTab[tetraIdx]]] = *ptet;
nereal++;
for(j = 0 ; j <= 3 ; j++) {
nodeGlbIdx = mesh->tetra[tetraIdx].v[j];
if (permNodTab[nodeGlbIdx]) continue;
ppt = &mesh->point[nodeGlbIdx];
if (!(ppt->tag & M_UNUSED)) {
/* Building the new point list */
permNodTab[nodeGlbIdx] = npreal++;
points[permNodTab[nodeGlbIdx]] = *ppt;
/* Building the new sol met */
addrOld = (nodeGlbIdx-1)*sol->offset + 1;
addrNew = (permNodTab[nodeGlbIdx]-1)*sol->offset + 1;
memcpy(&metNew[addrNew], &sol->met[addrOld], sol->offset*sizeof(double));
}
}
}
M_free(mesh->tetra);
mesh->tetra = tetras;
mesh->ne = nereal;
M_free(mesh->point);
mesh->point = points;
mesh->np = npreal - 1;
M_free(sol->met);
sol->met = metNew;
trias = (MMG_pTria)M_calloc(mesh->ntmax+1,sizeof(MMG_Tria),"renumbering");
ntreal = 1;
for(triaIdx = 1 ; triaIdx < mesh->nt + 1 ; triaIdx++) {
ptri = &mesh->tria[triaIdx];
/* Testing if the tetra exists */
if (!ptri->v[0]) continue;
/* Building the new point list */
trias[ntreal] = *ptri;
ntreal++;
}
M_free(mesh->tria);
mesh->tria = trias;
mesh->nt = ntreal - 1;
mesh->npnil = mesh->np + 1;
mesh->nenil = mesh->ne + 1;
for (k=mesh->npnil; k<mesh->npmax-1; k++)
mesh->point[k].tmp = k+1;
for (k=mesh->nenil; k<mesh->nemax-1; k++)
mesh->tetra[k].v[3] = k+1;
if ( mesh->nt ) {
mesh->ntnil = mesh->nt + 1;
for (k=mesh->ntnil; k<mesh->ntmax-1; k++)
mesh->tria[k].v[2] = k+1;
}
/* Modifying the numbering of the nodes of each tetra */
for(tetraIdx = 1 ; tetraIdx < mesh->ne + 1 ; tetraIdx++) {
if (!mesh->tetra[tetraIdx].v[0]) continue;
for(j = 0 ; j <= 3 ; j++) {
mesh->tetra[tetraIdx].v[j] = permNodTab[mesh->tetra[tetraIdx].v[j]];
}
}
/* Modifying the numbering of the nodes of each triangle */
for(triaIdx = 1 ; triaIdx < mesh->nt + 1 ; triaIdx++) {
if (!mesh->tria[triaIdx].v[0]) continue;
for(j = 0 ; j <= 2 ; j++) {
mesh->tria[triaIdx].v[j] = permNodTab[mesh->tria[triaIdx].v[j]];
}
}
M_free(permVrtTab);
return 1;
}
/* Internal function : kPartBoxCompute
* it computes a new numbering of graph vertices, using a k-partitioning.
* Assuming that baseval of the graph is 1
*
* - graf : the input graph
* - vertNbr : the number of vertices
* - boxVertNbr : the number of vertices of each box
* - permVrtTab : the new numbering
*
* returning 0 if OK, 1 else
*/
int kPartBoxCompute(SCOTCH_Graph graf, int vertNbr, int boxVertNbr, SCOTCH_Num *permVrtTab) {
int boxNbr, vertIdx;
SCOTCH_Num logMaxVal, SupMaxVal, InfMaxVal, maxVal;
char s[200];
SCOTCH_Num *sortPartTb;
SCOTCH_Strat strat ;
SCOTCH_Arch arch;
/* Computing the number of boxes */
boxNbr = vertNbr / boxVertNbr;
if (boxNbr * boxVertNbr != vertNbr) {
boxNbr = boxNbr + 1;
}
/* Initializing SCOTCH functions */
CHECK_SCOTCH(SCOTCH_stratInit(&strat), "scotch_stratInit", 0) ;
CHECK_SCOTCH(SCOTCH_archVcmplt(&arch), "scotch_archVcmplt", 0) ;
sprintf(s, "m{vert=%d,low=r{job=t,map=t,poli=S,sep=m{type=h,vert=80,low=h{pass=10}f{bal=0.0005,move=80},asc=f{bal=0.005,move=80}}}}", vertNbr / boxVertNbr);
CHECK_SCOTCH(SCOTCH_stratGraphMap(&strat, s), "scotch_stratGraphMap", 0) ;
sortPartTb= (SCOTCH_Num *)M_calloc(2*vertNbr, sizeof(SCOTCH_Num), "boxCompute");
/* Partionning the graph */
CHECK_SCOTCH(SCOTCH_graphMap(&graf, &arch, &strat, sortPartTb), "scotch_graphMap", 0);
// Looking for the max value in sortPartTb and computing sortPartTb as
// followed :
// - sortPartTb[2i] is the box value
// - sortPartTb[2i+1] is the vertex number
maxVal = sortPartTb[0];
for (vertIdx = vertNbr - 1 ; vertIdx >= 0 ; vertIdx--) {
sortPartTb[2*vertIdx] = sortPartTb[vertIdx];
sortPartTb[2*vertIdx+1] = vertIdx + 1;
if (sortPartTb[vertIdx] > maxVal)
maxVal = sortPartTb[vertIdx];
}
// Determining the log of MaxVal
logMaxVal = 0;
while ( maxVal > 0) {
logMaxVal++;
maxVal >>= 1;
}
// Infering the interval in which box values will be
InfMaxVal = logMaxVal << logMaxVal;
SupMaxVal = (logMaxVal << (logMaxVal + 1)) - 1;
// Increasing box values until they are in the previous interval
for (vertIdx = 0 ; vertIdx < vertNbr ; vertIdx++) {
while (!(sortPartTb[2*vertIdx] >= InfMaxVal && sortPartTb[2*vertIdx] <= SupMaxVal)) {
sortPartTb[2*vertIdx] <<= 1;
}
}
// Sorting the tabular, which contains box values and vertex numbers
_SCOTCHintSort2asc1(sortPartTb, vertNbr);
/* Infering the new numbering */
for (vertIdx = 0; vertIdx < vertNbr ; vertIdx++) {
permVrtTab[sortPartTb[2*vertIdx + 1]] = vertIdx + 1;
}
SCOTCH_stratExit(&strat) ;
SCOTCH_archExit(&arch) ;
M_free(sortPartTb);
return 0;
}
/*
#] Includes :
#[ FactorIn :
This routine tests for a factor in a dollar expression.
Note that unlike with regular active or hidden expressions we cannot
add memory as easily as dollars are rather volatile.
*/
int FactorIn(PHEAD WORD *term, WORD level)
{
GETBIDENTITY
WORD *t, *tstop, *m, *mm, *oldwork, *mstop, *n1, *n2, *n3, *n4, *n1stop, *n2stop;
WORD *r1, *r2, *r3, *r4, j, k, kGCD, kGCD2, kLCM, jGCD, kkLCM, jLCM, size;
UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc;
int fromwhere = 0, i;
DOLLARS d;
t = term; GETSTOP(t,tstop); t++;
while ( ( t < tstop ) && ( *t != FACTORIN || ( ( *t == FACTORIN )
&& ( t[FUNHEAD] != -DOLLAREXPRESSION || t[1] != FUNHEAD+2 ) ) ) ) t += t[1];
if ( t >= tstop ) {
MLOCK(ErrorMessageLock);
MesPrint("Internal error. Could not find proper factorin_ function.");
MUNLOCK(ErrorMessageLock);
return(-1);
}
oldwork = AT.WorkPointer;
d = Dollars + t[FUNHEAD+1];
#ifdef WITHPTHREADS
{
int nummodopt, dtype = -1;
if ( AS.MultiThreaded ) {
for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
if ( t[FUNHEAD+1] == ModOptdollars[nummodopt].number ) break;
}
if ( nummodopt < NumModOptdollars ) {
dtype = ModOptdollars[nummodopt].type;
if ( dtype == MODLOCAL ) {
d = ModOptdollars[nummodopt].dstruct+AT.identity;
}
}
}
}
#endif
if ( d->type == DOLTERMS ) {
fromwhere = 1;
}
else if ( ( d = DolToTerms(BHEAD t[FUNHEAD+1]) ) == 0 ) {
/*
The variable cannot convert to an expression
We replace the function by 1.
*/
m = oldwork; n1 = term;
while ( n1 < t ) *m++ = *n1++;
n1 = t + t[1]; tstop = term + *term;
while ( n1 < tstop ) *m++ = *n1++;
*oldwork = m - oldwork;
AT.WorkPointer = m;
if ( Generator(BHEAD oldwork,level) ) return(-1);
AT.WorkPointer = oldwork;
return(0);
}
if ( d->where[0] == 0 ) {
if ( fromwhere == 0 ) {
if ( d->factors ) M_free(d->factors,"Dollar factors");
M_free(d,"Dollar in FactorIn_");
}
return(0);
}
/*
Now we have an expression in d->where. Find the symbolic factor that
divides the expression and the numerical factor that makes all
coefficients integer.
For the symbolic factor we make a copy of the first term, and then
go through all terms, scratching in the copy the objects that do not
occur in the terms.
*/
m = oldwork;
mm = d->where;
k = *mm - ABS((mm[*mm-1]));
for ( j = 0; j < k; j++ ) *m++ = *mm++;
mstop = m;
*oldwork = k;
/*
The copy is in place. Now search through the terms. Start at the second term
*/
mm = d->where + d->where[0];
while ( *mm ) {
m = oldwork+1;
r2 = mm+*mm;
r2 -= ABS(r2[-1]);
r1 = mm+1;
while ( m < mstop ) {
while ( r1 < r2 ) {
if ( *r1 != *m ) {
r1 += r1[1]; continue;
}
/*
Now the various cases
#[ SYMBOL :
*/
if ( *m == SYMBOL ) {
n1 = m+2; n1stop = m+m[1];
n2stop = r1+r1[1];
while ( n1 < n1stop ) {
n2 = r1+2;
while ( n2 < n2stop ) {
if ( *n1 != *n2 ) { n2 += 2; continue; }
if ( n1[1] > 0 ) {
if ( n2[1] < 0 ) { n2 += 2; continue; }
if ( n2[1] < n1[1] ) n1[1] = n2[1];
}
else {
if ( n2[1] > 0 ) { n2 += 2; continue; }
if ( n2[1] > n1[1] ) n1[1] = n2[1];
}
break;
}
if ( n2 >= n2stop ) { /* scratch symbol */
if ( m[1] == 4 ) goto scratch;
m[1] -= 2;
n3 = n1; n4 = n1+2;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 2; n1stop -= 2;
continue;
}
n1 += 2;
}
break;
}
/*
#] SYMBOL :
#[ DOTPRODUCT :
*/
else if ( *m == DOTPRODUCT ) {
n1 = m+2; n1stop = m+m[1];
n2stop = r1+r1[1];
while ( n1 < n1stop ) {
n2 = r1+2;
while ( n2 < n2stop ) {
if ( *n1 != *n2 || n1[1] != n2[1] ) { n2 += 3; continue; }
if ( n1[2] > 0 ) {
if ( n2[2] < 0 ) { n2 += 3; continue; }
if ( n2[2] < n1[2] ) n1[2] = n2[2];
}
else {
if ( n2[2] > 0 ) { n2 += 3; continue; }
if ( n2[2] > n1[2] ) n1[2] = n2[2];
}
break;
}
if ( n2 >= n2stop ) { /* scratch symbol */
if ( m[1] == 5 ) goto scratch;
m[1] -= 3;
n3 = n1; n4 = n1+3;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 3; n1stop -= 3;
continue;
}
n1 += 3;
}
break;
}
/*
#] DOTPRODUCT :
#[ VECTOR :
*/
else if ( *m == VECTOR ) {
/*
Here we have to be careful if there is more than
one of the same
*/
n1 = m+2; n1stop = m+m[1];
n2 = r1+2;n2stop = r1+r1[1];
while ( n1 < n1stop ) {
while ( n2 < n2stop ) {
if ( *n1 == *n2 && n1[1] == n2[1] ) {
n2 += 2; goto nextn1;
}
n2 += 2;
}
if ( n2 >= n2stop ) { /* scratch symbol */
if ( m[1] == 4 ) goto scratch;
m[1] -= 2;
n3 = n1; n4 = n1+2;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 2; n1stop -= 2;
continue;
}
n2 = r1+2;
nextn1: n1 += 2;
}
break;
}
/*
#] VECTOR :
#[ REMAINDER :
*/
else {
/*
Again: watch for multiple occurrences of the same object
*/
if ( m[1] != r1[1] ) { r1 += r1[1]; continue; }
for ( j = 2; j < m[1]; j++ ) {
if ( m[j] != r1[j] ) break;
}
if ( j < m[1] ) { r1 += r1[1]; continue; }
r1 += r1[1]; /* to restart at the next potential match */
goto nextm; /* match */
}
/*
#] REMAINDER :
*/
}
if ( r1 >= r2 ) { /* no factor! */
scratch:;
r3 = m + m[1]; r4 = m;
while ( r3 < mstop ) *r4++ = *r3++;
*oldwork = r4 - oldwork;
if ( *oldwork == 1 ) goto nofactor;
mstop = r4;
r1 = mm + 1;
continue;
}
r1 = mm + 1;
nextm: m += m[1];
}
mm = mm + *mm;
}
nofactor:;
/*
For the coefficient we have to determine the LCM of the denominators
and the GCD of the numerators.
*/
GCDbuffer = NumberMalloc("FactorIn"); GCDbuffer2 = NumberMalloc("FactorIn");
LCMbuffer = NumberMalloc("FactorIn"); LCMb = NumberMalloc("FactorIn"); LCMc = NumberMalloc("FactorIn");
r1 = d->where;
/*
First take the first term to load up the LCM and the GCD
*/
r2 = r1 + *r1;
j = r2[-1];
r3 = r2 - ABS(j);
k = REDLENG(j);
if ( k < 0 ) k = -k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD];
k = REDLENG(j);
if ( k < 0 ) k = -k;
r3 += k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM];
r1 = r2;
/*
Now go through the rest of the terms in this dollar buffer.
*/
while ( *r1 ) {
r2 = r1 + *r1;
j = r2[-1];
r3 = r2 - ABS(j);
k = REDLENG(j);
if ( k < 0 ) k = -k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) {
/*
GCD is already 1
*/
}
else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) {
if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) {
goto onerror;
}
kGCD = kGCD2;
for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i];
}
else {
kGCD = 1; GCDbuffer[0] = 1;
}
k = REDLENG(j);
if ( k < 0 ) k = -k;
r3 += k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) {
for ( kLCM = 0; kLCM < k; kLCM++ )
LCMbuffer[kLCM] = r3[kLCM];
}
else if ( ( k != 1 ) || ( r3[0] != 1 ) ) {
if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) {
goto onerror;
}
DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM);
MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM);
for ( kLCM = 0; kLCM < jLCM; kLCM++ )
LCMbuffer[kLCM] = LCMc[kLCM];
}
else {} /* LCM doesn't change */
r1 = r2;
}
/*
Now put the factor together: GCD/LCM
*/
r3 = (WORD *)(GCDbuffer);
if ( kGCD == kLCM ) {
for ( jGCD = 0; jGCD < kGCD; jGCD++ )
r3[jGCD+kGCD] = LCMbuffer[jGCD];
k = kGCD;
}
else if ( kGCD > kLCM ) {
for ( jGCD = 0; jGCD < kLCM; jGCD++ )
r3[jGCD+kGCD] = LCMbuffer[jGCD];
for ( jGCD = kLCM; jGCD < kGCD; jGCD++ )
r3[jGCD+kGCD] = 0;
k = kGCD;
}
else {
for ( jGCD = kGCD; jGCD < kLCM; jGCD++ )
r3[jGCD] = 0;
for ( jGCD = 0; jGCD < kLCM; jGCD++ )
r3[jGCD+kLCM] = LCMbuffer[jGCD];
k = kLCM;
}
j = 2*k+1;
mm = m = oldwork + oldwork[0];
/*
Now compose the new term
*/
n1 = term;
while ( n1 < t ) *m++ = *n1++;
n1 += n1[1];
n2 = oldwork+1;
while ( n2 < mm ) *m++ = *n2++;
while ( n1 < tstop ) *m++ = *n1++;
/*
And the coefficient
*/
size = term[*term-1];
size = REDLENG(size);
if ( MulRat(BHEAD (UWORD *)tstop,size,(UWORD *)r3,k,
(UWORD *)m,&size) ) goto onerror;
size = INCLENG(size);
k = size < 0 ? -size: size;
m[k-1] = size;
m += k;
*mm = (WORD)(m - mm);
AT.WorkPointer = m;
if ( Generator(BHEAD mm,level) ) goto onerror;
AT.WorkPointer = oldwork;
if ( fromwhere == 0 ) {
if ( d->factors ) M_free(d->factors,"Dollar factors");
M_free(d,"Dollar in FactorIn");
}
NumberFree(GCDbuffer,"FactorIn"); NumberFree(GCDbuffer2,"FactorIn");
NumberFree(LCMbuffer,"FactorIn"); NumberFree(LCMb,"FactorIn"); NumberFree(LCMc,"FactorIn");
return(0);
onerror:
AT.WorkPointer = oldwork;
MLOCK(ErrorMessageLock);
MesCall("FactorIn");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorIn"); NumberFree(GCDbuffer2,"FactorIn");
NumberFree(LCMbuffer,"FactorIn"); NumberFree(LCMb,"FactorIn"); NumberFree(LCMc,"FactorIn");
return(-1);
}
int FactorInExpr(PHEAD WORD *term, WORD level)
{
GETBIDENTITY
WORD *t, *tstop, *m, *oldwork, *mstop, *n1, *n2, *n3, *n4, *n1stop, *n2stop;
WORD *r1, *r2, *r3, *r4, j, k, kGCD, kGCD2, kLCM, jGCD, kkLCM, jLCM, size, sign;
WORD *newterm, expr = 0;
WORD olddeferflag = AR.DeferFlag, oldgetfile = AR.GetFile, oldhold = AR.KeptInHold;
WORD newgetfile, newhold;
int i;
EXPRESSIONS e;
FILEHANDLE *file = 0;
POSITION position, oldposition, startposition;
WORD *oldcpointer = AR.CompressPointer;
UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc;
GCDbuffer = NumberMalloc("FactorInExpr"); GCDbuffer2 = NumberMalloc("FactorInExpr");
LCMbuffer = NumberMalloc("FactorInExpr"); LCMb = NumberMalloc("FactorInExpr"); LCMc = NumberMalloc("FactorInExpr");
t = term; GETSTOP(t,tstop); t++;
while ( t < tstop ) {
if ( *t == FACTORIN && t[1] == FUNHEAD+2 && t[FUNHEAD] == -EXPRESSION ) {
expr = t[FUNHEAD+1];
break;
}
t += t[1];
}
if ( t >= tstop ) {
MLOCK(ErrorMessageLock);
MesPrint("Internal error. Could not find proper factorin_ function.");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
oldwork = AT.WorkPointer;
if ( AT.previousEfactor && ( expr == AT.previousEfactor[0] ) ) {
/*
We have a hit in the cache. Construct the new term.
At the moment AT.previousEfactor[1] is reserved for future flags
*/
goto PutTheFactor;
}
/*
No hit. We have to do the work. We start with constructing the factor
in the WorkSpace. Later we will move it to the cache.
Finally we will jump to PutTheFactor.
*/
e = Expressions + expr;
switch ( e->status ) {
case LOCALEXPRESSION:
case SKIPLEXPRESSION:
case DROPLEXPRESSION:
case GLOBALEXPRESSION:
case SKIPGEXPRESSION:
case DROPGEXPRESSION:
/*
Expression is to be found in the input Scratch file.
Set the file handle and the position.
The rest is done by GetTerm.
*/
newhold = 0;
newgetfile = 1;
file = AR.infile;
break;
case HIDDENLEXPRESSION:
case HIDDENGEXPRESSION:
case HIDELEXPRESSION:
case HIDEGEXPRESSION:
case DROPHLEXPRESSION:
case DROPHGEXPRESSION:
case UNHIDELEXPRESSION:
case UNHIDEGEXPRESSION:
/*
Expression is to be found in the hide Scratch file.
Set the file handle and the position.
The rest is done by GetTerm.
*/
newhold = 0;
newgetfile = 2;
file = AR.hidefile;
break;
case STOREDEXPRESSION:
/*
This is an 'illegal' case
*/
MLOCK(ErrorMessageLock);
MesPrint("Error: factorin_ cannot determine factors in stored expressions.");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
case DROPPEDEXPRESSION:
/*
We replace the function by 1.
*/
m = oldwork; n1 = term;
while ( n1 < t ) *m++ = *n1++;
n1 = t + t[1]; tstop = term + *term;
while ( n1 < tstop ) *m++ = *n1++;
*oldwork = m - oldwork;
AT.WorkPointer = m;
if ( Generator(BHEAD oldwork,level) ) {
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
AT.WorkPointer = oldwork;
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(0);
default:
MLOCK(ErrorMessageLock);
MesPrint("Error: Illegal expression in factorinexpr.");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
/*
Before we start with the file we set the buffers for the coefficient
For the coefficient we have to determine the LCM of the denominators
and the GCD of the numerators.
*/
position = AS.OldOnFile[expr];
AR.DeferFlag = 0; AR.KeptInHold = newhold; AR.GetFile = newgetfile;
SeekScratch(file,&oldposition);
SetScratch(file,&position);
if ( GetTerm(BHEAD oldwork) <= 0 ) {
MLOCK(ErrorMessageLock);
MesPrint("(5) Expression %d has problems in scratchfile",expr);
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
SeekScratch(file,&startposition);
SeekScratch(file,&position);
/*
Load the first term in the workspace
*/
if ( GetTerm(BHEAD oldwork) == 0 ) {
SetScratch(file,&oldposition); /* We still need this untill Processor is clean */
AR.DeferFlag = olddeferflag;
oldwork[0] = 4; oldwork[1] = 1; oldwork[2] = 1; oldwork[3] = 3;
goto Complete;
}
SeekScratch(file,&position);
AR.DeferFlag = olddeferflag; AR.KeptInHold = oldhold; AR.GetFile = oldgetfile;
r2 = m = oldwork + *oldwork;
j = m[-1];
m -= ABS(j);
*oldwork = (WORD)(m-oldwork);
AT.WorkPointer = newterm = mstop = m;
/*
Now take the coefficient of the first term to load up the LCM and the GCD
*/
r3 = m;
k = REDLENG(j);
if ( k < 0 ) { k = -k; sign = -1; }
else { sign = 1; }
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD];
k = REDLENG(j);
if ( k < 0 ) k = -k;
r3 += k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM];
/*
The copy and the coefficient are in place. Now search through the terms.
*/
for (;;) {
AR.DeferFlag = 0; AR.KeptInHold = newhold; AR.GetFile = newgetfile;
SetScratch(file,&position);
size = GetTerm(BHEAD newterm);
SeekScratch(file,&position);
AR.DeferFlag = olddeferflag; AR.KeptInHold = oldhold; AR.GetFile = oldgetfile;
if ( size == 0 ) break;
m = oldwork+1;
r2 = newterm + *newterm;
r2 -= ABS(r2[-1]);
r1 = newterm+1;
while ( m < mstop ) {
while ( r1 < r2 ) {
if ( *r1 != *m ) {
r1 += r1[1]; continue;
}
/*
Now the various cases
#[ SYMBOL :
*/
if ( *m == SYMBOL ) {
n1 = m+2; n1stop = m+m[1];
n2stop = r1+r1[1];
while ( n1 < n1stop ) {
n2 = r1+2;
while ( n2 < n2stop ) {
if ( *n1 != *n2 ) { n2 += 2; continue; }
if ( n1[1] > 0 ) {
if ( n2[1] < 0 ) { n2 += 2; continue; }
if ( n2[1] < n1[1] ) n1[1] = n2[1];
}
else {
if ( n2[1] > 0 ) { n2 += 2; continue; }
if ( n2[1] > n1[1] ) n1[1] = n2[1];
}
break;
}
if ( n2 >= n2stop ) { /* scratch symbol */
if ( m[1] == 4 ) goto scratch;
m[1] -= 2;
n3 = n1; n4 = n1+2;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 2; n1stop -= 2;
continue;
}
n1 += 2;
}
break;
}
/*
#] SYMBOL :
#[ DOTPRODUCT :
*/
else if ( *m == DOTPRODUCT ) {
n1 = m+2; n1stop = m+m[1];
n2stop = r1+r1[1];
while ( n1 < n1stop ) {
n2 = r1+2;
while ( n2 < n2stop ) {
if ( *n1 != *n2 || n1[1] != n2[1] ) { n2 += 3; continue; }
if ( n1[2] > 0 ) {
if ( n2[2] < 0 ) { n2 += 3; continue; }
if ( n2[2] < n1[2] ) n1[2] = n2[2];
}
else {
if ( n2[2] > 0 ) { n2 += 3; continue; }
if ( n2[2] > n1[2] ) n1[2] = n2[2];
}
break;
}
if ( n2 >= n2stop ) { /* scratch dotproduct */
if ( m[1] == 5 ) goto scratch;
m[1] -= 3;
n3 = n1; n4 = n1+3;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 3; n1stop -= 3;
continue;
}
n1 += 3;
}
break;
}
/*
#] DOTPRODUCT :
#[ VECTOR :
*/
else if ( *m == VECTOR ) {
/*
Here we have to be careful if there is more than
one of the same
*/
n1 = m+2; n1stop = m+m[1];
n2 = r1+2;n2stop = r1+r1[1];
while ( n1 < n1stop ) {
while ( n2 < n2stop ) {
if ( *n1 == *n2 && n1[1] == n2[1] ) {
n2 += 2; goto nextn1;
}
n2 += 2;
}
if ( n2 >= n2stop ) { /* scratch vector */
if ( m[1] == 4 ) goto scratch;
m[1] -= 2;
n3 = n1; n4 = n1+2;
while ( n4 < mstop ) *n3++ = *n4++;
*oldwork = n3 - oldwork;
mstop -= 2; n1stop -= 2;
continue;
}
n2 = r1+2;
nextn1: n1 += 2;
}
break;
}
/*
#] VECTOR :
#[ REMAINDER :
*/
else {
/*
Again: watch for multiple occurrences of the same object
*/
if ( m[1] != r1[1] ) { r1 += r1[1]; continue; }
for ( j = 2; j < m[1]; j++ ) {
if ( m[j] != r1[j] ) break;
}
if ( j < m[1] ) { r1 += r1[1]; continue; }
r1 += r1[1]; /* to restart at the next potential match */
goto nextm; /* match */
}
/*
#] REMAINDER :
*/
}
if ( r1 >= r2 ) { /* no factor! */
scratch:;
r3 = m + m[1]; r4 = m;
while ( r3 < mstop ) *r4++ = *r3++;
*oldwork = r4 - oldwork;
if ( *oldwork == 1 ) goto nofactor;
mstop = r4;
r1 = newterm + 1;
continue;
}
r1 = newterm + 1;
nextm: m += m[1];
}
nofactor:;
/*
Now the coefficient
*/
r2 = newterm + *newterm;
j = r2[-1];
r3 = r2 - ABS(j);
k = REDLENG(j);
if ( k < 0 ) k = -k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) {
/*
GCD is already 1
*/
}
else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) {
if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) {
goto onerror;
}
kGCD = kGCD2;
for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i];
}
else {
kGCD = 1; GCDbuffer[0] = 1;
}
k = REDLENG(j);
if ( k < 0 ) k = -k;
r3 += k;
while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) {
for ( kLCM = 0; kLCM < k; kLCM++ )
LCMbuffer[kLCM] = r3[kLCM];
}
else if ( ( k != 1 ) || ( r3[0] != 1 ) ) {
if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) {
goto onerror;
}
DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM);
MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM);
for ( kLCM = 0; kLCM < jLCM; kLCM++ )
LCMbuffer[kLCM] = LCMc[kLCM];
}
else {} /* LCM doesn't change */
}
SetScratch(file,&oldposition); /* Needed until Processor is thread safe */
AR.DeferFlag = olddeferflag;
/*
Now put the term together in oldwork: GCD/LCM
We have already the algebraic contents there.
*/
r3 = (WORD *)(GCDbuffer);
r4 = (WORD *)(LCMbuffer);
r1 = oldwork + *oldwork;
if ( kGCD == kLCM ) {
for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++;
for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r4++;
k = 2*kGCD+1;
}
else if ( kGCD > kLCM ) {
for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++;
for ( jGCD = 0; jGCD < kLCM; jGCD++ ) *r1++ = *r4++;
for ( jGCD = kLCM; jGCD < kGCD; jGCD++ ) *r1++ = 0;
k = 2*kGCD+1;
}
else {
for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++;
for ( jGCD = kGCD; jGCD < kLCM; jGCD++ ) *r1++ = 0;
for ( jGCD = 0; jGCD < kLCM; jGCD++ ) *r1++ = *r4++;
k = 2*kLCM+1;
}
if ( sign < 0 ) *r1++ = -k;
else *r1++ = k;
*oldwork = (WORD)(r1-oldwork);
/*
Now put the new term in the cache
*/
Complete:;
if ( AT.previousEfactor ) M_free(AT.previousEfactor,"Efactor cache");
AT.previousEfactor = (WORD *)Malloc1((*oldwork+2)*sizeof(WORD),"Efactor cache");
AT.previousEfactor[0] = expr;
r1 = oldwork; r2 = AT.previousEfactor + 2; k = *oldwork;
NCOPY(r2,r1,k)
AT.previousEfactor[1] = 0;
/*
Now we construct the new term in the workspace.
*/
PutTheFactor:;
if ( AT.WorkPointer + AT.previousEfactor[2] >= AT.WorkTop ) {
MLOCK(ErrorMessageLock);
MesWork();
MesPrint("Called from factorin_");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
n1 = oldwork; n2 = term; while ( n2 < t ) *n1++ = *n2++;
n2 = AT.previousEfactor+2; GETSTOP(n2,n2stop); n3 = n2 + *n2;
n2++; while ( n2 < n2stop ) *n1++ = *n2++;
n2 = t + t[1]; while ( n2 < tstop ) *n1++ = *n2++;
size = term[*term-1];
size = REDLENG(size);
k = n3[-1]; k = REDLENG(k);
if ( MulRat(BHEAD (UWORD *)tstop,size,(UWORD *)n2stop,k,
(UWORD *)n1,&size) ) goto onerror;
size = INCLENG(size);
k = size < 0 ? -size: size;
n1 += k; n1[-1] = size;
*oldwork = n1 - oldwork;
AT.WorkPointer = n1;
if ( Generator(BHEAD oldwork,level) ) {
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
AT.WorkPointer = oldwork;
AR.CompressPointer = oldcpointer;
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(0);
onerror:
AT.WorkPointer = oldwork;
AR.CompressPointer = oldcpointer;
MLOCK(ErrorMessageLock);
MesCall("FactorInExpr");
MUNLOCK(ErrorMessageLock);
NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr");
NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr");
return(-1);
}
