inline bool CDS_YHay<Tprec, Dim>::calcCoefficients2D () {
prec_t dy_dx = Gamma * dy / dx;
prec_t dx_dy = Gamma * dx / dy;
prec_t dxy_dt = dx * dy / dt;
prec_t RaGaVol = Rayleigh * Gamma * 0.5 * dx * dy;
prec_t ce, cw;
prec_t cn, cs;
aE = 0.0; aW = 0.0; aN = 0.0; aS = 0.0; aP = 0.0;
sp = 0.0;
for (int j = bj; j <= ej; ++j)
for (int i = bi; i <= ei; ++i)
{
ce = ( u(i ,j) + u(i ,j+1) ) * 0.5 * dy;
cw = ( u(i-1,j) + u(i-1,j+1) ) * 0.5 * dy;
cn = ( v(i ,j) + v(i ,j+1) ) * 0.5 * dx;
cs = ( v(i ,j) + v(i ,j-1) ) * 0.5 * dx;
aE (i,j) = dy_dx - ce * 0.5;
aW (i,j) = dy_dx + cw * 0.5;
aN (i,j) = dx_dy - cn * 0.5;
aS (i,j) = dx_dy + cs * 0.5;
aP (i,j) = aE (i,j) + aW (i,j) + aN (i,j) + aS (i,j) + dxy_dt;
// + (ce - cw) + (cn - cs);
// Term (ce - cw) is part of discretizated continuity equation, and
// must be equal to zero when that equation is valid, so I can avoid
// this term for efficiency.
sp (i,j) = v(i,j) * dxy_dt - ( p(i,j+1) - p(i,j) ) * dx +
RaGaVol * ( T(i,j) + T(i,j+1) );
}
calc_dv_2D();
applyBoundaryConditions2D();
return 0;
}
void LExec::plm_trace()
{
/*
if (*Port=='C' && 0 == strcmp(Cur_goal,"clause"))
{
plmtrace_msg("CLAUSE ");
plm_xs(Cur_arity);
return;
}
else return;
*/
#ifdef LANDFILL
if (*Port==aS('C') || *Port==aS('R') || *Port==aS('X'))
depth++;
DUMP << "TR " << depth << "[" << Cur_clause << "] " << Port << SP << MODPREDAR(Cur_modix, Cur_goala, Cur_arity) << NL;
// plmtrace_msg(aS("pt %d/[%d]%ls: %ls/%d"), depth, Cur_clause, Port, Cur_goal,
// (int)Cur_arity);
// plm_xs(Cur_arity);
pHXL->DumpX(Cur_arity);
if (*Port == aS('F') || *Port == aS('E'))
depth--;
return;
#endif
}
inline bool Upwind_ZCoDiS<Tprec, Dim>::calcCoefficients3D () {
prec_t dyz = dy * dz, dyz_dx = Gamma * dyz / dx;
prec_t dxz = dx * dz, dxz_dy = Gamma * dxz / dy;
prec_t dxy = dx * dy, dxy_dz = Gamma * dxy / dz;
prec_t dxyz_dt = dx * dy * dz / dt;
prec_t ce, cw;
prec_t cn, cs;
prec_t cf, cb;
aE = 0.0; aW = 0.0; aN = 0.0; aS = 0.0; aF = 0.0; aB = 0.0; aP = 0.0;
sp = 0.0;
for (int k = bk; k <= ek; ++k)
for (int i = bi; i <= ei; ++i)
for (int j = bj; j <= ej; ++j)
{
ce = ( u(i,j,k) + u(i,j+1,k) ) * 0.5 * dyz;
cw = ( u(i-1,j,k) + u(i-1,j+1,k) ) * 0.5 * dyz;
cn = ( v(i,j,k) + v(i+1,j,k) ) * 0.5 * dxz;
cs = ( v(i,j-1,k) + v(i+1,j-1,k) ) * 0.5 * dxz;
cf = ( w(i,j,k) + w(i,j,k+1) ) * 0.5 * dxy;
cb = ( w(i,j,k) + w(i,j,k-1) ) * 0.5 * dxy;
if ( ce > 0 ) ce = 0.0;
else ce = -ce;
//
// This statement:
if ( cw <= 0 ) cw = 0.0;
//
// is more efficient than the next similar one:
// if ( cw > 0 ) cw = cw;
// else cw = 0.0;
if ( cn > 0 ) cn = 0.0;
else cn = -cn;
if ( cs <= 0 ) cs = 0.0;
if ( cf > 0 ) cf = 0.0;
else cf = -cf;
if ( cb <= 0 ) cb = 0.0;
aE (i,j,k) = (dyz_dx + ce);
aW (i,j,k) = (dyz_dx + cw);
aN (i,j,k) = (dxz_dy + cn);
aS (i,j,k) = (dxz_dy + cs);
aF (i,j,k) = (dxy_dz + cf);
aB (i,j,k) = (dxy_dz + cb);
aP (i,j,k) = aE (i,j,k) + aW (i,j,k) + aN (i,j,k) + aS (i,j,k)
+ aF (i,j,k) + aB (i,j,k) + dxyz_dt;
// + (ce - cw);
// Term (ce - cw) is part of discretizated continuity equation, and
// must be equal to zero when that equation is valid, so I can avoid
// this term for efficiency.
sp(i,j,k) = w(i,j,k) * dxyz_dt -
( p(i,j,k+1)- p(i,j,k) ) * dxy;
}
calc_dw_3D();
applyBoundaryConditions3D();
return 0;
}
int Linker::map_atom(int anumber)
{
aCHAR *name;
int oldhash;
int ahash;
name = LAtomTable[anumber];
#ifdef BUG_LINK
fprintf(lout, "map_atom: %d, %ls\n", anumber, name);
#endif
if (name == NULL)
abort_linker(aS("Error: Local atom table disaster (# %d)"), anumber);
oldhash = ahash = AtomHash(name);
while (GAtomTable[ahash].name) // while slot full
{
if(0 == Lstrcmp(name, GAtomTable[ahash].name)) // found it
{
ahash = GAtomTable[ahash].index ;
// bigdig if(anumber < 0)
// bigdig ahash = -ahash;
return(ahash);
}
// if collision, bump it
ahash = (ahash < eMaxAtoms - 1) ? ahash + 1 : 0;
if (ahash == oldhash) // full circle
abort_linker(aS("Error: Local atom %s not found in GAtomTable"), name);
}
abort_linker(aS("Error: Local atom %s not found in GAtomTable"), name);
return 0; // a formality
}
void Linker::EnterGAtom(aCHAR * abuf, int filei)
{ // Enter one global atom whose name is abuf
int ahash;
int oldhash;
aCHAR *pb;
const int bbufsize = TERM_BUFSIZE;
//aCHAR bbuf[bbufsize+1];
aCHAR *buf;
buf = abuf;
#ifdef BUG_LINK
fprintf(lout, "atom: %ls\n", buf);
#endif
oldhash = ahash = AtomHash(buf);
while (GAtomTable[ahash].name) // while slot full
{
if (0 == Lstrcmp(buf, GAtomTable[ahash].name))
return; // symbol already installed
// if collision, bump it else wrap around
ahash = (ahash < eMaxAtoms - 1) ? ahash + 1 : 0;
if (ahash == oldhash) // full circle
abort_linker(aS("Error: Global atom table full"));
}
if (NULL == (pb = (aCHAR*) new aCHAR[1+Lstrlen(buf)]))
abort_linker(aS("Error: Out of memory"));
Lstrcpy(pb, buf);
GAtomTable[ahash].name = pb;
}
inline
bool CDS_YLES<T_number, Dim>::calcCoefficients(const ScalarField &nut) {
T_number dyz = dy * dz, dxz = dx * dz, dxy = dx * dy;
T_number dyz_dx = dyz / dx, dxz_dy = dxz / dy, dxy_dz = dxy / dz;
T_number ce, cw, cn, cs, cf, cb;
T_number nutinter;
T_number dxyz_dt = dx * dy * dz / dt;
T_number RaGaVol = Rayleigh * Gamma * 0.5 * dx * dy * dz;
for (int i = bi; i <= ei; ++i)
for (int j = bj; j <= ej; ++j)
for (int k = bk; k <= ek; ++k)
{
ce = ( u(i,j,k) + u(i,j+1,k) ) * 0.5 * dyz;
cw = ( u(i-1,j,k) + u(i-1,j+1,k) ) * 0.5 * dyz;
cn = ( v(i,j,k) + v(i,j+1,k) ) * 0.5 * dxz;
cs = ( v(i,j,k) + v(i,j-1,k) ) * 0.5 * dxz;
cf = ( w(i,j,k) + w(i,j,k+1) ) * 0.5 * dxy;
cb = ( w(i-1,j,k) + w(i-1,j,k+1) ) * 0.5 * dxy;
//
// nut is calculated on center of volumes, therefore, nut
// must be staggered in y direction:
nutinter = 0.5 * ( nut(i,j,k) + nut(i,j+1,k) );
aE (i,j,k) = (Gamma + nutinter) * dyz_dx - ce * 0.5;
aW (i,j,k) = (Gamma + nutinter) * dyz_dx + cw * 0.5;
aN (i,j,k) = 2 * (Gamma + nutinter) * dxz_dy - cn * 0.5;
aS (i,j,k) = 2 * (Gamma + nutinter) * dxz_dy + cs * 0.5;
aF (i,j,k) = (Gamma + nutinter) * dxy_dz - cf * 0.5;
aB (i,j,k) = (Gamma + nutinter) * dxy_dz + cb * 0.5;
aP (i,j,k) = aE (i,j,k) + aW (i,j,k) +
aN (i,j,k) + aS (i,j,k) +
aF (i,j,k) + aB (i,j,k) +
dxyz_dt;
// aP (i,j,k) /= alpha; // under-relaxation
// + (ce - cw) + (cn - cs) + (cf - cb);
// Term (ce - cw) is part of discretizated continuity equation, and
// must be equal to zero when that equation is valid, so I can avoid
// this term for efficiency.
sp (i,j,k) = v(i,j,k) * dxyz_dt -
( p(i,j+1,k) - p(i,j,k) ) * dxz +
RaGaVol * ( T(i,j,k) + T(i,j+1,k) ) +
nutinter * ( (u(i,j+1,k) - u(i,j,k) -
u(i-1,j+1,k) + u(i-1,j,k)) * dz +
(w(i,j+1,k) - w(i,j,k) -
w(i,j+1,k-1) + w(i,j,k-1)) * dx );
// v(i,j,k) * (1-alpha) * aP(i,j,k)/alpha; // under-relaxation
}
calc_dv_3D();
applyBoundaryConditions3D();
return 1;
}
inline bool Upwind_XCoDiS<Tprec, Dim>::calcCoefficients2D()
{
prec_t dy_dx = Gamma * dy / dx;
prec_t dx_dy = Gamma * dx / dy;
prec_t dxy_dt = dx * dy / dt;
prec_t ce, cw;
prec_t cn, cs;
aE = 0.0;
aW = 0.0;
aN = 0.0;
aS = 0.0;
aP = 0.0;
sp = 0.0;
for (int i = bi; i <= ei; ++i)
for (int j = bj; j <= ej; ++j)
{
ce = ( u(i+1, j) + u(i,j) ) * 0.5 * dy;
cw = ( u(i-1, j) + u(i,j) ) * 0.5 * dy;
cn = ( v(i,j) + v(i+1,j) ) * 0.5 * dx;
cs = ( v(i,j-1) + v(i+1,j-1) ) * 0.5 * dx;
if ( ce > 0 ) ce = 0.0;
else ce = -ce;
//
// This statement:
if ( cw <= 0 ) cw = 0.0;
//
// is more efficient than the next similar one:
// if ( cw > 0 ) cw = cw;
// else cw = 0.0;
if ( cn > 0 ) cn = 0.0;
else cn = -cn;
if ( cs <= 0 ) cs = 0.0;
aE (i,j) = (dy_dx + ce);
aW (i,j) = (dy_dx + cw);
aN (i,j) = (dx_dy + cn);
aS (i,j) = (dx_dy + cs);
aP (i,j) = aE (i,j) + aW (i,j) + aN (i,j) + aS (i,j);
//+ dxy_dt;
// + (ce - cw) + (cn - cs);
// Term (ce - cw) is part of discretizated continuity equation, and
// must be equal to zero when that equation is valid, so I can avoid
// this term for efficiency.
// sp (i,j) = u(i,j) * dxy_dt - ( p(i+1,j) - p(i,j) ) * dy;
sp (i,j) = - ( p(i+1,j) - p(i,j) ) * dy;
}
calc_du_2D();
applyBoundaryConditions2D();
return 0;
}
void Linker::read_l_atoms(FILE * f, aUINT16 length, int filei)
{ // read local atom table for predicate
int i;
int ccount, ichar;
aCHAR *pbuf, *qbuf;
const int bufsize = TERM_BUFSIZE;
aCHAR abuf[bufsize+1];
//aCHAR bbuf[bufsize+1];
static int id;
for(i = 0; i < eMaxAtoms; ++i) // 1st, reset local atom table from last time
if (LAtomTable[i])
{
delete[] LAtomTable[i];
LAtomTable[i] = NULL;
}
ccount = 0;
if (isunicode)
length = length / 2;
for(i=0; i < eMaxAtoms; ++i)
{
if(ccount < length) // read atom table
{
pbuf = abuf;
do
{
if (pbuf >= (abuf + bufsize))
{
abort_linker(aS("Error: Local atom too long in code"));
}
if (-1 == (ichar = ISUNIGETC(f)))
aborteof(aS("local atom table"));
++ccount;
} while((*pbuf++ = (aCHAR) ichar) != EOS);
qbuf = abuf;
if (NULL == (pbuf = (aCHAR*) new aCHAR[Lstrlen(qbuf) + 1] ))
abort_linker(aS("Error: Out of memory"));
Lstrcpy(pbuf, qbuf);
LAtomTable[i] = pbuf;
}
else
return;
}
abort_linker(aS("Error: Local atom table full"));
}
void Linker::initialize( void(*pfM)(aCHAR*) )
{
#ifdef BUG_LINK
lout = fopen("buglink.txt","w");
// printf("buglink open\n");
fprintf(lout, "** Buglink open\n");
fprintf(lout, "%s\n", __TIME__);
fflush(lout);
// return;
#endif
aCHAR outbuf[512];
#ifdef BUG_LINK
pfMsg = NULL;
#else
pfMsg = pfM;
#endif
eMaxAtoms = 1024 * MAX_ATOM_TABLE_SZ;
GAtomTable = NULL;
LAtomTable = NULL;
zero_fill(m_ver, 256);
Lstrcpy(m_ver, AMZI_VERSION);
Lstrncpy(outbuf, aS("\nAmzi! Prolog Linker "), 256);
Lstrncat(outbuf, m_ver, 256);
#ifdef BUG_LINK
return;
#endif
output(outbuf);
//output(aS(""));
}
int Linker::fread_int16(FILE *f)
{ // read a 2-byte integer -- if you can't then blow up
aINT16 i;
if (!read_int16(&i, f))
// if (0 == fread((aBYTE *) &i, 2, 1, f))
aborteof(aS("while processing"));
return((int) i);
}
void LExec::plm_xs(ARITY ar)
{
int i;
TERM t;
if (ar == 0)
{
plmtrace_msg(NL);
return;
}
plmtrace_msg(aS("( "));
for (i = 0; i < (int) ar; i++)
{
t = (pHXL->XVar(i))->dref();
// plmtrace_msg("\n X[%d] ", i);
if (i) plmtrace_msg(aS(", "));
//pIO->termWriteLog(t);
// plmprint_cell(t);
}
plmtrace_msg(aS(" )\n"));
}
void Linker::read_atom(FILE* f, FILE* pFtarg)
{
aBYTE buf[2];
aINT16 temp, gatom;
if (0 == fread(buf, 2, 1, f))
aborteof(aS("read atom"));
temp = getint16(buf);
gatom = map_atom(temp);
//fwrite(&gatom, 2, 1, pFtarg);
write_int16(gatom, pFtarg);
}
void Linker::initialize( void(*pfM)(char*) )
{
#ifdef BUG_LINK
lout = fopen("buglink.txt","w");
// printf("buglink open\n");
fprintf(lout, "** Buglink open\n");
fprintf(lout, "%s\n", __TIME__);
fflush(lout);
// return;
#endif
aCHAR outbuf[120];
pfMsgA = pfM;
pfMsg = NULL;
eMaxAtoms = 1024 * MAX_ATOM_TABLE_SZ;
GAtomTable = NULL;
LAtomTable = NULL;
Lstrcpy(m_ver, AMZI_VERSION);
Lstrncpy(outbuf, aS("\nAmzi! Prolog Linker "), 120);
Lstrncat(outbuf, m_ver, 120);
output(outbuf);
}
void Linker::read_code_segs(FILE *f, FILE *pFtarg, int filei)
{
aUINT16 length;
aBYTE mod, type;
fseek(f, 1L, SEEK_SET); // get to byte 1
fread(&type, sizeof(aBYTE), 1, f); // 1
if ((type & 0x03) != 0x03)
abort_linker(aS("Error: Input file not a .PLM file"));
isunicode = type & 0x10 ? LTRUE : LFALSE;
fread(&mod, sizeof(aBYTE), 1, f); // 2 is it a module
//fread(&ver, sizeof(aBYTE), 1, f); // 3 get the version number
//if (ver < CUR_COMPILER)
// abort_linker(aS("Error: .PLM file not at current level, %d"),
// CUR_COMPILER);
fseek(f, CC_HEAD_LENGTH, SEEK_SET); // 8 skip header
// check for 00 at end of .plm, put there for VMS bug
while(read_uint16(&length, f) && length)
{ read_linked_segs(f, length, pFtarg, filei); }
}
void LExec::plmprint_cell(TERM t)
{
int i;
ARITY ar;
// DynamicClause* pdb;
STRptr name;
//PATOM a;
plmtrace_msg(aS("%0*lx: "), PP_SIZE, * (intCptr) t);
switch(t->getType())
{
// case consT :
// switch(pTSVC->SubType(t))
// {
case atomS:
//a = t->getAtom();
//if (i >= 0 && i < pATAB->GetMaxAtoms())
//{
ar = t->getArity();
name = *(t->getAtom());
plmtrace_msg(aS("ATOM %s/%d "), name, ar);
i = 1;
while (ar-- > 0)
{
plmtrace_msg(aS("\n %s[%d]: "), name, i++);
plmprint_cell(++t);
}
//}
//else
// plmtrace_msg(aS("ATOM - bad atom %0*lx"), PP_SIZE, *(intCptr)t);
break;
case intS: plmtrace_msg(aS("INTG %d "), t->getInt());
break;
/*
case dbrefS:
plmtrace_msg(aS("DBREF "));
pdb = t->getDBRef()->getClause();
plmtrace_msg(aS("\n DB: "));
plmprint_cell(pdb->getCode());
break;
*/
case doubleS: plmtrace_msg(aS("DOUBLE "));
break;
case singleS: plmtrace_msg(aS("SINGLE "));
break;
//case longS: plmtrace_msg(aS("LONG "));
// break;
//case mscwS: plmtrace_msg(aS("MSCW "));
// break;
case strS: plmtrace_msg(aS("STRING "));
break;
// default: plmtrace_msg(aS("GARBAGE CONSTANT TYPE "));
// }
// break;
case strucT:
plmtrace_msg(aS("STRUCT "));
plmtrace_msg(pHXL->cellname(t));
t = t->getTerm();
plmtrace_msg(aS("\n --> "));
plmprint_cell(t);
break;
case refT:
if (t != t->getTerm())
{
plmtrace_msg(aS("REF "));
plmtrace_msg(pHXL->cellname(t));
t = t->getTerm();
plmtrace_msg(aS("\n --> "));
plmprint_cell(t);
}
else
plmtrace_msg(aS("UNBOUND "));
break;
case listT:
plmtrace_msg(aS("LIST "));
plmtrace_msg(pHXL->cellname(t));
t = t->getTerm();
plmtrace_msg(aS("\n --> "));
plmprint_cell(t);
break;
default:
plmtrace_msg(aS("GARBAGE CELL TYPE "));
}
}
void LExec::cdDebugCode(CODEptr p, int length)
{
cdOP op;
CODEptr stop, start, q;
cdSINT i, x;
PATOM a;
stop = p + length;
start = p;
DUMP << aS("--- Code Listing ---") << NL << FLUSH;
while(p < stop)
{
op = * (cdOPptr) p;
DUMP << p
<< std::setw(5) << p-start
<< std::setw(4) << op
<< SP << ops[op] << SP;
p += cdOP_L;
switch(op)
{
case Owho_am_i:
p -= cdOP_L;
DUMP << ((CODE_HEADERptr) p) -> mod_ix << aS(":");
a = (PATOM) ((CODE_HEADERptr) p) -> pred_atom;
DUMP << PREDAR( *(a), ((CODE_HEADERptr) p) -> pred_arity );
p += sizeof(CODE_HEADER) / sizeof(CODE);
break;
case Ono_op: // no args
case Ofail:
case Oproceed:
case Odealloc:
case Ocut:
case Otrust_me_else:
case Ou_var_getlist:
case Ounify_nil:
break;
case Oget_nil: // Xi
case Oget_list:
case Oput_nil:
case Oput_list:
case Ounify_x_var:
case Ounify_x_val:
DUMP << aS("Xi ") << * (TERMptr) p;
p += PTR_L;
break;
case Oget_x_var: // Xi, Xj
case Oget_x_val:
case Oput_x_var:
case Oput_x_val:
DUMP << aS("Xi ") << * (TERMptr) p << aS(", ");
p += PTR_L;
DUMP << aS("Xj ") << * (TERMptr) p;
p += PTR_L;
break;
case Ounify_y_var: // Yi
case Ounify_y_val:
DUMP << aS("Yi ") << * (cdSMINTptr) p;
p += cdSMINT_L;
break;
case Ounify_unsafe:
DUMP << aS("Yi ") << * (cdSMINTptr) p;
p += cdSMINT_L;
break;
case Oget_y_var: // Yi, Xj
case Oget_y_val:
case Oput_y_var:
case Oput_y_val:
case Oput_unsafe:
DUMP << aS("Yi ") << * (cdSMINTptr) p << aS(", ");
p += cdSMINT_L;
DUMP << aS("Xi ") << * (cdSMINTptr) p;
p += PTR_L;
break;
case Ounify_void: // short int
case Oalloc:
case Olabel:
DUMP << * (cdSINTptr) p << SP;
p += cdSINT_L;
break;
case Ocutd:
case Oretry_me_else:
case Oretry:
case Otrust:
case Ogoto:
case Otrust_me_2_else:
DUMP << aS(" offset ") << * (cdSINTptr) p + (p - start);
p += cdSINT_L;
break;
case Otry_me_or_else:
case Otry_me_else:
case Otry:
DUMP << aS(" offset ") << * (cdSINTptr) p + (p - start) << aS(", ");
p += cdSINT_L;
DUMP << aS("NTV ") << * (cdSINTptr) p << aS(", ");
p += cdSINT_L;
break;
case Oget_con: // Constant, Xi
case Oput_con:
DUMP << * (TERM) p;
DUMP << aS(", ");
p += CELL_L;
DUMP << aS("Xi ") << * (TERMptr) p;
p += PTR_L;
break;
case Oescape:
DUMP << *(cdESCAPEptr)p;
p += cdESCAPE_L;
break;
case Oexec:
case Ocall:
case Omod_exec:
case Omod_call:
DUMP << " module:" << *(cdMODIXptr)p << SP;
p += cdMODIX_L;
case Oget_struc: // functor, arity, (Xi or short or null)
case Oput_struc:
DUMP << * (cdATOMptr) p << SP;
p += cdATOM_L;
if (op == Ocall || op == Oexec || op == Omod_call || op == Omod_exec)
{
DUMP << * (cdATOMptr) p;
p += cdATOM_L;
}
DUMP << aS(" / ") << * (cdSMINTptr) p;
p += cdSMINT_L;
// now figure third (optional arg
if (op == Oget_struc || op == Oput_struc) // Xi
{
DUMP << aS(", Xi ") << * (TERMptr) p;
p += PTR_L;
}
else if (op == Ocall || op == Omod_call) // short
{
DUMP << aS(", ") << * (cdSINTptr) p;
p += cdSINT_L;
}
// else no 3rd arg
break;
case Oexec_direct:
case Ocall_direct:
DUMP << aS("code* ") << * (CODEhnd) p;
p += cdMODIX_L + 2 * cdATOM_L + cdSMINT_L; /* the sizes from Ocall & Oexec */
if (op == Ocall_direct)
{
DUMP << aS(", ") << * (cdSINTptr) p;
p += cdSINT_L;
}
break;
case Ounify_con:
DUMP << * (TERM) p;
p += CELL_L;
break;
case Oswitch_on_term:
// three short ints
// we map these to match what the pcode expects
q = p;
for (i=0; i<3; i++)
{
if (* (cdSINTptr) p == 0)
DUMP << aS(" offset fail ");
else
DUMP << aS(" offset ")
<< i * (cdSINT_L) + * (cdSINTptr) p + (q - start);
p += cdSINT_L;
}
break;
case Oswitch_on_cons:
// short size, (size x |CELL|LABEL|)
x = * (cdSINTptr) p;
i = 0;
//errDebugMsg("%d: ", * (cdSINTptr) p);
p += cdSINT_L;
while(x--)
{
DUMP << aS(" ") << * (TERM) p;
p += CELL_L;
DUMP << aS(" offset[") << * (cdSINTptr) p + (p - start) << aS("]");
p += cdSINT_L;
}
break;
case Oswitch_on_struc:
// short size, (size x |NAME|ARITY|LABEL|)
x = * (cdSINTptr) p;
i = 0;
DUMP << * (cdSINTptr) p << aS(": ");
p += cdSINT_L;
while(x--)
{
// functor
DUMP << SP << * (cdATOMptr) p;
p += cdATOM_L;
// arity
DUMP << aS("/") << * (cdSMINTptr) p;
p += cdSMINT_L;
// label
DUMP << aS(" offset[") << * (cdSINTptr) p + (p - start) << aS("] ");
p += cdSINT_L;
}
break;
default:
DUMP << aS("Unknown op");
}
DUMP << NL << FLUSH;
}
DUMP << NL << aS("--- end ---") << NL << FLUSH;
}
inline bool CDS_YHay<Tprec, Dim>::calcCoefficients3D ()
{
prec_t dyz = dy * dz, dyz_dx = Gamma * dyz / dx;
prec_t dxz = dx * dz, dxz_dy = Gamma * dxz / dy;
prec_t dxy = dx * dy, dxy_dz = Gamma * dxy / dz;
prec_t dxyz_dt = dx * dy * dz / dt;
prec_t ce, cep, cem, cw, cwp, cwm, CE, CW;
prec_t cn, cnp, cnm, cs, csp, csm, CN, CS;
prec_t cf, cfp, cfm, cb, cbp, cbm, CF, CB;
prec_t RaGaVol = Rayleigh * Gamma * 0.5 * dx * dy * dz;
aE = 0.0; aW = 0.0; aN = 0.0; aS = 0.0; aF = 0.0; aB = 0.0; aP = 0.0;
sp = 0.0;
for (int k = bk; k <= ek; ++k)
for (int i = bi; i <= ei; ++i)
for (int j = bj; j <= ej; ++j)
{
CE = ce = ( u(i ,j,k) + u(i ,j+1,k ) ) * 0.5 * dyz;
CW = cw = ( u(i-1,j,k) + u(i-1,j+1,k ) ) * 0.5 * dyz;
CN = cn = ( v(i ,j,k) + v(i ,j+1,k ) ) * 0.5 * dxz;
CS = cs = ( v(i ,j,k) + v(i ,j-1,k ) ) * 0.5 * dxz;
CF = cf = ( w(i ,j,k) + w(i ,j ,k+1) ) * 0.5 * dxy;
CB = cb = ( w(i-1,j,k) + w(i-1,j ,k+1) ) * 0.5 * dxy;
cem = cep = 0;
cwm = cwp = 0;
cnm = cnp = 0;
csm = csp = 0;
cfm = cfp = 0;
cbm = cbp = 0;
if ( ce > 0 ){
CE = 0;
cep = ce * 0.5 * (-phi_0(i,j,k) + phi_0(i+1,j,k));
} else {
cem = ce * 0.5 * (phi_0(i,j,k) - phi_0(i+1,j,k));
}
if ( cw > 0 ){
cwp = cw * 0.5 * (-phi_0(i-1,j,k) + phi_0(i,j,k));
} else {
CW = 0.0;
cwm = cw * 0.5 * (phi_0(i-1,j,k) - phi_0(i,j,k));
}
if ( cn > 0 ){
CN = 0;
cnp = cn * 0.5 * (-phi_0(i,j,k) + phi_0(i,j+1,k));
} else {
cnm = cn * 0.5 * (phi_0(i,j,k) - phi_0(i,j+1,k));
}
if ( cs > 0 ){
csp = cs * 0.5 * (-phi_0(i,j-1,k) + phi_0(i,j,k));
} else {
CS = 0.0;
csm = cs * 0.5 * (phi_0(i,j-1,k) - phi_0(i,j,k));
}
if ( cf > 0 ){
CF = 0;
cfp = cf * 0.5 * (-phi_0(i,j,k) + phi_0(i,j,k+1));
} else {
cfm = cf * 0.5 * (phi_0(i,j,k) - phi_0(i,j,k+1));
}
if ( cb > 0 ){
cbp = cb * 0.5 * (-phi_0(i,j,k-1) + phi_0(i,j,k));
} else {
CB = 0.0;
cbm = cb * 0.5 * (phi_0(i,j,k-1) - phi_0(i,j,k));
}
aE (i,j,k) = dyz_dx - CE;
aW (i,j,k) = dyz_dx + CW;
aN (i,j,k) = dxz_dy - CN;
aS (i,j,k) = dxz_dy + CS;
aF (i,j,k) = dxy_dz - CF;
aB (i,j,k) = dxy_dz + CB;
aP (i,j,k) = aE (i,j,k) + aW (i,j,k) + aN (i,j,k) + aS (i,j,k)
+ aF (i,j,k) + aB (i,j,k) + dxyz_dt
+ (ce - cw) + (cn - cs) + (cn - cs);
sp (i,j,k) += v(i,j,k) * dxyz_dt -
( p(i,j+1,k) - p(i,j,k) ) * dxz +
RaGaVol * ( T(i,j,k) + T(i,j+1,k) )
- (cep + cem - cwp - cwm + cnp + cnm - csp - csm + cfp + cfm - cbp - cbm);
}
calc_dv_3D();
applyBoundaryConditions3D();
return 0;
}
int Linker::Link(int argctr, aCHAR* *pargv)
{
FILE *pFobj, *pFtarg;
int filei, i, j, count, pos;
int fpos_eoa;
aBYTE ibuf[CL_HEAD_LENGTH+4];
aBYTE checksum, curbyte;
bool is_system = false;
#if defined(_WIN32)
DWORD v = ::GetVersion();
g_osver = v < 0x80000000 ? WNT : W95;
#else
g_osver = OtherOS;
#endif
try {
// locking(); // get the registration status and info
output(aS("Linking: %s"), pargv[0]);
if (Lstrstr(pargv[0], aS("alis.xpl")) != NULL ||
Lstrstr(pargv[0], aS("acmp.xpl")) != NULL ||
Lstrstr(pargv[0], aS("aidl.xpl")) != NULL ||
Lstrstr(pargv[0], aS("axrf.xpl")) != NULL ) {
is_system = true; }
// Open output .xpl file
if (NULL == (pFtarg = Lfopen(pargv[0], aS("w+b"))))
abort_linker(aS("Error: Cannot open xpl file %s"), pargv[0]);
// make two passes through files - first one builds
// complete atom table - second pass constructs new file
// header and atom table then writes out clauses
// pass 0 - initialise
if (NULL == (GAtomTable = (G_ATOM*) new G_ATOM[eMaxAtoms] ))
abort_linker(aS("Insufficient memory for global atom table"));
//for(i = 0; i < eMaxAtoms; ++i)
// GAtomTable[i].name = NULL;
if (NULL == (LAtomTable = (L_ATOM*) new L_ATOM[eMaxAtoms] ))
abort_linker(aS("Insufficient memory for local atom table"));
for(i = 0; i < eMaxAtoms; ++i)
LAtomTable[i] = NULL;
// pass1
for (filei = 1; filei < argctr; ++filei)
{
output(aS("Opening: '%s'"), pargv[filei]);
if (NULL == (pFobj = Lasys_fopen(pargv[filei], aS("rb"), aS("abin"))))
abort_linker(aS("Error: Cannot open plm file '%s'"), pargv[filei]);
else
{
//output(aS("Reading Atom Table: %s"), pargv[filei]);
read_g_atoms(pFobj, filei);
fclose(pFobj);
}
}
// now read through global atom table setting index field
// to the index of the atom as it will be when the table
// is written out
count = 0;
for(i = 0; i < eMaxAtoms; ++i)
if (GAtomTable[i].name)
{
GAtomTable[i].index = count;
++count;
}
for (i = 0; i < CL_HEAD_LENGTH+4; i++)
ibuf[i] = 0;
/* Header bytes
0 - ff indicating a load module
1 - xpl/plm flag + unicode flag + large + longcode
2 - version
3 - build
4 - check sum of remaining header stuff + atom table
5 - 0, 1, 2 for professional or personal or evaluation edition
6 - platform id based on linker - 1 - Win32
7-? - serial number product code (ex. APX)
- serial number platform code (ex. PC)
- serial number sequence ID, as a long (ex. 93309)
*/
// write header
ibuf[0] = 0xFF; // the tag
#ifdef _UNICODE
ibuf[1] = 0x72; // .xpl + Unicode + large + long code
#else
ibuf[1] = 0x22; // signifying .xpl file + large
#endif
ibuf[2] = VERSION_NUMBER; // set module bit
ibuf[3] = BUILD_NUMBER; // oldest compiler version supported
#ifdef DISTVER
#ifdef BUG_LINK
fprintf(lout, "** Starting Initialization\n");
fflush(lout);
#endif
ibuf[8] = 0;
ibuf[9] = 0;
ibuf[10] = 0;
ibuf[11] = 0;
ibuf[12] = 0;
ibuf[13] = 0;
ibuf[14] = 0;
ibuf[15] = 0;
for (i = 16, j=0; i < CL_HEAD_LENGTH; i++, j++)
ibuf[i] = ibuf[8+j] ^ (aBYTE)i;
#endif // DISTVER
// fill out header and first four bytes of atom table length with 0s
ucFWRITE(ibuf, 1, CL_HEAD_LENGTH+4, pFtarg);
count = 0;
for(i = 0; i < eMaxAtoms; ++i) // now write the atom table
{
if (GAtomTable[i].name)
{
aCHAR *nptr = GAtomTable[i].name;
write_wstring(GAtomTable[i].name, pFtarg);
++count;
}
}
pos = (int) ftell(pFtarg); // currrent pos
fpos_eoa = pos; // end of atom table file pos
fseek(pFtarg, CL_HEAD_LENGTH, SEEK_SET); // posn for atom table length
pos = pos - (CL_HEAD_LENGTH + 4); // length of table
//printf("pos = 0x%x\n",pos); ray
write_int32(pos, pFtarg); // write it out
// write_int16(pos, pFtarg); // write it out
#ifdef BUG_LINK
fprintf(lout, "** Atom Table Done\n");
fflush(lout);
#endif
// compute check sum, starting with byte #5 and ending before fpos_eoa.
fseek(pFtarg, 5, SEEK_SET); // write it in byte #4.
checksum = 0xaa;
for (i=5; i<fpos_eoa; i++)
{
fread(&curbyte, 1, 1, pFtarg);
curbyte += (aBYTE)i;
checksum ^= curbyte;
}
fseek(pFtarg, 4, SEEK_SET);
ucFWRITE(&checksum, 1, 1, pFtarg);
#ifdef BUG_LINK
fprintf(lout, "** Check Sum Done\n");
fflush(lout);
#endif
// Back to the end of the atom table to continue the real work.
fseek(pFtarg, (long)(pos+CL_HEAD_LENGTH+4), SEEK_SET);
for (filei = 1; filei < argctr; ++filei)
{
if (NULL == (pFobj = Lasys_fopen(pargv[filei], aS("rb"), aS("abin"))))
abort_linker(aS("Warning: Cannot open PLM file %s"), pargv[filei]);
else
{
//output(aS("Reading Code Segments: %s"), pargv[filei]);
read_code_segs(pFobj, pFtarg, filei);
fclose(pFobj);
}
}
#ifdef BUG_LINK
fprintf(lout, "** Code Segments Done\n");
fflush(lout);
#endif
// originally added to catch a bug with binary files and VMS,
// but is now used to determine end of code, so leave in.
ibuf[0] = 0;
for (i=0; i<4; i++)
ucFWRITE(ibuf, 1, 1, pFtarg);
// write file names at end of file, so that ensure_loaded, if
// used, can check to see if a given file was loaded as part
// of an .xpl file, end with zeroes as above.
for (filei = 1; filei < argctr; ++filei)
{
write_wstring(pargv[filei], pFtarg);
}
// originally added to catch a bug with binary files and VMS,
// but is now used to determine end of file as well, so leave in.
ibuf[0] = 0;
for (i=0; i<4; i++)
ucFWRITE(ibuf, 1, 1, pFtarg);
fclose(pFtarg);
for(i = 1, count = 0; i < eMaxAtoms; ++i)
{
if (GAtomTable[i].name)
++count;
}
//output(aS("%d Global Atoms"), count);
output(aS("Link Done"));
} catch (ErrCode)
{
#ifdef BUG_LINK
fprintf(lout, "** Returning NOTOK 1\n");
fflush(lout);
#endif
#ifdef BUG_LINK
fclose(lout);
#endif
return NOTOK;
}
catch (...)
{
#ifdef BUG_LINK
fprintf(lout, "** Returning NOTOK 2\n");
fflush(lout);
#endif
#ifdef BUG_LINK
fclose(lout);
#endif
output(aS("\nUnrecognized system error"));
return NOTOK;
}
#ifdef BUG_LINK
fprintf(lout, "** Returning OK\n");
fflush(lout);
#endif
#ifdef BUG_LINK
fclose(lout);
#endif
return OK;
}
int Linker::read_code(FILE* f, FILE* pFtarg, long init_pos, int length,
aBYTE* buf)
{
aBYTE op;
int x;
#ifdef BUG_LINK
int i;
#endif
while( init_pos < length)
{
#ifdef BUG_LINK
fprintf(lout, "\nstart length %d init_pos %d ", length, init_pos);
#endif
if (0 == fread(buf, CODESIZE, 1, f))
aborteof(aS("code"));
ucFWRITE(buf, CODESIZE, 1, pFtarg);
init_pos += CODESIZE;
op = *buf;
#ifdef BUG_LINK
fprintf(lout, "\nop %d, %s: ", (int) op, lops[op]);
#endif
switch(op)
{
case Ono_op: // no args
case Ofail:
case Oproceed:
case Odealloc:
case Ocut:
case Ocut64:
case Otrust_me_else:
case Ou_var_getlist:
case Ounify_nil:
break;
case Ounify_y_var: // Xi or Yi
case Ounify_y_val:
case Ounify_unsafe:
case Oget_nil:
case Oget_list:
case Oput_nil:
case Oput_list:
case Ounify_x_var:
case Ounify_x_val:
if (0 == fread(buf, 2, 1, f))
aborteof(aS("unify x val"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
break;
case Oget_y_var: // Xi and Yi or Xj
case Oget_y_val:
case Oput_y_var:
case Oput_y_val:
case Oput_unsafe:
case Oget_x_var:
case Oget_x_val:
case Oput_x_var:
case Oput_x_val:
if (0 == fread(buf, 2, 2, f))
aborteof(aS("put x val"));
ucFWRITE(buf, 2, 2, pFtarg);
init_pos += 4;
break;
case Ounify_void: // short int
case Oalloc:
case Ocutd:
case Oretry_me_else:
case Oretry:
case Otrust:
case Ogoto:
case Otrust_me_2_else:
case Olabel:
if (0 == fread(buf, 2, 1, f))
aborteof(aS("label"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
#ifdef BUG_LINK
fprintf(lout, "%d", (int) getint16(buf));
#endif
break;
case Otry_me_else:
case Otry_me_or_else:
case Otry: // 2 short ints
if (0 == fread(buf, 2, 2, f))
aborteof(aS("try"));
ucFWRITE(buf, 2, 2, pFtarg);
init_pos += 4;
#ifdef BUG_LINK
fprintf(lout, "%d, %d",
(int) getint16(buf), (int) getint16(buf+2));
#endif
break;
case Oget_con: // Constant, Xi
case Oput_con:
read_const(f, pFtarg, &init_pos);
if (0 == fread(buf, 2, 1, f))
aborteof(aS("put con"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
break;
case Oexec:
case Oescape:
case Ocall:
case Omod_call:
case Omod_exec:
case Oget_struc: // functor, arity, (Xi or short or null)
case Oput_struc:
read_atom(f, pFtarg); // functor
init_pos += 2;
if (op == Ocall || op == Oexec || op == Omod_call || op == Omod_exec) // new style call/exec
{
//if (0 == fread(buf, 2, 1, f))
// aborteof(aS("put struc"));
//ucFWRITE(buf, 2, 1, pFtarg);
// shouldn't this be a read atom, not just a buf??
read_atom(f, pFtarg);
init_pos += 2;
}
if (0 == fread(buf, 2, 1, f))
aborteof(aS("put struc 2"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
#ifdef BUG_LINK
fprintf(lout, " arity = %d", (int) getint16(buf));
#endif
// now figure third (optional arg
if (op == Oget_struc ||
op == Oput_struc) // Xi
{
if (0 == fread(buf, 2, 1, f))
aborteof(aS("put struc 3"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
#ifdef BUG_LINK
fprintf(lout, " xi(get/put_struc) = %d", (int) getint16(buf));
#endif
}
else if (op == Ocall || op == Omod_call) // short
{
if (0 == fread(buf, 2, 1, f))
aborteof(aS("put struc 4"));
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
#ifdef BUG_LINK
fprintf(lout, " short(call/mod_call) = %d", (int) getint16(buf));
#endif
}
// else no 3rd arg
break;
case Ounify_con:
read_const(f, pFtarg, &init_pos);
break;
case Oswitch_on_term:
if (0 == fread(buf, 2, 3, f)) // lab1, lab2, lab3
aborteof(aS("switch on term"));
init_pos += 6;
ucFWRITE(buf, 2, 3, pFtarg);
#ifdef BUG_LINK
for (i=0; i<3; i++)
fprintf(lout, " %d ",(int) getint16(buf + 2 * i));
#endif
break;
case Oswitch_on_cons: // short size, (size x |CELL|LABEL|)
if (0 == fread(buf, 2, 1, f))
aborteof(aS("switch on cons"));
ucFWRITE(buf, 2, 1, pFtarg);
x = getint16(buf);
init_pos += 2;
while(x--)
{
read_const(f, pFtarg, &init_pos); // get const
if (0 == fread(buf, 2, 1, f)) // branch label
aborteof(aS("switch on cons 2"));
#ifdef BUG_LINK
fprintf(lout, " branch[%d] ", (int) getint16(buf));
#endif
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2;
}
break;
case Oswitch_on_struc: // short size, (size x |NAME|ARITY|LABEL|)
if (0 == fread(buf, 2, 1, f))
aborteof(aS("switch on struc"));
ucFWRITE(buf, 2, 1, pFtarg);
x = getint16(buf);
init_pos += 2;
while(x--)
{
read_atom(f, pFtarg);
if (0 == fread(buf, 2, 1, f)) // arity
aborteof(aS("switch on struc 2"));
ucFWRITE(buf, 2, 1, pFtarg);
if (0 == fread(buf, 2, 1, f)) // label
aborteof(aS("switch on struc 2"));
#ifdef BUG_LINK
fprintf(lout, " branch[%d] ", (int) getint16(buf));
#endif
ucFWRITE(buf, 2, 1, pFtarg);
init_pos += 2 + 2 + 2;
}
break;
default:
abort_linker(aS("Error: Bad opcode in CodeStream %d"), op);
}
#ifdef BUG_LINK
fprintf(lout, "\nend length %d init_pos %d ", length, init_pos);
#endif
}
return(1);
}
/* ----- Includes -------------------------------------------------------- */
#include "inc.h"
#include "pch.h"
#if defined(DOS) && defined(P16)
#include <conio.h>
#endif
/* ----- Internal definitions -------------------------------------------- */
#ifdef LANDFILL
aCHAR * ops[] =
{
/* 0 */ aS("no_op"),
/* 1 */ aS("get_con"),
/* 2 */ aS("get_nil"),
/* 3 */ aS("get_struc"),
/* 4 */ aS("get_list"),
/* 5 */ aS("put_unsafe"),
/* 6 */ aS("put_con"),
/* 7 */ aS("put_nil"),
/* 8 */ aS("put_struct"),
/* 9 */ aS("put_list"),
/* 10 */ aS("call"),
/* 11 */ aS("proceed"),
/* 12 */ aS("exec"),
/* 13 */ aS("escape"),
/* 14 */ aS("alloc"),
/* 15 */ aS("dealloc"),
void Linker::aborteof(aCHAR * s)
{
abort_linker(aS("Error: Unexpected end-of-file reading %s"), s);
}
inline bool Quick_ZHay<Tprec, Dim>::calcCoefficients3D () {
prec_t dyz = dy * dz, dyz_dx = Gamma * dyz / dx;
prec_t dxz = dx * dz, dxz_dy = Gamma * dxz / dy;
prec_t dxy = dx * dy, dxy_dz = Gamma * dxy / dz;
prec_t dxyz_dt = dx * dy * dz / dt;
prec_t ce, cem, cep, cw, cwm, cwp, CE, CW;
prec_t cn, cnm, cnp, cs, csm, csp, CN, CS;
prec_t cf, cfm, cfp, cb, cbm, cbp, CF, CB;
aE = 0.0; aW = 0.0; aN = 0.0; aS = 0.0; aF = 0.0; aB = 0.0; aP = 0.0;
sp = 0.0;
for (int k = bk; k <= ek; ++k)
for (int i = bi; i <= ei; ++i)
for (int j = bj; j <= ej; ++j)
{
CE = ce = ( u(i ,j ,k) + u(i ,j+1,k ) ) * 0.5 * dyz;
CW = cw = ( u(i-1,j ,k) + u(i-1,j+1,k ) ) * 0.5 * dyz;
CN = cn = ( v(i ,j ,k) + v(i+1,j ,k ) ) * 0.5 * dxz;
CS = cs = ( v(i ,j-1,k) + v(i+1,j-1,k ) ) * 0.5 * dxz;
CF = cf = ( w(i ,j ,k) + w(i ,j ,k+1) ) * 0.5 * dxy;
CB = cb = ( w(i ,j ,k) + w(i ,j ,k-1) ) * 0.5 * dxy;
cem = cep = 0.0;
cwm = cwp = 0.0;
cnm = cnp = 0.0;
csm = csp = 0.0;
cfm = cfp = 0.0;
cbm = cbp = 0.0;
// QUICK as presented in Hayase et al.
// ---- X
if ( ce > 0 ) {
CE = 0;
if (i == bi) {
cep = ce * (phi_0(i+1,j,k) - phi_0(i-1,j,k)) / 3.0;
} else {
cep = ce * 0.125 * (-phi_0(i-1,j,k) - 2*phi_0(i,j,k) + 3*phi_0(i+1,j,k));
}
} else {
// The case i == ei is taken in to account in applyBoundaryConditions3D.
if (i == ei-1) {
cem = ce * (phi_0(i+2,j,k) - phi_0(i,j,k)) / 3.0;
} else if (i < ei-1) {
cem = ce * 0.125 * (-phi_0(i+2,j,k) - 2*phi_0(i+1,j,k) + 3*phi_0(i,j,k));
}
}
if ( cw > 0 ) {
// The case i == bi is taken in to account in applyBoundaryConditions3D.
if (i == bi+1) {
cwp = cw * (phi_0(i,j,k) - phi_0(i-2,j,k)) / 3.0;
} else if (i > bi+1) {
cwp = cw * 0.125 * (-phi_0(i-2,j,k) - 2*phi_0(i-1,j,k) + 3*phi_0(i,j,k));
}
} else {
CW = 0;
if (i == ei) {
cwm = cw * (phi_0(i-1,j,k) - phi_0(i+1,j,k)) / 3.0;
} else {
cwm = cw * 0.125 * (-phi_0(i+1,j,k) - 2*phi_0(i,j,k) + 3*phi_0(i-1,j,k));
}
}
// ---- Y
if ( cn > 0 ) {
CN = 0;
if (j == bj) {
cnp = cn * (phi_0(i,j+1,k) - phi_0(i,j-1,k)) / 3.0;
} else {
cnp = cn * 0.125 * (-phi_0(i,j-1,k) - 2*phi_0(i,j,k) + 3*phi_0(i,j+1,k));
}
} else {
if (j == ej-1) {
cnm = cn * (phi_0(i,j+2,k) - phi_0(i,j,k)) / 3.0;
} else if (i < ei-1) {
cnm = cn * 0.125 * (-phi_0(i,j+2,k) - 2*phi_0(i,j+1,k) + 3*phi_0(i,j,k));
}
}
if ( cs > 0 ) {
if (j == bj+1) {
csp = cs * (phi_0(i,j,k) - phi_0(i,j-2,k)) / 3.0;
} else if (j > bj+1) {
csp = cs * 0.125 * (-phi_0(i,j-2,k) - 2*phi_0(i,j-1,k) + 3*phi_0(i,j,k));
}
} else {
CS = 0;
if (j == ej) {
csm = cs * (phi_0(i,j-1,k) - phi_0(i,j+1,k)) / 3.0;
} else {
csm = cs * 0.125 * (-phi_0(i,j+1,k) - 2*phi_0(i,j,k) + 3*phi_0(i,j-1,k));
}
}
// ---- Z
if ( cf > 0 ) {
CF = 0;
cfp = cf * 0.125 * (-phi_0(i,j,k-1) - 2*phi_0(i,j,k) + 3*phi_0(i,j,k+1));
} else {
if (k == ek) {
cfm = cf * 0.125 * (-5*phi_0(i,j,k+1) + 6*phi_0(i,j,k) - phi_0(i,j,k-1));
} else {
cfm = cf * 0.125 * (-phi_0(i,j,k+2) - 2*phi_0(i,j,k+1) + 3*phi_0(i,j,k));
}
}
if ( cb > 0 ) {
if (k == bk) {
cbp = cb * 0.125 * (-5*phi_0(i,j,k-1) + 6*phi_0(i,j,k) - phi_0(i,j,k+1));
} else {
cbp = cb * 0.125 * (-phi_0(i,j,k-2) - 2*phi_0(i,j,k-1) + 3*phi_0(i,j,k));
}
} else {
CB = 0;
cbm = cb * 0.125 * (-phi_0(i,j,k+1) - 2*phi_0(i,j,k) + 3*phi_0(i,k,k-1));
}
aE (i,j,k) = dyz_dx - CE;
aW (i,j,k) = dyz_dx + CW;
aN (i,j,k) = dxz_dy - CN;
aS (i,j,k) = dxz_dy + CS;
aF (i,j,k) = dxy_dz - CF;
aB (i,j,k) = dxy_dz + CB;
aP (i,j,k) = aE (i,j,k) + aW (i,j,k) + aN (i,j,k) + aS (i,j,k)
+ aF (i,j,k) + aB (i,j,k) + dxyz_dt
+ (ce - cw) + (cn - cs) + (cf - cb);
sp(i,j,k) = w(i,j,k) * dxyz_dt -
( p(i,j,k+1)- p(i,j,k) ) * dxy
- (cep + cem - cwp - cwm +
cnp + cnm - csp - csm +
cfp + cfm - cbp - cbm);
}
calc_dw_3D();
applyBoundaryConditions3D();
return 0;
}
suppl_log_stack_t suppl_stack1 = {
0 /* no next item */
, /* files to be logged */
{ 0
, { '-', '\0' }
}
, /* classes to be logged */
{ 0
, { '-', '\0' }
}
, /* functions to be logged */
{ 0
, { '-', '\0' }
}
,INT_MAX /* maximum nesting level */
,0 /* logging active? */
,1 /* indent output? */
,1 /* 'files' member NOT inherited */
,1 /* 'classes' member NOT inherited */
,1 /* 'functions' member NOT inherited */
};
suppl_log_stack_t *suppl_Stack = aS(suppl_stack1);
int suppl_l_nestlevel = 0; /* current nesting level */
FLAG suppl_l_fct_enabled = 0; /* function class permits logging */
FILE *suppl_l_logfile = 0; /* logfile opened? */
char suppl_l_openmode[] = "wt"; /* openmode for the logfile
first character must be w/a */
long suppl_l_count = 0; /* line counter */
void Linker::read_g_atoms(FILE* f, int filei)
{ // Build the Global atom table
aUINT16 atom_table_length, code_length;
short posn;
aCHAR buf[TERM_BUFSIZE], *p;
int ichar;
aBYTE type, version, build;
if (0 == fread(&type, 1, 1, f)) // 0
aborteof(aS("header"));
if (type != 0xFF)
abort_linker(aS("Error: File is not an Amzi! Prolog object file (.PLM)"));
if (0 == fread(&type, 1, 1, f)) // 1
aborteof(aS("header"));
if (0x03 != (type & 0x03))
abort_linker(aS("Error: File is not an Amzi! Prolog object file (.PLM)"));
if (type & 0x10)
isunicode = LTRUE;
else
isunicode = LFALSE;
if (0 == fread(&version, 1, 1, f)) // 1
aborteof(aS("header"));
if (version < COMPATIBLE_VERSION)
abort_linker(aS("Error: Out-of-date .PLM file needs to be recompiled"));
if (0 == fread(&build, 1, 1, f)) // 1
aborteof(aS("header"));
if (version == COMPATIBLE_VERSION && build < COMPATIBLE_BUILD)
abort_linker(aS("Error: Out-of-date .PLM file needs to be recompiled"));
fseek(f, CC_HEAD_LENGTH, SEEK_SET); // 8 skip header
while(LTRUE) // for each atomtable / code segment sequence
{
if (!read_uint16(&atom_table_length, f) || // 8
atom_table_length == 0)
return; // all done
if (isunicode)
atom_table_length = atom_table_length / 2;
posn = 0;
while (posn < atom_table_length) // read atom table
{
p = buf;
do
{
if ( p >= (buf + TERM_BUFSIZE))
{
//buf[511] = EOS;
//Lprintf(aS("%d %d %d %d"), buf[0], buf[1], buf[2], buf[3]);
abort_linker(aS("Error: Global atom too long in code"));
}
if (EOF == (ichar = ISUNIGETC(f))) // read chars
aborteof(aS("global atom table"));
++posn;
}
while((*p++ = (aCHAR) ichar) != 0); // until null char
//Lprintf(aS("atom = '%s'\n"), buf);
EnterGAtom(buf, filei);
}
if (!read_uint16(&code_length, f)) // 10 get code seg length
aborteof(aS("code segment length"));
fseek(f, (long) code_length, SEEK_CUR); // and seek past it
}
}
void disp_msg(aCHAR * msg)
{
wcscat(MsgBuf, msg);
wcscat(MsgBuf, aS("\n"));
}
/*
* Class: amzi_ls_ARulesLogicServer
* Method: Link
* Signature: (Ljava/lang/String;[Ljava/lang/String;Ljava/lang/String;)I
*/
JNIEXPORT jint JNICALL Java_amzi_ls_ARulesLogicServer_Link
(JNIEnv * jenv, jobject jobj, jstring jxpl, jobjectArray jplms, jstring joptions)
{
#if defined(_WINDOWS)
//wcscpy(MsgBuf, aS("Link not implemented yet"));
//return -1;
// HINSTANCE m_hLinkDLL;
// pfLINK m_pfL;
clear_msg();
/* m_hLinkDLL = LoadLibraryExA("alnk.dll", NULL, 0);
if (m_hLinkDLL != NULL)
{
m_pfL = (pfLINK)GetProcAddress(m_hLinkDLL, "cpLinkW");
if (m_pfL == NULL)
{
wsprintf(MsgBuf, aS("Unable to find Linker entry point: %d"), GetLastError());
return -2;
}
}
else
{
m_pfL = NULL;
wsprintf(MsgBuf, aS("Unable to load Linker library: %d"), GetLastError());
return -3;
}
*/
jsize jlen, ji;
int i, argctr;
aCHAR * pargv[128];
jobject jplm;
pargv[0] = JtoC(jenv, jxpl);
pargv[1] = new aCHAR[1 + wcslen(aS("alib.plm"))];
wcscpy(pargv[1], aS("alib.plm"));
jlen = jenv->GetArrayLength(jplms);
argctr = jlen + 2;
for (ji=0; ji<jlen; ji++)
{
jplm = jenv->GetObjectArrayElement(jplms, ji);
i = ji + 2;
pargv[i] = JtoC(jenv, (jstring)jplm);
}
// Call the linker with the list of files to link
// int rc = (*m_pfL)(disp_msg, argctr, (aCHAR **)pargv);
int rc = aLinkW(disp_msg, argctr, (aCHAR **)pargv);
for (i=0; i<argctr; i++)
delete pargv[i];
// FreeLibrary(m_hLinkDLL);
//wsprintf(MsgBuf, aS("Link successful"));
return rc;
#else
jsize jlen, ji;
int i, argctr;
aCHAR * pargv[128];
jobject jplm;
pargv[0] = JtoC(jenv, jxpl);
pargv[1] = new aCHAR[1 + wcslen(aS("alib.plm"))];
wcscpy(pargv[1], aS("alib.plm"));
jlen = jenv->GetArrayLength(jplms);
argctr = jlen + 2;
for (ji=0; ji<jlen; ji++)
{
jplm = jenv->GetObjectArrayElement(jplms, ji);
i = ji + 2;
pargv[i] = JtoC(jenv, (jstring)jplm);
}
// Call the linker with the list of files to link
int rc = aLinkW(disp_msg, argctr, (aCHAR **)pargv);
for (i=0; i<argctr; i++)
delete pargv[i];
return rc;
// wcscpy(MsgBuf, aS("Link not implemented yet"));
// return -1;
#endif
}
void Linker::read_linked_segs(FILE * f, aUINT16 atom_table_length,
FILE * pFtarg, int filei)
{ // reads the linked segments for one PROCEDURE
aINT32 proc_code_length;
aUINT16 clause_code_length;
CODE buf[6];
aUINT16 last_clause, first_clause;
aINT32 start_of_proc, end_of_proc; // changed from long
aINT16 zero = 0;
char op;
start_of_proc = ftell(pFtarg);
/* build the procedure prefix segment
proc_code_length
name
arity
*/
read_l_atoms(f, atom_table_length, filei); // Read the local atom table
if (!read_uint16(&clause_code_length, f)) // code length
aborteof(aS("linked segment length"));
#ifdef BUG_LINK
fprintf(lout, "clause_length = %u, local_atom_table_length = %u\n", clause_code_length, atom_table_length);
#endif
// ucFWRITE(&zero, sizeof(aINT16), 1, pFtarg); // reserve this
// ucFWRITE(&zero, sizeof(intC), 1, pFtarg); // reserve this ray
ucFWRITE(&zero, sizeof(aINT32), 1, pFtarg); // no ray, should be int32, intC might be 64
if (!read_uint16(&last_clause, f)) // last clause marker
aborteof(aS("linked segment clause marker"));
read_atom(f, pFtarg); // functor
if (0 == fread(buf, sizeof(aINT16), 1, f)) // arity
aborteof(aS("linked segment arity"));
ucFWRITE(buf, 2, 1, pFtarg);
proc_code_length = clause_code_length - 2; // size of first clause
/*
There is no last clause marker in the created prefix segment
so subtract this off
*/
first_clause = 1;
while (1)
{ // We are now at the code
#ifdef BUG_LINK
fprintf(lout, "\nNext clause");
#endif
if (first_clause)
{
first_clause = 0;
fread(&op, sizeof(aBYTE), 1, f); // see if switch is active
if (op == Ono_switch)
{
#ifdef xBUG_LINK
fprintf(lout, "\nno switch");
#endif
fseek(f, 6L, SEEK_CUR); // skip the remaining labels
clause_code_length -= 7;
proc_code_length -= 7;
fread(&op, sizeof(aBYTE), 1, f); // now look at try_me_else
if (op == Ono_try)
{
#ifdef xBUG_LINK
fprintf(lout, "\nno try_me_else");
#endif
clause_code_length -= 5;
proc_code_length -= 5;
fseek(f, 4L, SEEK_CUR); // skip label and NTV
}
else
fseek(f, -1L, SEEK_CUR); // get back to the try_me
}
else
fseek(f, -1L, SEEK_CUR); // get back to first op code
}
read_code(f, pFtarg, PLM_CLHEAD_L, clause_code_length, (aBYTE*) buf);
if (last_clause) // was last clause
break;
if (!read_uint16(&atom_table_length, f))
aborteof(aS("linked atom table length"));
read_l_atoms(f, atom_table_length, filei);
if (!read_uint16(&clause_code_length, f))
aborteof(aS("linked clause length"));
#ifdef BUG_LINK
fprintf(lout, "clause_length = %d\n", clause_code_length);
#endif
/* We don't include junk in prefix as part of length
after the first clause (we only have ONE name, arity etc) */
proc_code_length += clause_code_length - PLM_CLHEAD_L;
if (!read_uint16(&last_clause, f))
aborteof(aS("linked last clause"));
fseek(f, 4L, SEEK_CUR); // skip Name, ARITY
}
#ifdef BUG_LINK
fprintf(lout, "\n ----- end of predicate ----- \n");
#endif
// seek back to fill in proc_size & proc length
end_of_proc = ftell(pFtarg);
fseek(pFtarg, start_of_proc, SEEK_SET);
#ifdef BUG_LINK
fprintf(lout, "proc_length = %d\n", proc_code_length);
#endif
write_int32(proc_code_length, pFtarg);
fseek(pFtarg, end_of_proc, SEEK_SET);
}
void cElHJaPlan3D::Show
(
Video_Win aW,
INT aCoul,
bool ShowDroite,
bool ShowInterEmpr
)
{
if (aCoul >=0)
ELISE_COPY(aW.all_pts(),aCoul,aW.ogray());
Box2dr aBoxW(Pt2dr(0,0),Pt2dr(aW.sz()));
for (INT aK=0; aK<INT(mVInters.size()) ; aK++)
{
cElHJaDroite * aDr =mVInters[aK];
if (aDr)
{
ElSeg3D aSeg = aDr->Droite();
Pt3dr aQ0 = aSeg.P0();
Pt3dr aQ1 = aSeg.P1();
Pt2dr aP0(aQ0.x,aQ0.y);
Pt2dr aP1(aQ1.x,aQ1.y);
Seg2d aS(aP0,aP1);
Seg2d aSC = aS.clipDroite(aBoxW);
if (ShowDroite && (! aSC.empty()))
{
aW.draw_seg(aSC.p0(),aSC.p1(),aW.pdisc()(P8COL::magenta));
}
}
}
tFullSubGrPl aSGrFul;
if (ShowInterEmpr)
{
for (tItSomGrPl itS=mGr->begin(aSGrFul) ; itS.go_on() ; itS++)
{
aW.draw_circle_loc
(
(*itS).attr().Pt(),
4.0,
aW.pdisc()(P8COL::blue)
);
for (tItArcGrPl itA=(*itS).begin(aSGrFul) ; itA.go_on() ; itA++)
{
tSomGrPl &s1 = (*itA).s1();
tSomGrPl &s2 = (*itA).s2();
if (&s1 < &s2)
{
aW.draw_seg
(
s1.attr().Pt(),
s2.attr().Pt(),
aW.pdisc()(P8COL::black)
);
}
}
}
}
// for (INT aK=0 ; aK<INT(mFacOblig.size()) ; aK++)
// mFacOblig[aK]->Show(PI/2.0,P8COL::cyan,false);
}
void Linker::read_const(FILE *f, FILE *pFtarg, long *pi)
{
/* a constant is a tag followed by constant data
tag = 1 -> constant is short atom
tag = 2 -> constant is short int
tag = 3 -> constant is arb string terminated by EOS
tag = 4 -> constant is 4 byte float
tag = 5 -> constant is 4 byte long
tag = 6 -> constant is 4 byte long wide char
tag = 7 -> constant is 8 byte double
tag = 8 -> constant is real
*/
aBYTE buf[8];
int ccount;
aBYTE ibyte;
aINT16 temp, length;
aINT32 temp32;
aCHAR ichar;
if (0 == fread(buf, 1, 1, f))
aborteof(aS("read const"));
ucFWRITE(buf, 1, 1, pFtarg);
(*pi) += 1;
switch(*buf)
{
case 1:
read_atom(f, pFtarg);
(*pi) += 2;
break;
case 2:
if (0 == fread(buf, 2, 1, f))
aborteof(aS("read const 2"));
ucFWRITE(buf, 2, 1, pFtarg);
(*pi) += 2;
break;
case 3: // single byte string
ccount = 1;
if (0 == fread(&ibyte, 1, 1, f))
aborteof(aS("read const 3"));
ichar = (aCHAR)ibyte;
while(ichar)
{
++ccount;
ucFWRITE(&ichar, 1, 1, pFtarg);
if (0 == fread(&ibyte, 1, 1, f))
aborteof(aS("read const 3b"));
ichar = (aCHAR)ibyte;
}
ucFWRITE(&ichar, 1, 1, pFtarg);
(*pi) += ccount*sizeof(char);
break;
case 4: // float
if (0 == fread(buf, 4, 1, f))
aborteof(aS("read const 4"));
ucFWRITE(buf, 4, 1, pFtarg);
(*pi) += 4;
break;
case 5: // long
if (0 == fread(buf, 4, 1, f))
aborteof(aS("read const 5"));
ucFWRITE(buf, 4, 1, pFtarg);
(*pi) += 4;
break;
case 6: // wide character string
ccount = 1;
// if (0 == fread(&ichar, sizeof(aCHAR), 1, f))
if (!read_int16(&temp, f))
aborteof(aS("read const 3"));
while(temp)
{
++ccount;
// ucFWRITE(&ichar, sizeof(aCHAR), 1, pFtarg);
write_int16(temp, pFtarg);
// if (0 == fread(&ichar, sizeof(aCHAR), 1, f))
if (!read_int16(&temp, f))
aborteof(aS("read const 3b"));
}
// fwrite(&ichar, sizeof(aCHAR), 1, pFtarg);
write_int16(temp, pFtarg);
(*pi) += ccount*2;
break;
case 9: // fixed
case 7: // C double
if (0 == fread(buf, 8, 1, f))
aborteof(aS("read const 7"));
ucFWRITE(buf, 8, 1, pFtarg);
(*pi) += 8;
break;
case 8:
for(ccount = 0; ccount < 6; ccount += 2)
{ // copy the real descr
if (!read_int16(&temp, f))
aborteof(aS("read const 3"));
if(ccount == 0)
length = temp; // length
write_int16(temp, pFtarg);
}
while(length)
{ // copy the gigits
if (!read_int32(&temp32, f))
aborteof(aS("read const 3b"));
write_int32(temp32, pFtarg);
ccount+= 4;
length--;
}
(*pi) += ccount;
} // end switch
}
