/* GetFileTypeName - return the text corresponding to the file type
*
* GetFileTypeName takes the file type as set in the file structure of the
* current file and returns the textual string corresponding to that type.
*
* returns character pointer to the type-specific text
*/
char *
GetFileTypeName (
void
) {
if (TESTFLAG (FLAGS (pFileHead),FAKE)) {
return "pseudo";
}
return mpTypepName[FTYPE (pFileHead)];
}
/* GetCurUsage()
* ======================================================================
* Get the current Speedo Data Cache Usage.
*/
long
GetCurUsage( void )
{
FON_PTR curptr;
int i;
long Used;
int icount;
/* Get the Fixed amount - always have this...*/
Used = FONTP_ACTUAL;
/* Get the per font allocation */
icount = CountFonts( installed_list, SPD_FONT );
Used += (long)icount * ( FSMHEADER + ARB_PTSBLK );
/* Get the per pointsize per font allocation. */
curptr = installed_list;
while( curptr )
{
if( FTYPE( curptr ) == SPD_FONT )
{
for( i=0; i < MAX_POINTS; i++ )
{
if( POINTS( curptr )[i] )
{
if( Current.Width )
Used += WIDTH_TABLE_DATA;
Used += THE_PTSBLK;
}
else
break;
}
}
curptr = FNEXT( curptr );
}
Used += ( GetFontMin() + GetCharMin() );
/* Make sure we ALWAYS have at least 10K */
if( Used < 10240L )
Used = 10240L;
Used /= 1024L;
return( Used );
}
/* SetFileType - set the file type of a file based upon its extension
*
* pFile pointer to file whose type will be determined
*/
void
SetFileType (
PFILE pFile
) {
pathbuf fext;
REGISTER int i;
extention (pFile->pName, fext);
for (i = 0; ftypetbl[i].ext; i++) {
if (!strcmp (ftypetbl[i].ext, (char *)&fext[1])) {
break;
}
}
FTYPE(pFile) = ftypetbl[i].ftype;
}
void image(int image_cnt, int which, int scale, int limits)
{
int i = 0, j = 0, l = 0, col = 0;
FILE *fp;
char ifnam[MAXFILENAME];
// which : which primitive variable
SFTYPE pr,iq, liq, aa, lmax, lmin;
FTYPE X[NDIM],r,th;
FTYPE min,max,sum;
FTYPE minptr[NPR], maxptr[NPR], sumptr[NPR];
int jonhead;
#if(USEMPI)
void *jonio;
int ndims, array_of_gsizes[4], array_of_distribs[4];
int order, len;
int array_of_dargs[4], array_of_psizes[4];
int bufcount, array_size;
#endif
void *writebuf;
unsigned char *realbuf;
char truemyidtxt[MAXFILENAME];
FTYPE (*pimage)[N2+4][NPR];
////////////////////////////
//
// Image output setup/definition
//
////////////////////////////
pimage=ph;
if(limits==ZOOM){
ZLOOP{
if(which<=1){
coord(i,j,CENT,X);
bl_coord(X,&r,&th);
if(which==0) pimage[i][j][which]=p[i][j][which]/(RHOMIN*pow(r,-1.5));
if(which==1) pimage[i][j][which]=p[i][j][which]/(UUMIN*pow(r,-2.5));
}
else{
if(scale==LINEAR) pimage[i][j][which]=p[i][j][which];
else if(scale==LOG) pimage[i][j][which]=fabs(p[i][j][which])+MINVECTOR;
}
}
}
// used to make WENO work better in contact
// works well as setup for isolated stationary and moving contact and blast wave, but problem for TESTNUMBER==4 contact compared to MCSTEEP,PARALINE,PARAFLAT still -- should look at etai's at late time in contact to see why -- maybe shock not flat enough
// GODMARK: If parafrac==0, then must behave *exactly* like weno would have!
int paraprocess_line_c2e( int whichquantity, int dir, int do_weight_or_recon, weno_weights_t *stencil_weights_array, int whichreduce, int preforder, int pl, int bs, int ps, int pf, int bf, int *minorderit, int *maxorderit, int *shiftit,
FTYPE *shockindicator, FTYPE *stiffindicator, FTYPE *parafrac, FTYPE *V, FTYPE *P, FTYPE (*df)[NBIGM],
FTYPE (*dP)[NBIGM], FTYPE *etai, FTYPE (*monoindicator)[NBIGM],
FTYPE *Pindicator, FTYPE *yin, FTYPE *yout_left, FTYPE *yout_right, struct of_trueijkp *trueijkp )
{
extern void paracont(FTYPE ddq, FTYPE *y, FTYPE *facecont);
extern void parasteepgen(int pl, FTYPE etai, FTYPE *V, FTYPE *P, FTYPE *y, FTYPE *dq, FTYPE *l, FTYPE *r);
extern void paraflatten(int dir, int pl, FTYPE *y, FTYPE Fi, FTYPE *l, FTYPE *r);
extern void checkparamonotonicity(int smooth, int dqrange, int pl, FTYPE *y, FTYPE *ddq, FTYPE *dq, FTYPE *lin, FTYPE *rin, FTYPE *lout, FTYPE *rout);
void jonparasmooth_compute(int realisinterp, int dqrange, int pl, FTYPE *y, FTYPE *dq1, FTYPE *dq2, FTYPE *lout, FTYPE *rout, int *smooth);
FTYPE a_face[2][NBIGM];
FTYPE (*face)[NBIGM];
int i;
int dqrange;
int odir1,odir2;
FTYPE parafraclocal;
FTYPE monofrac;
FTYPE truelowerorderfraction;
FTYPE myetai,myshock;
int mm;
FTYPE mymono;
FTYPE leftmc,rightmc;
FTYPE leftweno,rightweno;
int smooth;
//////////////////////
//
// for now only apply to density (only works if don't introduce switching effects between para and weno, and switching seems to be avoided if use para within -3..3 of contact since WENO is then removed from reaching into contact
//
/////////////////////
#if(FULLHYBRID==0)
if(pl!=RHO) return(0);
#endif
// stencil_weights_array[i].lower_order_fraction;
// Still have this local file-global quantity, so let's perform extra PARA-like operations here
// pointer shift
face=(FTYPE (*)[NBIGM]) (&(a_face[0][NBIGBND]));
// define orthogonal directions for field steepening
odir1=dir%3+1;
odir2=(dir+1)%3+1;
//////////////////////////////
//
// copy over WENO result since will only use PARA modifications if reduced to WENO3
//
/////////////////////////////
#if(0)// choose weno as base for lower order
for( i = ps; i <= pf; i++ ) {
face[0][i]=yout_left[i];
face[1][i]=yout_right[i];
}
#elif(1) // choose para as base for lower order
for( i = ps; i <= pf+1; i++ ) {
paracont(df[DF2OFMONO][i], &yin[i], &face[0][i]);
}
// default left and right states
// 1 input and 2 outputs
for( i = ps-1; i <= pf; i++ ) {
// left from y[i]
// yout_left[i]=face[0][i];
// right from y[i]
// yout_right[i]=face[1][i]=face[0][i+1];
face[1][i]=face[0][i+1];
}
#elif(0)// choose weno as base for lower order
// MC also doesn't work?
for( i = ps; i <= pf; i++ ) {
face[0][i]= yin[i] - 0.5*df[DFMONO][i];
face[1][i]= yin[i] + 0.5*df[DFMONO][i];
}
#endif
//dqrange=preforder-2;
dqrange=5;
// default left and right states
// 1 input and 2 outputs
for( i = ps; i <= pf; i++ ) {
#if(JONPARASMOOTH)
int realisinterp=1; // assume not big deal
jonparasmooth_compute(realisinterp,dqrange,pl,&yin[i],&df[DFONESIDED][i],&df[DFCENT][i],&face[0][i],&face[1][i],&smooth);
#else
smooth=0;
#endif
#if(DOPPMCONTACTSTEEPMODWENO)
#if(CONTACTINDICATOR==0)
#error If Steepen in paraline, must turn on CONTACTINDICATOR
#endif
if(smooth==0) parasteepgen(pl,etai[i],&V[i],&P[i],&yin[i],&df[DFMONO][i],&face[0][i],&face[1][i]);
#endif
#if( DOPPMREDUCEMODWENO )
paraflatten(dir,pl,&yin[i],shockindicator[i],&face[0][i],&face[1][i]);
#endif
#if(1)
// was checking only para result
checkparamonotonicity(smooth, dqrange, pl, &yin[i], &df[DF2OFMONO][i], &df[DFMONO][i],&face[0][i],&face[1][i],&face[0][i],&face[1][i]);
#endif
// now see if want to use MONO result and combine with para result
// doesn't seem to help moving Gresho
#if(1)
mymono=min(max(monoindicator[MONOINDTYPE][i],0.0),1.0);
// modify PARA result using MONO if monoindicator>0
face[0][i] = face[0][i] * (1.0-mymono) + yout_left[i] * mymono;
face[1][i] = face[1][i] * (1.0-mymono) + yout_right[i] * mymono;
#endif
// now merge WENO and PARA result based upon lower order fraction
// if(etai>=0.01) etai=1.0;
// if(pl==RHO){
// dualfprintf(fail_file,"i=%d etai=%21.15g\n",i,etai);
// }
// parafraclocal = etai;
//parafraclocal=1.0;
// GODMARK: Unsure if lower order fraction accounts for MONO
#if(FULLHYBRID==0)
myetai=0;
myshock=0;
// seem to require -3..3 for blast wave to avoid WENO smearing of contact
for(mm=-3;mm<=3;mm++){
myetai=max(myetai,etai[i+mm]);
myshock=max(myshock,shockindicator[i+mm]);
}
monofrac = min(max(monoindicator[MONOYIN][i],0.0),1.0);
// monofrac=0.0;
truelowerorderfraction = (stencil_weights_array[i].lower_order_fraction)*(1.0-monofrac);
// truelowerorderfraction = (1.0-monofrac);
//parafraclocal = (1.0-monofrac)*(1.0-myshock)*myetai;
//(1.0-monofrac)*(1.0-myshock)*
// myetai=1.0;
// parafraclocal = min(max(1.5*myetai,0.0),1.0);
// use para if ANY indication that contact is near
// 2.0*myetai seems to work fine once set range to be -3..3
parafraclocal = min(max(2.0*myetai,0.0),1.0);
// parafraclocal = min(max(max(2.0*myetai,myshock),0.0),1.0);
// don't use para if in stiff regime since WENO more robust
parafraclocal = parafraclocal*(1.0-stiffindicator[i]);
// if(pl==RHO) parafraclocal=1.0;
// don't use para if doing higher order WENO
// parafraclocal = min(parafraclocal,truelowerorderfraction);
// below doesn't work (generates spike at contact) probably because need some monoindicator across all quantities so para or weno used consistently for all quantities in contact
// parafraclocal = min(parafraclocal,(1.0-monofrac));
//dualfprintf(fail_file,"i=%d etai=%21.15g myetai=%21.15g\n",i,etai[i],myetai);
// parafraclocal = min(max(truelowerorderfraction,2.0*etai[i]),1.0);
// parafraclocal = min(1.0*max(max(truelowerorderfraction,etai),0.0),1.0);
// parafraclocal = min(1.0*max(10.0*etai,0.0),1.0);
//parafraclocal = min(max(1.0*max(truelowerorderfraction,1.1*etai),0.0),1.0);
//parafraclocal = min(max(1.0*max(truelowerorderfraction,1.1*etai),0.0),1.0);
// parafraclocal = 1.0;
// parafraclocal = min(max(1.0*max(truelowerorderfraction,etai),0.0),1.0);
// if(parafraclocal<0.9) parafraclocal=0.0;
// parafraclocal = min(10.0*max(parafraclocal-0.9,0.0),1.0);
// parafraclocal = min(max(parafraclocal*(parafraclocal-0.1),0.0),1.0);
// if(parafraclocal<0.3) parafraclocal=0;
// parafraclocal=0.98;
// parafraclocal=0.0;
//parafraclocal = min(max(etai,0.0),1.0);
//parafraclocal = 1.0;
//parafraclocal = 1.0;
// GODMARK: DEBUG:
//stencil_weights_array[i].lower_order_fraction=1.0;
#elif(FULLHYBRID==1)
// if not stiff, then speculate with para. If stiff, then stay robust with WENO
// parafraclocal = (1.0-stiffindicator[i]);
// new method that uses para or weno fully and only mixes in middle of stiffindicator
parafraclocal = parafrac[i];
#endif
#if(USEMCFORLOWERORDERWENO)
leftmc = yin[i] - 0.5* df[DFMONO][i];
rightmc = yin[i] + 0.5* df[DFMONO][i];
// flatten MC in shocks
#if( DOPPMREDUCEMODWENO )
paraflatten(dir,pl,&yin[i],shockindicator[i],&leftmc,&rightmc);
#endif
monofrac = min(max(monoindicator[MONOYIN][i],0.0),1.0);
truelowerorderfraction = min(max((stencil_weights_array[i].lower_order_fraction)*(1.0-monofrac),0.0),1.0);
leftweno = yout_left[i] * (1.0-truelowerorderfraction) + leftmc *truelowerorderfraction;
rightweno = yout_right[i] * (1.0-truelowerorderfraction) + rightmc*truelowerorderfraction;
#else
// normal weno
monofrac = min(max(monoindicator[MONOYIN][i],0.0),1.0);
leftweno = yout_left[i];
rightweno = yout_right[i];
#endif
yout_left[i] = leftweno * (1.0-parafraclocal) + face[0][i] * parafraclocal ;
yout_right[i] = rightweno * (1.0-parafraclocal) + face[1][i] * parafraclocal ;
// dualfprintf(fail_file,"nstep=%ld steppart=%d i=%d :: etai=%21.15g myetai=%21.15g parafraclocal=%21.15g :: myshock=%21.15g monofrac=%21.15g truelow=%21.15g \n",nstep,steppart,i,etai[i],myetai,parafraclocal,myshock,monofrac,truelowerorderfraction);
#if(0)
// if using any weno part, then can't modify state so behaves like weno in limit that parafrac==0. Otherwise, e.g., MPI boundaries not consistently computing fluxes
#if(FULLHYBRID==0 || FULLHYBRID==1)
// if(1||parafraclocal>0.01){
if(monofrac<0.1){
// if(parafraclocal>0.01){
// check monotonicity of FINAL result rather than just para result, to ensure monotonic
dqrange=5;
checkparamonotonicity(dqrange, pl, &yin[i], &df[DF2OFMONO][i], &df[DFMONO][i],&yout_left[i],&yout_right[i],&yout_left[i],&yout_right[i]);
}
#endif
#if( DOPPMREDUCEMODWENO )
// flatten again in case checkparamonotonic is not reducing all the way to DONOR
// causes major problems
// paraflatten(dir,pl,&yin[i],shockindicator[i],&yout_left[i],&yout_right[i]);
#endif
#endif
}// end loop over i
return(0);
}
/* MoveToInstalled()
* ====================================================================
* Move any Available fonts to the Installed List.
* type -> 0 -> USE Available list CALLS
* -> 1 -> Skip available list calls
*/
void
MoveToInstalled( int flag )
{
FON_PTR curptr;
FON_PTR xcurptr;
int index;
curptr = available_list;
/* Try to maintain the top node displayed to remain that way if
* at all possible.
*/
xcurptr = Active_Slit[ 0 ];
if( curptr && xcurptr )
index = Get_Findex( curptr, xcurptr );
/* Go through the list looking for selected nodes ( AFLAG == TRUE )
* and set their SEL() to FALSE.
* Where SEL == TRUE means installed. and SEL == FALSE means
* available.
* Set MakeWidth Tables flag if moving Outline Fonts TO INSTALLED!
*/
while( curptr )
{
if( AFLAG( curptr ) )
{
if( FTYPE( curptr ) == SPD_FONT )
MakeWidthFlag = TRUE;
SEL( curptr ) = TRUE;
}
curptr = FNEXT( curptr );
}
/* Now, fix up the linked list for both the
* available and installed fonts.
*/
free_arena_links();
installed_count = build_list( &installed_list, &installed_last, ACTIVE );
available_count = build_list( &available_list, &available_last, INACTIVE );
/* Prompt to save SYS files */
SetChangeFlag();
if( !flag )
{
mover_setup( available_list, available_count,
IBASE, ISLIDER, IUP, IDOWN,
ILINE0, ILINE13, ILINE, index, INACTIVE_HEIGHT );
RedrawObject( tree, IBASE );
Objc_draw( tree, ILINE, MAX_DEPTH, NULL );
if( !IsDisabled( IINSTALL ) )
ChangeButton( ad_inactive, IINSTALL, FALSE );
if( !IsDisabled( ICONFIG ) )
ChangeButton( ad_inactive, ICONFIG, FALSE );
CheckSelectAll( TRUE );
}
}
// So in the end only pf is modified at each zone, so the loop changing p at previous (i,j) location doesn't affect the any new location in (i,j)
int advance_eno_du(int stage,
FTYPE pi[][N2M][NPR],
FTYPE ulast[][N2M][NPR],
FTYPE pb[][N2M][NPR],
FTYPE *CUf, FTYPE pf[][N2M][NPR],
FTYPE *Cunew, FTYPE unew[][N2M][NPR],
int stagenow, int numstages,
FTYPE *ndt)
{
int i, j, k, sc;
FTYPE ndt1, ndt2;
FTYPE Uf[NPR], Ui[NPR], Ub[NPR], dU[NPR],dUcomp[NUMSOURCES][NPR];
struct of_geom geom;
struct of_state q;
FTYPE dUtot;
FTYPE idx1,idx2;
FTYPE (*dUriemannavg)[N2M][NPR];
FTYPE dUriemann[NPR], dUgeom[NPR];
// FTYPE *dUriemannavg[N2M][NPR];
SFTYPE dt4diag;
void flux2dUavg(int i, int j, FTYPE F1[][N2M][NPR],FTYPE F2[][N2M][NPR],FTYPE *dUavg);
void dUtoU(FTYPE *dUgeom, FTYPE *dUriemann, FTYPE *CUf, FTYPE *Cunew, FTYPE *Ui, FTYPE *ulast, FTYPE *Uf, FTYPE *unew);
dUriemannavg=ua;
// dUriemannavg=(FTYPE (*[N2M][NPR]))(&ua[0][0][0][0]);
// dUriemannavg=(FTYPE *[N2M][NPR])(&ua[2][2][0]);
// tells diagnostics functions if should be accounting or not
if(stagenow==numstages-1) dt4diag=dt; else dt4diag=-1.0;
trifprintf( "#0f");
// pb used here on a stencil, so if pb=pf or pb=pi in pointers, shouldn't change pi or pf yet -- don't currently
MYFUN(fluxcalc(stage, pb, F1, 1, &ndt1),"step_ch.c:advance()", "fluxcalc", 1);
MYFUN(fluxcalc(stage, pb, F2, 2, &ndt2),"step_ch.c:advance()", "fluxcalc", 2);
fix_flux(F1, F2);
flux_ct(stage, F1, F2);
trifprintf( "1f");
// from here on, pi/pb/pf are only used a zone at a time rather than on a stencil
/** now update pi to pf **/
// get dU^{n+1}
CZLOOP flux2dUavg(i,j,F1,F2,dUriemannavg[i][j]);
// get U^{n+1}
CZLOOP {
/////////////
//
// Utoprim as initial conditions : can't assume want these to be same in the end, so assign
//
////////////
PLOOP pf[i][j][k] = pi[i][j][k];
// initialize ulast and unew if very first time here
if(stagenow==0) PLOOP ulast[i][j][k]=unew[i][j][k]=0.0;
// set geometry for centered zone to be updated
get_geometry(i, j, CENT, &geom);
// find Ui(pi)
MYFUN(get_state(pi[i][j], &geom, &q),"step_ch.c:advance()", "get_state()", 1);
MYFUN(primtoU(pi[i][j], &q, &geom, Ui),"step_ch.c:advance()", "primtoU()", 1);
// find dU(pb)
MYFUN(source(pb[i][j], &geom, i, j, dUcomp, dUgeom, CUf[2]),"step_ch.c:advance()", "source", 1);
diag_source(i,j,dUcomp,dt4diag);
//convert to cell centered ones
a2cij(1,i,j,dUriemannavg, dUriemann );
dUtoU(dUgeom, dUriemann, CUf, Cunew, Ui, ulast[i][j], Uf, unew[i][j]);
// invert U->p (but do conversion from averages to cell-centered quantities first!)
if(stagenow==numstages-1){ // last call, so unew is cooked and ready to eat!
// instead of unew need to supply cell centered quantities
MYFUN(Utoprimgen(unew[i][j], &geom, pf[i][j]),"step_ch.c:advance()", "Utoprimgen", 1);
}
else{ // otherwise still iterating on primitives
// instead of Uf need to supply cell centered quantities
MYFUN(Utoprimgen(Uf, &geom, pf[i][j]),"step_ch.c:advance()", "Utoprimgen", 1);
}
// immediate local (i.e. 1-zone) fix
#if(FIXUP1ZONE)
MYFUN(fixup1zone(pf[i][j],&geom,dt4diag),"fixup.c:fixup()", "fixup1zone()", 1);
#endif
}
//atch: fixup_zones: removed to avoid any fixup; not the proper way to solve: need a switch rather than
// comment out
//#if(!FIXUP1ZONE)
//fixup(stage,pf,dt4diag);
//#enedif
*ndt = defcon * 1. / (1. / ndt1 + 1. / ndt2);
trifprintf( "2f");
return (0);
}
// boundvartype specifies whether to bound scalar or to bound vector that is only needed to be bound along that direction
int bound_mpi_dir(int boundstage, int finalstep, int whichdir, int boundvartype, FTYPE (*prim)[NSTORE2][NSTORE3][NPR], FTYPE (*F1)[NSTORE2][NSTORE3][NPR], FTYPE (*F2)[NSTORE2][NSTORE3][NPR], FTYPE (*F3)[NSTORE2][NSTORE3][NPR], FTYPE (*vpot)[NSTORE1+SHIFTSTORE1][NSTORE2+SHIFTSTORE2][NSTORE3+SHIFTSTORE3])
{
FTYPE (*prim2bound[NDIM])[NSTORE2][NSTORE3][NPR];
FTYPE (*vpot2bound[NDIM])[NSTORE1+SHIFTSTORE1][NSTORE2+SHIFTSTORE2][NSTORE3+SHIFTSTORE3];
int dir;
#if(DEBUG)
int i,j,k,pl,pliter;
#endif
/* These arrays contain designations that identify
* each recv and send */
static MPI_Request requests[COMPDIM * 2 * 2];
// format of map for requests[dir*2+recv/send(0/1)]
static int didpostrecvs[COMPDIM*2]={0};
/*
*
* 1. do outflow/inflow/etc. boundary conditions (in bounds)
* 2. pack data into workbc arrays and do send/recv's
* 3. for each transfer do a wait/unpack
* 4. do all send waits
*
* NOTE: order is important so corner zones are assigned correctly
*
* workbc[PACK][][] is data that is being sent
* workbc[UNPACK][][] is data that is being recvd
*
*/
/*
* -> higher values of x1
* 2 -> lower values of x1
*
*/
/* bounds has already done non-MPI boundary conditions; now do MPI
* boundary conditions */
// must go in this order (0,1) then (2,3) then (4,5) or visa versa,
// a single directions order doesn't matter. This method of
// ordering is as opposed to directly transfering the corner zones
// to the corner CPU.
// This may be faster since all transfers can proceed at once,
// although this may be slower since no transfers can occur until
// packing is completed. This way packing and transfering occur
// simultaneously.
// Although l/r are packed together, since in the end we have to
// wait for both l/r to complete, so equal time completion is
// favored //over asynch completion.
// Also, transfering corner zones with small message sizes increases
// the importance of latency.
// for 2D:
// I choose left-right N?M first, then up/down N?M. Could
// just do N? for interior for L/R, but true boundary needs full
// N?M exchanged since cpu sets boundary using normal bc code
// which needs to get transfered to neight(i.e. currently if corner
// has bctype 99/? then doesn't do corner)
// GODMARK: Make sure 3D makes sense (no extra things to do)
#if(DEBUG)
PBOUNDLOOP(pliter,pl){
FULLLOOP{
MACP0A1(prim,i,j,k,pl)=-1-pl*100; // should be turned into myid-k*100
}
ZLOOP {
MACP0A1(prim,i,j,k,pl)=myid-pl*100; // differentiates but clear per pr
// logfprintf("%d %d %d %d %21.15g\n",i,j,k,pl,MACP0A1(prim,i,j,k,pl));
}
}
/* Execute special form (defun, setq. etc... arguments are not evaluated) */
long
special(long f, long a)
{
long t, v, u;
int l, i;
switch (D_GET_DATA(f)){
case KW_DEFUN:
if (list_len(a) < 2)
return err_msg(errmsg_ill_syntax, 1, f);
#ifdef SCHEME
/* (define (func var1 varn) (func content)) */
v = l_car(a); /* function name */
v = l_car(v); /* list of function name, arg and function body */
if (D_GET_TAG(v) != TAG_SYMB)
return err_msg(errmsg_ill_syntax, 1, f);
t = l_cdr(v); /* list of function args */
l = list_len(t); /* #args */
a = l_cons( v, l_cons( l_cdr(l_car(a)) , l_cdr(a)));
#endif
/* (defun func (var1 varn) (func content)) */
v = l_car(a); /* function name */
if (D_GET_TAG(v) != TAG_SYMB)
return err_msg(errmsg_ill_syntax, 1, f);
t = l_cdr(a); /* list of function arg and function body */
l = list_len(l_car(t)); /* #args */
i = D_GET_DATA(v);
t_symb_fval[i] = t;
t_symb_ftype[i] = FTYPE(FTYPE_USER, l);
break;
case KW_SETQ:
t = l_car(a); /* symbol name */
if (D_GET_TAG(t) != TAG_SYMB)
return err_msg(errmsg_ill_type, 1, f);
if ((v = l_eval(l_car(l_cdr(a)))) < 0) /* value */
return -1;
t_symb_val[D_GET_DATA(t)] = v;
break;
case KW_QUOTE:
v = l_car(a);
break;
case KW_PROGN:
for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
}
break;
case KW_WHILE:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
if ((v = l_eval(l_car(a))) < 0)
return -1;
while (D_GET_TAG(v) != TAG_NIL) {
for (t = l_cdr(a); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
}
v = l_eval(l_car(a));
}
break;
#ifndef MINIMALISTIC
case KW_AND:
for (v = TAG_T, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
if (D_GET_TAG(t) == TAG_NIL)
break;
}
break;
#endif
case KW_OR:
for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL)
break;
}
break;
case KW_COND:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
v = TAG_NIL;
for (t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
u = l_car(t);
if (D_GET_TAG(u) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
if ((v = l_eval(l_car(u))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL){
for (u = l_cdr(u); D_GET_TAG(u) == TAG_CONS; u = l_cdr(u)){
if ((v = l_eval(l_car(u))) < 0)
return -1;
}
break;
}
}
break;
#ifndef MINIMALISTIC
case KW_COMMENT:
v = TAG_T;
break;
#endif
case KW_IF:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
l = list_len(a);
if ((l == 2) || (l == 3)){
if ((v = l_eval(l_car(a))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL)
return l_eval(l_car(l_cdr(a)));
return (l == 2) ? TAG_NIL : l_eval(l_car(l_cdr(l_cdr(a))));
} else {
return err_msg(errmsg_ill_syntax, 1, f);
}
break;
}
return v;
}
,KW_LT, KW_AND, KW_DIVIDE, KW_LAMBDA,
KW_WHILE, KW_GTE, KW_LTE, KW_COMMENT,
KW_ZEROP, KW_ATOM, KW_RAND, KW_REM,
KW_INCR, KW_DECR, KW_EQUAL, KW_EQMATH
#endif
};
struct s_keywords {
char *key;
int ftype;
char i;
};
/* Built-in function table */
#ifndef NOINIT
struct s_keywords funcs[] = {
{ "read", FTYPE(FTYPE_SYS, 0), KW_READ },
{ "eval", FTYPE(FTYPE_SYS, 1), KW_EVAL },
{ "gc", FTYPE(FTYPE_SYS, 0), KW_GC },
{ "cons", FTYPE(FTYPE_SYS, 2), KW_CONS },
{ "car", FTYPE(FTYPE_SYS, 1), KW_CAR },
{ "cdr", FTYPE(FTYPE_SYS, 1), KW_CDR },
{ "quit", FTYPE(FTYPE_SYS, 0), KW_QUIT },
#ifdef SCHEME
{ "define", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_DEFUN },
#else
{ "defun", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_DEFUN },
#endif
{ "quote", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_QUOTE },
#ifdef SCHEME
{ "set!", FTYPE(FTYPE_SPECIAL, 2), KW_SETQ },
{ "eq?", FTYPE(FTYPE_SYS, 2), KW_EQ },
/*
* Read a file from the world.
* C is command, 'e' if this really an edit (or a recover).
*/
void
rop(int c)
{
int i;
struct stat64 stbuf;
short magic;
static int ovro; /* old value(vi_READONLY) */
static int denied; /* 1 if READONLY was set due to file permissions */
io = open(file, 0);
if (io < 0) {
if (c == 'e' && errno == ENOENT) {
edited++;
/*
* If the user just did "ex foo" they're probably
* creating a new file. Don't be an error, since
* this is ugly, and it messes up the + option.
*/
if (!seenprompt) {
viprintf(gettext(" [New file]"));
noonl();
return;
}
}
if (value(vi_READONLY) && denied) {
value(vi_READONLY) = ovro;
denied = 0;
}
syserror(0);
}
if (fstat64(io, &stbuf))
syserror(0);
switch (FTYPE(stbuf) & S_IFMT) {
case S_IFBLK:
error(gettext(" Block special file"));
/* FALLTHROUGH */
case S_IFCHR:
if (isatty(io))
error(gettext(" Teletype"));
if (samei(&stbuf, "/dev/null"))
break;
error(gettext(" Character special file"));
/* FALLTHROUGH */
case S_IFDIR:
error(gettext(" Directory"));
}
if (c != 'r') {
if (value(vi_READONLY) && denied) {
value(vi_READONLY) = ovro;
denied = 0;
}
if ((FMODE(stbuf) & 0222) == 0 || access((char *)file, 2) < 0) {
ovro = value(vi_READONLY);
denied = 1;
value(vi_READONLY) = 1;
}
}
if (hush == 0 && value(vi_READONLY)) {
viprintf(gettext(" [Read only]"));
flush();
}
if (c == 'r')
setdot();
else
setall();
/* If it is a read command, then we must set dot to addr1
* (value of N in :Nr ). In the default case, addr1 will
* already be set to dot.
*
* Next, it is necessary to mark the beginning (undap1) and
* ending (undap2) addresses affected (for undo). Note that
* rop2() and rop3() will adjust the value of undap2.
*/
if (FIXUNDO && inopen && c == 'r') {
dot = addr1;
undap1 = undap2 = dot + 1;
}
rop2();
rop3(c);
}
void bound_gensimple1(FTYPE (*vars)[N2M][N1M],
FTYPE (*varv)[N3M][N2M][N1M],
int wsca,
int wvec,
int wcom) // 1,2,3, 0: none, 123=all 12=12 13=13, 23=23 (not currently setup to do 13 or 23 since never needed)
{
static int firsttime=1;
int tagheader,tagsend,tagrecv;
int othercpu;
int jumpfactor;
int i,j,k,l,m,p,q ;
int i2,j2,k2;
int ii,jj,kk,ll;
int jje2,jjje2;
int iio,jjo,kko,llo;
int iio2,jjo2,kko2,llo2;
int iir,jjr,kkr,llr;
int iii,jjj,kkk,lll;
int iii2,jjj2,kkk2,lll2;
int bct,bcdim,bcdir,bcd1,bcd2;
int bcdir1,bcdir2,bcdir3;
int bi,bj,bk;
int bireal,bjreal,bkreal;
int diri,dirj;
int startloop,endloop,loopvar;
int looper,component;
FTYPE slope;
FTYPE (*works)[N3M][N2M][N1M];
FTYPE (*workv)[3][N3M][N2M][N1M];
static int numhit=0;
int numhitmin,numhitmax;
int wbound;
FTYPE ftemp,ftempv[3+1],ftempv2[3+1];
char temps[50];
int tempslen=40;
int tempi;
int forces=0, forcev=0, forcecheck;
int docom[3+1], comlength,comorder[3+1],itemp;
int dosign;
int dualloop,divbfix;
int doingscalars,doingvectors;
int gval;
int typeofbc;
int loopi,loopj,loopk;
int othercomp;
int cornerto,corner;
int edgeto, edge;
int whichzone;
int iisum,jjsum,kksum;
int ininflag,outinflag,innerreflectflag;
int doinner,doouter;
int looperstart,looperend;
// might not want to bound vectors if not advecting them
// if(wvec==-1) return;
// if(wvec!=0) return;
//if(wsca!=0) return;
// GODMARK(commented)
//return;
// wsca=0;
// wvec=0;
numhit++;
if(wsca<=-2){
works=(FTYPE (*) [N3M][N2M][N1M])(&vars[0][0][0]);
}
else works=s;
if(wvec<=-2){
workv=(FTYPE (*) [3][N3M][N2M][N1M])(&varv[0][0][0][0]);
}
else workv=v;
if(firsttime||(!(nstep%NUMOUTERSKIP)) ) doouter=1; // only do firsttime and every NUMOUTERSKIPth time
else doouter=0;
doinner=1; // always do it
#if(DOTRUEBOUNDARY==1)
/////////////////////////////////////
/////////////////////////////////////
////////////// SCALARS
/////////////////////////////////////
/////////////////////////////////////
#if(DOBOUNDSCA)
if(wsca!=0){
doingvectors=0;
doingscalars=1;
for(l=1;l<=NUMSCA-NOBOUNDPOT;l++){
/* if not to do all, pick */
if(wsca!=-1){ if(wsca<=-2) ll=0; else ll=wsca; }
else ll=l;
// determine how things are bounded for other vars
if(ll==0){
if(wsca==-2){//other
// bound like rho
wbound=1;
}
else if(wsca==-11){//other
// bound like rho
wbound=1;
}
else if(wsca==-12){//other
// bound like en
wbound=2;
}
else{
fprintf(fail_file,"No definition for ll==0 for scalar case: wsca=%d\n",wsca);
myexit(1);
}
}
else wbound=ll;
looperstart=6;
looperend=7;
for(looper=looperstart;looper<=looperend;looper++){
if((!doinner)&&(looper==6)) continue;
if((!doouter)&&(looper==7)) continue;
LOOPBOUND(looper){
itemp=bzs[looper][temptempi][0];
ftemp=0;
for(m=0;m<itemp;m++) ftemp+=works[ll][bzs[looper][temptempi][m*3+2+1]][bzs[looper][temptempi][m*3+1+1]][bzs[looper][temptempi][m*3+0+1]];
// now assign value
works[ll][k][j][i]=ftemp/((FTYPE)(itemp));
}//end over current scalar boundary zones(minus corners)
}
/* cut short loop if only to do one */
if(wsca!=-1) l=NUMSCA;
} // end over scalars
} // end if any scalars
void bound_rect1(FTYPE (*vars)[N2M][N1M],
FTYPE (*varv)[N3M][N2M][N1M],
int wsca,
int wvec,
int wcom) // 1,2,3, 0: none, 123=all 12=12 13=13, 23=23 (not currently setup to do 13 or 23 since never needed)
{
static int firsttime=1;
int i,j,k,l,m,p,q ;
int ii,jj,kk,ll;
FTYPE (*works)[N3M][N2M][N1M];
FTYPE (*workv)[3][N3M][N2M][N1M];
FTYPE ftemp;
static int numhit=0;
numhit++;
if(wsca<=-2){
works=(FTYPE (*) [N3M][N2M][N1M])(&vars[0][0][0]);
}
else works=s;
if(wvec<=-2){
workv=(FTYPE (*) [3][N3M][N2M][N1M])(&varv[0][0][0][0]);
}
else workv=v;
/////////////////////////////////////
/////////////////////////////////////
////////////// SCALARS
/////////////////////////////////////
/////////////////////////////////////
if(wsca!=0){
for(l=1;l<=NUMSCA;l++){ // bounds potential
if(wsca!=-1){ if(wsca<=-2) ll=0; else ll=wsca; }
else ll=l;
// x1 down
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<0;i++){
kk=k; jj=j; ii=0;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// x1 up
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=N1;i<N1+N1BND;i++){
kk=k; jj=j; ii=N1-1;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// x2 down
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<0;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=k; jj=0; ii=i;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// x2 up
for(k=-N3BND;k<N3+N3BND;k++) for(j=N2;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=k; jj=N2-1; ii=i;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// x3 down
for(k=-N3BND;k<0;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=0; jj=j; ii=i;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// x3 up
for(k=N3;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=N3-1; jj=j; ii=i;
works[ll][k][j][i]=works[ll][kk][jj][ii];
}
// cut short loop if only 1 scalar
if(wsca!=-1) l=NUMSCA;
} // end over scalars
} // end if any scalars
////////////////////////////////////////////////
/////////////////////////////////////////////////
////////////////////////////////////////////////
//////////////////////////// VECTORS
///////////////////////////////////////////////
/////////////////////////////////////////////////
////////////////////////////////////////////////
// Now do vectors if any
if(wvec!=0){
for(l=1;l<=REALNUMVEC;l++){
/* if not to do all, pick */
if(wvec!=-1){ if(wvec<=-2) ll=0; else ll=wvec; }
else ll=l;
// x1 down
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<=0;i++){
kk=k; jj=j; ii=1;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
if(ll==1 && workv[ll][1][k][j][i]>0.0) workv[ll][1][k][j][i]=0.0;
kk=k; jj=j; ii=0;
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
}
// x1 up
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=N1;i<N1+N1BND;i++){
kk=k; jj=j; ii=N1-1;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
if(ll==1 && workv[ll][1][k][j][i]<0.0) workv[ll][1][k][j][i]=0.0;
kk=k; jj=j; ii=N1-1;
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
}
// x2 down
for(k=-N3BND;k<N3+N3BND;k++) for(j=-N2BND;j<=0;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=k; jj=1; ii=i;
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
if(ll==1 && workv[ll][2][k][j][i]>0.0) workv[ll][2][k][j][i]=0.0;
kk=k; jj=0; ii=i;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
}
// x2 up
for(k=-N3BND;k<N3+N3BND;k++) for(j=N2;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=k; jj=N2-1; ii=i;
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
if(ll==1 && workv[ll][2][k][j][i]<0.0) workv[ll][2][k][j][i]=0.0;
kk=k; jj=N2-1; ii=i;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
}
// x3 down
for(k=-N3BND;k<=0;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=1; jj=j; ii=i;
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
if(ll==1 && workv[ll][3][k][j][i]>0.0) workv[ll][3][k][j][i]=0.0;
kk=0; jj=j; ii=i;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
}
// x3 up
for(k=N3;k<N3+N3BND;k++) for(j=-N2BND;j<N2+N2BND;j++) for(i=-N1BND;i<N1+N1BND;i++){
kk=N3-1; jj=j; ii=i;
workv[ll][3][k][j][i]=workv[ll][3][kk][jj][ii];
if(ll==1 && workv[ll][3][k][j][i]<0.0) workv[ll][3][k][j][i]=0.0;
kk=N3-1; jj=j; ii=i;
workv[ll][1][k][j][i]=workv[ll][1][kk][jj][ii];
workv[ll][2][k][j][i]=workv[ll][2][kk][jj][ii];
}
/* cut short loop if only to do one */
if(wvec!=-1) l=REALNUMVEC;
}// end over vectors
}// endif vectors to be done
#if(DOINTERNALBOUNDARY==1)
// if doing MPI:
#if(USEMPI)
bound_mpi(vars,varv,wsca,wvec,wcom);
#endif
#endif
firsttime=0;
}// end function