bool CSPropMaterial::Write2XML(TiXmlNode& root, bool parameterised, bool sparse)
{
if (CSProperties::Write2XML(root,parameterised,sparse) == false) return false;
TiXmlElement* prop=root.ToElement();
if (prop==NULL) return false;
prop->SetAttribute("Isotropy",bIsotropy);
/*************** 3D - Properties *****************/
TiXmlElement value("Property");
WriteVectorTerm(Epsilon,value,"Epsilon",parameterised);
WriteVectorTerm(Mue,value,"Mue",parameterised);
WriteVectorTerm(Kappa,value,"Kappa",parameterised);
WriteVectorTerm(Sigma,value,"Sigma",parameterised);
/*************** 1D - Properties *****************/
WriteTerm(Density,value,"Density",parameterised);
prop->InsertEndChild(value);
/********** 3D - Properties Weight **************/
TiXmlElement Weight("Weight");
WriteVectorTerm(WeightEpsilon,Weight,"Epsilon",parameterised);
WriteVectorTerm(WeightMue,Weight,"Mue",parameterised);
WriteVectorTerm(WeightKappa,Weight,"Kappa",parameterised);
WriteVectorTerm(WeightSigma,Weight,"Sigma",parameterised);
/********** 1D - Properties Weight **************/
WriteTerm(WeightDensity,Weight,"Density",parameterised);
prop->InsertEndChild(Weight);
return true;
}
bool ParameterCoord::Write2XML(TiXmlElement *elem, bool parameterised)
{
if (elem==NULL)
return false;
WriteTerm(*m_Coords[0],*elem,"X",parameterised);
WriteTerm(*m_Coords[1],*elem,"Y",parameterised);
WriteTerm(*m_Coords[2],*elem,"Z",parameterised);
return true;
}
bool CSPrimRotPoly::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimPolygon::Write2XML(elem,parameterised);
elem.SetAttribute("RotAxisDir",m_RotAxisDir);
TiXmlElement Ang("Angles");
WriteTerm(StartStopAngle[0],Ang,"Start",parameterised);
WriteTerm(StartStopAngle[1],Ang,"Stop",parameterised);
elem.InsertEndChild(Ang);
return true;
}
Term SplitIndices(Term t, List *ilist)
{
Term rt,tt,t1=0;
rt=ConsumeCompoundArg(t,1);
tt=ConsumeCompoundArg(t,2);
FreeAtomic(t);
while(is_compound(tt))
{
t1=CompoundName(tt);
if(t1!=OPR_CARET && t1!=OPR_USCORE)
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Semantic error: \'");
WriteTerm(tt);
printf("\' is not appropriate index.\n");
FreeAtomic(tt); return 0;
}
t1=ConsumeCompoundArg(tt,1);
if(!is_atom(t1) && !is_integer(t1))
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Semantic error: \'");
WriteTerm(t1);
printf("\' is not appropriate index.\n");
FreeAtomic(tt);FreeAtomic(t1); return 0;
}
*ilist=AppendLast(*ilist,t1);
t1=ConsumeCompoundArg(tt,2);
FreeAtomic(tt);
tt=t1;
}
if(!is_atom(tt) && !is_integer(tt))
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Semantic error: \'");
WriteTerm(tt);
printf("\' is not appropriate index.\n");
FreeAtomic(tt); return 0;
}
*ilist=AppendLast(*ilist,tt);
return rt;
}
bool CSPropLumpedElement::Write2XML(TiXmlNode& root, bool parameterised, bool sparse)
{
if (CSProperties::Write2XML(root,parameterised,sparse)==false) return false;
TiXmlElement* prop=root.ToElement();
if (prop==NULL) return false;
prop->SetAttribute("Direction",m_ny);
prop->SetAttribute("Caps",(int)m_Caps);
WriteTerm(m_R,*prop,"R",parameterised);
WriteTerm(m_C,*prop,"C",parameterised);
WriteTerm(m_L,*prop,"L",parameterised);
return true;
}
bool CSPrimSphericalShell::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimSphere::Write2XML(elem,parameterised);
WriteTerm(psShellWidth,elem,"ShellWidth",parameterised);
return true;
}
static Term cc_particle(Term t1, List *ind)
{
Term t, prt;
t=ConsumeCompoundArg(t1,1);
FreeAtomic(t1);
prt=GetAtomProperty(t,PROP_TYPE);
if( !(is_compound(prt) && CompoundName(prt)==OPR_PARTICLE))
{
ErrorInfo(216);
printf(" cc(\'");WriteTerm(t);printf("\') is undefined.\n");
longjmp(alg1_jmp_buf,1);
}
t1=t;
/* if(CompoundArg1(prt)==t)
t=CompoundArg2(prt);
else
t=CompoundArg1(prt);*/
if(ind!=NULL)
*ind=CopyTerm(GetAtomProperty(t,PROP_INDEX));
if(!is_empty_list(*ind) && CompoundName(CompoundArg1(ListFirst(*ind)))==A_LORENTZ)
{
Term tt, in1,in2;
tt=CompoundArg1(ListFirst(*ind));
in1=ConsumeCompoundArg(tt,1);
in2=ConsumeCompoundArg(tt,2);
SetCompoundArg(tt,1,in2);
SetCompoundArg(tt,2,in1);
}
/*
WriteTerm(*ind); puts("");
*/
return t1;
}
bool CSPrimLinPoly::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimPolygon::Write2XML(elem,parameterised);
WriteTerm(extrudeLength,elem,"Length",parameterised);
return true;
}
bool CSPrimPolygon::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimitives::Write2XML(elem,parameterised);
WriteTerm(Elevation,elem,"Elevation",parameterised);
elem.SetAttribute("NormDir",m_NormDir);
elem.SetAttribute("QtyVertices",(int)vCoords.size()/2);
for (size_t i=0;i<vCoords.size()/2;++i)
{
TiXmlElement VT("Vertex");
WriteTerm(vCoords.at(i*2),VT,"X1",parameterised);
WriteTerm(vCoords.at(i*2+1),VT,"X2",parameterised);
elem.InsertEndChild(VT);
}
return true;
}
bool CSPrimUserDefined::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimitives::Write2XML(elem,parameterised);
elem.SetAttribute("CoordSystem",CoordSystem);
TiXmlElement P1("CoordShift");
WriteTerm(dPosShift[0],P1,"X",parameterised);
WriteTerm(dPosShift[1],P1,"Y",parameterised);
WriteTerm(dPosShift[2],P1,"Z",parameterised);
elem.InsertEndChild(P1);
TiXmlElement FuncElem("Function");
TiXmlText FuncText(GetFunction());
FuncElem.InsertEndChild(FuncText);
elem.InsertEndChild(FuncElem);
return true;
}
bool CSPropExcitation::Write2XML(TiXmlNode& root, bool parameterised, bool sparse)
{
if (CSProperties::Write2XML(root,parameterised,sparse) == false) return false;
TiXmlElement* prop=root.ToElement();
if (prop==NULL) return false;
prop->SetAttribute("Number",(int)uiNumber);
WriteTerm(m_Frequency,*prop,"Frequency",parameterised);
WriteTerm(Delay,*prop,"Delay",parameterised);
prop->SetAttribute("Type",iExcitType);
WriteVectorTerm(Excitation,*prop,"Excite",parameterised);
TiXmlElement Weight("Weight");
WriteTerm(WeightFct[0],Weight,"X",parameterised);
WriteTerm(WeightFct[1],Weight,"Y",parameterised);
WriteTerm(WeightFct[2],Weight,"Z",parameterised);
prop->InsertEndChild(Weight);
WriteVectorTerm(PropagationDir,*prop,"PropDir",parameterised);
return true;
}
static
void WriteSidePF(FILE *f,
CONST struct relation *r,
int side,
CONST struct Instance *ref)
{
unsigned c,len;
CONST struct relation_term *term;
len = RelationLength(r,side);
for(c=1;c<=len;c++){
term = RelationTerm(r,c,side);
WriteTerm(f,r,term,ref);
if(c<len) PUTC(' ',f);
}
}
Term ProcDelVertex(Term t, List ind)
{
List l, pl;
if(lagr_hash==NULL)
{
ErrorInfo(107);
puts("DelVertex: no vertices");
return 0;
}
if(!is_compound(t)||CompoundArity(t)!=1)
{
ErrorInfo(107);
puts("wrong call to DelVertex");
return 0;
}
pl=CompoundArg1(t);
if(!is_list(pl))
{
ErrorInfo(107);
puts("wrong call to DelVertex");
return 0;
}
for(l=pl;l;l=ListTail(l))
if(is_function(ListFirst(l),0))
ChangeList(l,CallFunction(ListFirst(l),0));
pl=SortedList(pl,acmp);
l=finda2(pl,1);
if(is_empty_list(l))
{
WarningInfo(108);printf("DelVertex: vertex ");
WriteTerm(pl); puts(" not found");
return 0;
}
return 0;
}
Term ProcKeepLets(Term t, Term ind)
{
Term t1;
List l;
if(!is_compound(t) || CompoundArity(t)!=1)
{
ErrorInfo(331);
printf("bad syntax in 'keep_lets' statement.\n");
return 0;
}
t1=CommaToList(ConsumeCompoundArg(t,1));
FreeAtomic(t);
for(l=t1;l;l=ListTail(l))
{
Atom p;
p=ListFirst(l);
if(!is_atom(p))
{
ErrorInfo(332);
printf("unexpected '");
WriteTerm(p);
printf("' in 'keep_lets' statement.\n");
continue;
}
if(GetAtomProperty(p,PROP_TYPE))
{
ErrorInfo(333);
printf("'keep_lets': object '%s' is already defined.\n",
AtomValue(p));
continue;
}
SetAtomProperty(p,A_KEEP_LETS,MakeCompound1(A_KEEP_LETS,0));
}
return 0;
}
Term ProcOptLets(Term ls, Term ind)
{
List l=ConsumeCompoundArg(ls,1);
/*WriteTerm(l);puts("");*/
FreeAtomic(ls);
ls=CommaToList(l);
/*WriteTerm(ls);puts("");*/
for(l=ls;l;l=ListTail(l))
{
Term prp=GetAtomProperty(ListFirst(l),PROP_TYPE);
if(!prp || CompoundName(prp)!=OPR_LET)
{
ErrorInfo(900);
WriteTerm(ListFirst(l));
puts(" is not a let subst.");
}
alg1_opt_let(CompoundArg1(prp));
}
return 0;
}
bool CSPrimMultiBox::Write2XML(TiXmlElement &elem, bool parameterised)
{
CSPrimitives::Write2XML(elem,parameterised);
elem.SetAttribute("QtyBox",(int)vCoords.size()/6);
for (size_t i=0;i<vCoords.size()/6;++i)
{
TiXmlElement SP("StartP");
WriteTerm(*vCoords.at(i*6),SP,"X",parameterised);
WriteTerm(*vCoords.at(i*6+2),SP,"Y",parameterised);
WriteTerm(*vCoords.at(i*6+4),SP,"Z",parameterised);
elem.InsertEndChild(SP);
TiXmlElement EP("EndP");
WriteTerm(*vCoords.at(i*6+1),EP,"X",parameterised);
WriteTerm(*vCoords.at(i*6+3),EP,"Y",parameterised);
WriteTerm(*vCoords.at(i*6+5),EP,"Z",parameterised);
elem.InsertEndChild(EP);
}
return true;
}
Term ProcChVertex(Term t, List ind)
{
List l, pl, ml;
Term rpl;
Atom a1, a2;
int pli;
int ii;
if(lagr_hash==NULL)
{
ErrorInfo(107);
puts("ChVertex: no vertices");
return 0;
}
if(!is_compound(t)||CompoundArity(t)!=2)
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
pl=CompoundArg1(t);
for(l=pl;l;l=ListTail(l))
if(is_function(ListFirst(l),0))
ChangeList(l,CallFunction(ListFirst(l),0));
rpl=CompoundArg2(t);
if(!is_list(pl)|| !is_compound(rpl) || CompoundArity(rpl)!=2)
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
a1=CompoundArg1(rpl);a2=CompoundArg2(rpl);
if(!is_parameter(a1)||!is_parameter(a2))
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
pl=SortedList(pl,acmp);
l=finda2(pl,0);
if(is_empty_list(l))
{
WarningInfo(108);printf("ChVertex: vertex ");
WriteTerm(pl); puts(" not found");
return 0;
}
ml=CompoundArgN(ListFirst(l),5);
ii=0;
for(l=ml;l;l=ListTail(l))
{
List l1;
for(l1=CompoundArg2(ListFirst(l));l1;l1=ListTail(l1))
if(CompoundArg1(ListFirst(l1))==a1)
{
SetCompoundArg(ListFirst(l1),1,a2);ii++;
}
}
if(ii==0)
{
WarningInfo(107);printf("ChVertex: vertex ");WriteTerm(pl);
printf("has no '%s' within.\n",AtomValue(a1));
}
return 0;
}
Term ProcCoefVrt(Term t, List ind)
{
List l,pl,ml;
int ii;
Term a2;
int g=0, g5=0, re=0, im=0, abbr=0, cmplx=0;
if(!is_compound(t) || CompoundArity(t)>2 || !is_list(CompoundArg1(t)))
{
ErrorInfo(0);
puts("wrong parameters of CoefVrt function.");
return 0;
}
if(lagr_hash==NULL)
{
ErrorInfo(107);
puts("CoefVrt: no vertices");
return 0;
}
mmm=0;
if(CompoundArity(t)==2)
{
List ol=CompoundArg2(t);
if(!is_list(ol))
{
ErrorInfo(107);
puts("CoefVrt: second argument is not a list.");
return 0;
}
for(;ol;ol=ListTail(ol))
{
Term o=ListFirst(ol);
if(is_compound(o))
{
o=CompoundArg1(o);
if(!is_atom(o) || !is_particle(o,0))
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not a particle.\n");
return 0;
}
mmm=o;
continue;
}
if(!is_atom(o))
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not an option.\n");
return 0;
}
if(strcmp("gamma",AtomValue(o))==0)
{
g++;
continue;
}
if(strcmp("gamma5",AtomValue(o))==0)
{
g5++;
continue;
}
if(strcmp("re",AtomValue(o))==0)
{
re++;
continue;
}
if(strcmp("im",AtomValue(o))==0)
{
im++;
continue;
}
if(strcmp("abbr",AtomValue(o))==0)
{
abbr++;
continue;
}
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not an option.\n");
return 0;
}
}
}
if(re&&im)
re=im=0;
pl=ConsumeCompoundArg(t,1);
for(l=pl;l;l=ListTail(l))
if(is_function(ListFirst(l),0))
ChangeList(l,CallFunction(ListFirst(l),0));
/* for(l=pl;l;l=ListTail(l))
{
Term aa=ListFirst(l);
if(is_compound(aa)&&CompoundName(aa)==A_ANTI)
ChangeList(l,GetAtomProperty(CompoundArg1(aa),A_ANTI));
}*/
pl=SortedList(pl,acmp);
l=finda2(pl,0);
if(mmm && !mmmpos)
{
ErrorInfo(0);
printf("CoefVrt: particle ");
WriteTerm(mmm);
puts(" not found in the vertex");
return 0;
}
if(is_empty_list(l))
{
ErrorInfo(108);
printf("CoefVrt: vertex ");
WriteTerm(pl);
puts(" not found");
return NewInteger(0);
}
a2=CopyTerm(ListFirst(l));
alg2_symmetrize(a2);
alg2_common_n(a2);
{
int sv=kill_gamma_pm;
kill_gamma_pm=1;
alg2_red_1pm5(a2);
kill_gamma_pm=sv;
}
alg2_recommon_n(a2);
ml=ConsumeCompoundArg(a2,5);
for(l=ml;l;l=ListTail(l))
{
List l1,ll;
int tg=0, tg5=0, tm=0;
for(l1=CompoundArgN(ListFirst(l),3);l1;l1=ListTail(l1))
{
Term tt=ListFirst(l1);
if(CompoundName(tt)==OPR_SPECIAL && CompoundArg1(tt)==A_GAMMA)
tg++;
if(CompoundName(tt)==OPR_SPECIAL && CompoundArg1(tt)==A_GAMMA5)
tg5++;
if(CompoundName(tt)==A_MOMENT && CompoundArg1(tt)==
NewInteger(mmmpos))
tm++;
}
if(g!=tg || g5!=tg5 || (mmm && !tm))
{
SetCompoundArg(ListFirst(l),1,0);
continue;
}
if(!re && !im)
continue;
for(l1=CompoundArg2(ListFirst(l));l1;l1=ListTail(l1))
if(GetAtomProperty(CompoundArg1(ListFirst(l1)),A_ANTI))
cmplx++;
}
if( (re||im) && !cmplx)
for(l=ml;l;l=ListTail(l))
{
List ll,l1;
if(CompoundArg1(ListFirst(l))==0)
continue;
ll=ConsumeCompoundArg(ListFirst(l),2);
for(l1=ll;l1;l1=ListTail(l1))
if(CompoundArg1(ListFirst(l1))==A_I)
break;
if( (re && l1) || (im && !l1) )
SetCompoundArg(ListFirst(l),1,0);
if(im && l1)
ll=CutFromList(ll,l1);
SetCompoundArg(ListFirst(l),2,ll);
}
rpt:
for(l=ml;l;l=ListTail(l))
if(CompoundArg1(ListFirst(l))==0)
{
ml=CutFromList(ml,l);
break;
}
if(l)
goto rpt;
SetCompoundArg(a2,5,ml);
alg2_recommon_n(a2);
alg2_common_s(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
alg2_red_sico(a2);
alg2_red_comsico(a2);
alg2_recommon_n(a2);
if(abbr)
{
int trisv=opTriHeu;
alg2_eval_vrt(a2);
doing_abbr=0;
opTriHeu=trisv;
}
{
int n,d;
Term cf;
Term res;
n=IntegerValue(CompoundArg1(CompoundArg2(a2)));
d=IntegerValue(CompoundArg2(CompoundArg2(a2)));
cf=l2expr(CompoundArgN(a2,3),n);
ml=CompoundArgN(a2,5);
if(ml==0)
return NewInteger(0);
res=l2expr(CompoundArg2(ListFirst(ml)),
IntegerValue(CompoundArg1(ListFirst(ml))));
for(l=ListTail(ml);l;l=ListTail(l))
{
Term ccc;
n=IntegerValue(CompoundArg1(ListFirst(l)));
ccc=l2expr(CompoundArg2(ListFirst(l)),n>0?n:-n);
if(n>0)
res=MakeCompound2(OPR_PLUS,res,ccc);
else
res=MakeCompound2(OPR_MINUS,res,ccc);
}
if(res==NewInteger(1))
res=cf;
else
res=MakeCompound2(OPR_MLT,cf,res);
if(d!=1)
res=MakeCompound2(OPR_DIV,res,NewInteger(d));
if( (im||re) && cmplx)
res=MakeCompound1(NewAtom(re?"creal":"cimag",0),res);
return res;
}
return a2;
}
Term VarVer(Term t, Term ind)
{
List l,l1,l2;
puts("Parameters");
l=all_param_list();
for(l1=l;!is_empty_list(l1);l1=ListTail(l1))
{
Term aa;
aa=CompoundArg1(ListFirst(l1));
if(!is_float(aa) && !is_integer(aa))
{
printf("%s: ",AtomValue(CompoundName(ListFirst(l1))));
WriteTerm(aa);
printf(" -> ");
WriteTerm(dif_term(aa));
puts("");
}
}
puts("\nVertices");
l2=l=all_vert_list();
for(l1=l;!is_empty_list(l1);l1=ListTail(l1))
{
Term a2;
List l,lp,lm;
a2=CopyTerm(ListFirst(l1));
alg2_symmetrize(a2);
alg2_common_s(a2);
alg2_common_n(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
if(CompoundArg2(a2)==NewInteger(0) ||
is_empty_list(CompoundArgN(a2,5)))
continue;
WriteVertex(CompoundArg1(a2));
printf(" ");
if(CompoundArgN(a2,3))
WriteTerm(CompoundArgN(a2,3));
else
printf("[]");
printf(" ");
lp=lm=NewList();
for(l=CompoundArgN(a2,3);!is_empty_list(l);l=ListTail(l))
{
Term aa;
aa=ListFirst(l);
if(IntegerValue(CompoundArg2(aa))<0)
{
aa=CopyTerm(aa);
SetCompoundArg(aa,2,NewInteger(-IntegerValue(CompoundArg2(aa))));
if(IntegerValue(CompoundArg2(aa))==1)
lm=AppendLast(lm,CompoundArg1(aa));
else
lm=AppendLast(lm,aa);
}
else
{
if(IntegerValue(CompoundArg2(aa))==1)
lp=AppendLast(lp,CompoundArg1(aa));
else
lp=AppendLast(lp,aa);
}
}
if(lp)
lp=l2mult(lp);
if(lm)
lm=l2mult(lm);
if(lp==0 && lm==0)
{
printf("0");
goto cnt;
}
if(lm==0)
{
WriteTerm(dif_term(lp));
goto cnt;
}
if(lp==0)
{
WriteTerm(dif_term(MakeCompound2(OPR_DIV,NewInteger(1),lm)));
goto cnt;
}
WriteTerm(dif_term(MakeCompound2(OPR_DIV,lp,lm)));
cnt:
puts("");
FreeAtomic(a2);
}
FreeAtomic(l2);
return 0;
}
static List s_l_1(Term m1)
{
List l,l1;
l=CompoundArgN(m1,3);
while(!is_empty_list(l))
{
Term t1;
t1=ListFirst(l);
if(CompoundName(t1)==OPR_LET)
{
Term sub,a1,ila,ill;
a1=sub=ConsumeCompoundArg(t1,2);
ill=ConsumeCompoundArg(t1,1);
FreeAtomic(t1);
ChangeList(l,0);
sub=CopyTerm(GetAtomProperty(a1,OPR_LET));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
sub=CopyTerm(GetAtomProperty(a1,PROP_TYPE));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
printf("Internal error: inconsistent substitution '");
WriteTerm(CompoundArg2(a1));
puts("'");
longjmp(alg1_jmp_buf,1);
}
}
renewlab(sub);
a1=ConsumeCompoundArg(sub,1);
ila=ConsumeCompoundArg(sub,2);
FreeAtomic(sub);
repl_ind(a1,ila,ill);
return SetLets(mk_let(m1,l,a1));
}
l=ListTail(l);
}
l=CompoundArgN(m1,4);
while(!is_empty_list(l))
{
Term t1;
t1=ListFirst(l);
if(CompoundName(t1)==OPR_LET)
{
Term sub,a1,ila,ill;
a1=sub=ConsumeCompoundArg(t1,2);
ill=ConsumeCompoundArg(t1,1);
if(ill)
{
puts("Integnal error (iinld)");
longjmp(alg1_jmp_buf,1);
}
l1=ConsumeCompoundArg(m1,4);
l1=CutFromList(l1,l);
SetCompoundArg(m1,4,l1);
sub=CopyTerm(GetAtomProperty(a1,OPR_LET));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
sub=CopyTerm(GetAtomProperty(a1,PROP_TYPE));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
printf("Internal error: inconsistent substitution '");
WriteTerm(CompoundArg2(a1));
puts("'");
longjmp(alg1_jmp_buf,1);
}
}
renewlab(sub);
if(CompoundArgN(sub,3)==0)
{
ErrorInfo(378);
printf("symbol '%s' can not be in denominator\n",AtomValue(a1));
longjmp(alg1_jmp_buf,1);
}
a1=ConsumeCompoundArg(sub,3);
ila=ConsumeCompoundArg(sub,2);
FreeAtomic(sub);
if(ila)
{
puts("Internal error (iidl1)");
longjmp(alg1_jmp_buf,1);
}
return SetLets(mk_let_d(m1,a1));
}
l=ListTail(l);
}
return AppendFirst(NewList(),m1);
}
void alg1_opt_let(Term a1)
{
List l,l1,l2,lm=ConsumeCompoundArg(a1,1);
List nl=0;
Label mylbl=NewLabel();
/*printf("%d -> ",ListLength(lm));*/
for(l=lm;l;l=ListTail(l))
{
Term m1=ListFirst(l);
int n,d,g;
List ln=ConsumeCompoundArg(m1,3);
List ld=ConsumeCompoundArg(m1,4);
Term f1=0, f2=0, w=0;
n=IntegerValue(CompoundArg1(m1));
d=IntegerValue(CompoundArg2(m1));
rpt1:
for(l1=ld;l1;l1=ListTail(l1))
{
int n=ListMember(ln,ListFirst(l1));
if(n)
{
ld=CutFromList(ld,l1);
l1=ListNthList(ln,n);
ln=CutFromList(ln,l1);
goto rpt1;
}
if(CompoundArg2(ListFirst(l1))==A_SQRT2)
{
Term t=ListFirst(l1);
ChangeList(l1,0);
ld=CutFromList(ld,l1);
ln=AppendFirst(ln,t);
d*=2;
goto rpt1;
}
}
rpt2:
for(l1=ln;l1;l1=ListTail(l1))
if(CompoundArg2(ListFirst(l1))==A_SQRT2)
{
List l2;
for(l2=ListTail(l1);l2;l2=ListTail(l2))
if(CompoundArg2(ListFirst(l2))==A_SQRT2)
{
ln=CutFromList(ln,l1);
ln=CutFromList(ln,l2);
n*=2;
goto rpt2;
}
}
g=gcf(n,d);
n/=g;
d/=g;
for(l1=ln;l1;l1=l1?ListTail(l1):0)
{
Term sp=ListFirst(l1);
if(CompoundName(sp)==OPR_PARAMETER)
continue;
if(CompoundName(sp)==OPR_FIELD)
{
if(f1==0)
f1=l1;
else if(f2==0)
f2=l1;
else
{
ErrorInfo(1280);
puts("bad let-sub: >2 prtc");
return;
}
continue;
}
if(CompoundName(sp)==OPR_WILD)
{
if(w)
{
ErrorInfo(1281);
puts("bad let-sub: unk spec");
return;
}
w=l1;
continue;
}
ErrorInfo(110);
WriteTerm(sp);puts(" : bad let: unk stuff");
return;
}
if(f2==0)
{
ErrorInfo(112);
puts("bad let-subs: not 2 prtc");
return;
}
l1=f1;f1=ListFirst(f1);ChangeList(l1,0);ln=CutFromList(ln,l1);
l1=f2;f2=ListFirst(f2);ChangeList(l1,0);ln=CutFromList(ln,l1);
if(w)
{l1=w;w=ListFirst(w);ChangeList(l1,0);ln=CutFromList(ln,l1);}
ln=SortedList(ln,prmcmp);
ld=SortedList(ld,prmcmp);
if((GetAtomProperty(CompoundArg2(f1),A_ANTI)==CompoundArg2(f1) ||
GetAtomProperty(CompoundArg2(f2),A_ANTI)==CompoundArg2(f2))
&& strcmp(AtomValue(CompoundArg2(f1)),AtomValue(CompoundArg2(f2)))>0)
{
Term tmp=f1;
f1=f2;
f2=tmp;
}
if(ListLength(CompoundArg1(f1))==1 && ListLength(CompoundArg1(f1))==1)
{
Term i1=ListFirst(CompoundArg1(f1));
Term i2=ListFirst(CompoundArg1(f2));
if(CompoundName(CompoundArg1(i1))!=A_COLOR ||
CompoundName(CompoundArg1(i2))!=A_COLOR ||
CompoundArg2(i1)!=CompoundArg2(i2))
{
ErrorInfo(233);
puts("bad color stru in let-sub.");
return;
}
SetCompoundArg(i1,2,mylbl);
SetCompoundArg(i2,2,mylbl);
}
ln=AppendLast(ln,f1);
ln=AppendLast(ln,f2);
if(w) ln=AppendLast(ln,w);
SetCompoundArg(m1,1,NewInteger(n));
SetCompoundArg(m1,2,NewInteger(d));
SetCompoundArg(m1,3,ln);
SetCompoundArg(m1,4,ld);
for(l1=nl;l1;l1=ListTail(l1))
{
if(EqualTerms(CompoundArgN(ListFirst(l1),3),ln) &&
EqualTerms(CompoundArgN(ListFirst(l1),4),ld) &&
IntegerValue(CompoundArg2(ListFirst(l1)))*d>0)
{
Term om1=ListFirst(l1);
int n1=IntegerValue(CompoundArg1(om1));
int d1=IntegerValue(CompoundArg2(om1));
int rn,rd,cc=0;
if(d1<0)
{
d=-d;d1=-d1;cc=1;
}
rn=n*d1+n1*d;
rd=d*d1;
if(rn==0)
{
nl=CutFromList(nl,l1);
break;
}
g=gcf(rn,rd);
rn/=g; rd/=g;
if(cc) rd=-rd;
SetCompoundArg(om1,1,NewInteger(rn));
SetCompoundArg(om1,2,NewInteger(rd));
FreeAtomic(m1);
break;
}
}
if(l1==0)
nl=AppendLast(nl,m1);
}
RemoveList(lm);
/*DumpList(nl);*/
/*printf("%d\n",ListLength(nl));*/
SetCompoundArg(a1,1,nl);
}
int main(int argc, char **argv, char **env)
{
int i;
int save_flag=0;
char *save_file=NULL;
if(sizeof(Term)!=4)
{
puts("Compilation error");
return -1;
}
if(argc>1 && strcmp(argv[1],"-exv")==0)
{
exv(argc-1,argv+1);
return 0;
}
InitAtoms();
InitFuncs();
AlwaysBracets = 0;
WideWriting = 0;
signal(SIGINT, stop);
signal(SIGSEGV, sigsegv);
signal(SIGUSR1, sigdmp);
for(i=1; i<argc; i++)
{
if(strcmp(argv[i],"-v")==0)
{
VerbMode=1;
continue;
}
if(strcmp(argv[i],"-vv")==0)
{
VerbMode=2;
continue;
}
if(strcmp(argv[i],"-vvv")==0)
{
VerbMode=3;
continue;
}
if(strcmp(argv[i],"-c4")==0)
{
ChepVersion=4;
continue;
}
if(strcmp(argv[i],"-c3")==0)
{
ChepVersion=3;
continue;
}
if(strcmp(argv[i],"-mOmega")==0)
{
ChepVersion=4;
MicroOmega=1;
continue;
}
if(strcmp(argv[i],"-OutDir")==0)
{
OutputDirectory=argv[++i];
continue;
}
if(strcmp(argv[i],"-InDir")==0)
{
InputDirectory=argv[++i];
continue;
}
if(strcmp(argv[i],"-allvrt")==0)
{
write_all_vertices=1;
continue;
}
if(strcmp(argv[i],"-rc")==0)
{
InitFile=argv[++i];
continue;
}
if(strcmp(argv[i],"-tex")==0)
{
TexOutput=1;
opSplitCol1=0;
continue;
}
if(strcmp(argv[i],"-feynarts")==0 || strcmp(argv[i],"-FeynArts")==0)
{
FAOutput=1;
opSplitCol1=0;
opSplitCol2=0;
continue;
}
if(strcmp(argv[i],"-feynarts6")==0 || strcmp(argv[i],"-FeynArts6")==0 ||
strcmp(argv[i],"-fa6")==0)
{
FAOutput=1;
FAver=6;
opSplitCol1=0;
opSplitCol2=0;
continue;
}
if(strcmp(argv[i],"-uf")==0 || strcmp(argv[i],"-UF")==0)
{
UFOutput=1;
opSplitCol1=0;
opSplitCol2=0;
continue;
}
if(strcmp(argv[i],"-save")==0)
{
save_flag=1;
save_file=argv[++i];
printf("Feynman rules will be saved in '%s' file.\n",save_file);
continue;
}
if(strcmp(argv[i],"-eval-prm")==0)
{
EvalPrm=1;
continue;
}
if(strcmp(argv[i],"-eval-vrt")==0)
{
EvalVrt=1;
continue;
}
if(strcmp(argv[i],"-frc")==0)
{
ForsedRedCol=1;
continue;
}
if(strcmp(argv[i],"-nocolor")==0)
{
NoColors=1;
continue;
}
if(strcmp(argv[i],"-colors")==0)
{
WriteColors=1;
continue;
}
if(strcmp(argv[i],"-no4color")==0)
{
No4Color=1;
continue;
}
if(strcmp(argv[i],"-nocdot")==0)
{
TEX_set_dot=0;
continue;
}
if(strcmp(argv[i],"-v-charges")==0)
{
verb_charge=1;
continue;
}
if(strcmp(argv[i],"-v-herm")==0)
{
verb_herm=1;
continue;
}
if(strcmp(argv[i],"-v-imprt")==0)
{
verb_imprt=1;
continue;
}
if(strcmp(argv[i],"-off-srefine")==0)
{
off_srefine=1;
continue;
}
if(strcmp(argv[i],"-chep-srefine")==0)
{
ch_sign=1;
continue;
}
if(strcmp(argv[i],"-texLines")==0)
{
sscanf(argv[++i],"%d",&TEX_lines);
continue;
}
if(strcmp(argv[i],"-texLineLength")==0)
{
sscanf(argv[++i],"%d",&TEX_spec_in_line);
continue;
}
if(strcmp(argv[i],"-texMaxPrtNo")==0)
{
sscanf(argv[++i],"%d",&TEX_max_pno);
continue;
}
if(strncmp(argv[i],"-abbr",5)==0)
{
if(eval_vrt_len)
{
puts("Error: -evl and -abbr options are not compatible");
continue;
}
opAbbrVrt=1;
opAbbArr=1;
opEvalVrt=0;
opTriHeu=0;
if(argv[i][5]>'1' && argv[i][5]<'9')
opAbbrVrt=argv[i][5]-'1'+1;
if(argv[i][5]=='A')
opAbbArr=0;
opNoDummies=1;
continue;
}
if(strcmp(argv[i],"-evl")==0)
{
if(opAbbrVrt)
{
puts("Error: -evl and -abbr options are not compatible");
i++;
continue;
}
sscanf(argv[++i],"%d",&eval_vrt_len);
if(eval_vrt_len==2)
{
opNoDummies=1;
eval_vrt_more=1;
/*kill_gamma_pm=1;*/
}
continue;
}
if(strcmp(argv[i],"-sleep")==0)
{
int sec;
sscanf(argv[++i],"%d",&sec);
sleep(sec*60);
continue;
}
if(strcmp(argv[i],"-key")==0)
{
SetKeyFromArg(argv[++i]);
continue;
}
if(strcmp(argv[i],"-edbg")==0)
{
end_with_tty=1;
continue;
}
if(strcmp(argv[i],"-norc")==0)
{
remove_rc=1;
continue;
}
if(argv[i][0]=='-')
{
ErrorInfo(0);
printf(": unknown option %s.\n",argv[i]);
continue;
}
if(InputFile)
{
ErrorInfo(0);
printf(": unknown option %s.\n",argv[i]);
continue;
}
InputFile=argv[i];
}
if(!write_all_vertices && !TexOutput)
{
if(FAOutput)
opMaxiLegs=4;
else
opMaxiLegs=4;
}
if(UFOutput)
{
FAOutput=1;
opAbbrVrt=1;
opAbbArr=0;
opEvalVrt=0;
opTriHeu=0;
opNoDummies=1;
}
if(MicroOmega)
SetKeyFromArg("MicrOmega=1");
else
SetKeyFromArg("MicrOmega=0");
if(FAOutput)
SetKeyFromArg("FeynArts=1");
else
SetKeyFromArg("FeynArts=0");
if(InputDirectory==NULL)
{
InputDirectory=find_path(argv[0],env);
if(VerbMode)
printf("Input directory is '%s'\n",InputDirectory);
}
doinitfile=1;
ReadFile(InitFile);
doinitfile=0;
if(InputFile!=NULL)
ReadFile(InputFile);
else
{
printf(
"Welcome to LanHEP Version 3.1.1 (Nov 08 2010)\n");
/*
log_file=fopen("lhep.log","w");
if(log_file==NULL)
printf("Warning: can not open file lhep.log for writing.\n");
*/
ReadFile(NULL);
if(log_file!=NULL)
{
fclose(log_file);
log_file=0;
}
}
puts("");
/* AtomStatistics();
ListStatistics();
*/
if(save_flag)
{
Term t;
SaveRules(save_file);
if(itrSetIn("q.sav")==0)
return 0;
while((t=itrIn())!=0)
{
WriteTerm(t);
puts("");
}
itrCloseIn();
return 0;
}
if(ModelNumber!=0 || InputFile!=NULL)
{
if(MicroOmega)
ModelNumber=1;
RegisterLine("MAIN: writing lagrangian.");
WriteLagrFile(ModelNumber,ModelName);
UnregisterLine();
RegisterLine("MAIN: writing parameters and particles.");
WriteParameters(ModelNumber,ModelName);
WriteParticles(ModelNumber,ModelName);
if(MicroOmega)
{
ModelNumber=2;
SecondVaFu=1;
WriteParameters(ModelNumber,ModelName);
}
UnregisterLine();
WriteExtlib(ModelNumber,ModelName);
WriteCpart(ModelNumber,ModelName);
if(!TexOutput && !FAOutput && C_F_WIDTH<longest_cfline)
{
printf("Error: 'Common Factor' field longer than maximum of %d symbols.\n",
C_F_WIDTH);
printf("Use the statement 'option chepCFWidth=%d.'\n",longest_cfline+1);
}
if(!TexOutput && !FAOutput && L_P_WIDTH<longest_lpline)
{
printf("Error: 'Lorentz part' field longer than maximum of %d symbols.\n",
L_P_WIDTH);
printf("Use the statement 'option chepLPWidth=%d.'\n",longest_lpline+1);
}
if(!TexOutput && !FAOutput && P_D_WIDTH<longest_pdline)
{
if(P_D_WIDTH)
{
printf("Error: 'Parameter expression' field for '%s' is longer than maximum of %d symbols.\n",
AtomValue(llparam),P_D_WIDTH);
printf("Use the statement 'option chepPDWidth=%d.'\n",longest_pdline+1);
}
else if(longest_pdline>100)
printf("Longest parameter expression is %d symbols for '%s'.\n",longest_pdline,
AtomValue(llparam));
}
if(!TexOutput && !FAOutput && VerbMode)
{
printf("Longest Common factor line is %d symbols (max %d)\n",
longest_cfline,C_F_WIDTH);
printf("Longest Lorentz part line is %d symbols (max %d)\n",
longest_lpline,L_P_WIDTH);
printf("Longest Parameter dep line is %d symbols (max %d)\n\n",
longest_pdline,P_D_WIDTH);
}
}
/*
else
puts("Model # is zero");
*/
if(VerbMode)
{
int i;
printf("%5.1fMB of memory used.\n",
(ListMemory()+TermMemory())*0.001);
abbr_stat();
/*AtomStatistics();
ListStatistics();
for(i=0;i<10;i++)
if(inf_removed[i]) printf("%d pwr of inf: %d\n",i,inf_removed[i]);*/
}
if(err_cnt)
puts("!!!!!!!!!!!!! THERE WERE ERRORS DURING PROCESSING !!!!!!!!");
if(end_with_tty)
{
ReadFile(NULL);
puts("");
}
return 0;
}
Term ProcMkProc(Term t, Term ind)
{
Atom prt[4];
Atom mass[4];
Term color[4];
int spin[4];
int i;
int neufact=1;
double thcut=0.0;
int dec=0;
char pname[128];
FILE *f;
if(CompoundArity(t)==1)
{
List l,dlist;
double m1;
set_ppl();
l=GetAtomProperty(CompoundArg1(t),PROP_TYPE);
if(!is_compound(l)||CompoundName(l)!=OPR_PARTICLE ||
CompoundArgN(l,5)==0)
{
ErrorInfo(0);
WriteTerm(t);
printf(" : decays are not generated.\n");
return 0;
}
m1=fabs(EvalParameter(CompoundArgN(l,5)));
dlist=GetAtomProperty(CompoundArg1(t),PROP_PPL);
for(l=dlist;l;l=ListTail(l))
{
List pl=ListFirst(l);
Atom prp,a;
Atom ap1, ap2;
double m2,m3;
int is_neut;
if(ListLength(pl)!=2)
continue;
prp=GetAtomProperty(ListFirst(pl),PROP_TYPE);
if(!is_compound(prp)||CompoundName(prp)!=OPR_PARTICLE)
continue;
if(CompoundArgN(prp,7)==OPR_MLT)
continue;
a=CompoundArgN(prp,5);
if(a==0)
continue;
else
m2=fabs(EvalParameter(a));
prp=GetAtomProperty(ListFirst(ListTail(pl)),PROP_TYPE);
if(!is_compound(prp)||CompoundName(prp)!=OPR_PARTICLE)
continue;
if(CompoundArgN(prp,7)==OPR_MLT)
continue;
a=CompoundArgN(prp,5);
if(a==0)
continue;
else
m3=fabs(EvalParameter(a));
if(m1<=m2+m3)
continue;
is_neut=(CompoundArg1(t)==GetAtomProperty(CompoundArg1(t),A_ANTI));
ap1=GetAtomProperty(ListFirst(pl),A_ANTI);
ap2=GetAtomProperty(ListFirst(ListTail(pl)),A_ANTI);
if(is_neut)
{
List l1;
for(l1=dlist;l1!=l;l1=ListTail(l1))
{
if( (ListFirst(ListFirst(l1))==ap1 &&
ListFirst(ListTail(ListFirst(l1)))==ap2) ||
(ListFirst(ListFirst(l1))==ap2 &&
ListFirst(ListTail(ListFirst(l1)))==ap1))
break;
}
if(l1!=l)
continue;
}
/*WriteTerm(CompoundArg1(t));printf(" -> ");
WriteTerm(pl);puts("");*/
prp=MakeCompound(A_I,4);
SetCompoundArg(prp,1,CompoundArg1(t));
SetCompoundArg(prp,2,NewInteger(0));
SetCompoundArg(prp,3,is_neut?ListFirst(pl):ap1);
SetCompoundArg(prp,4,is_neut?ListFirst(ListTail(pl)):ap2);
ProcMkProc(prp,0);
}
return 0;
}
if(CompoundArity(t)<4)
{
ErrorInfo(2000);
puts("mkProc: wrong argument number.");
return 0;
}
for(i=5;i<=CompoundArity(t);i++)
{
Term t1=CompoundArgN(t,i);
if(is_compound(t1) && is_atom(CompoundArg1(t1)) &&
strcmp(AtomValue(CompoundArg1(t1)),"THETACUT")==0)
{
if(is_integer(CompoundArg2(t1)))
thcut=IntegerValue(CompoundArg2(t1));
else if(is_float(CompoundArg2(t1)))
thcut=FloatValue(CompoundArg2(t1));
else
{
ErrorInfo(303);puts("wrong THETACUT value.");
continue;
}
continue;
}
ErrorInfo(304);
puts("wrong argument in mkProc.");
}
for(i=0;i<4;i++)
{
Term prp, t7;
prt[i]=CompoundArgN(t,i+1);
if(prt[i]==NewInteger(0)&&i==1)
{
dec=1;spin[i]=0;color[1]=0;
continue;
}
if(!is_particle(prt[i],NULL))
{
ErrorInfo(2001);
WriteTerm(prt[i]);
puts(": is not a particle.");
return 0;
}
prp=GetAtomProperty(prt[i],PROP_TYPE);
if(CompoundName(prp)!=OPR_PARTICLE)
{
ErrorInfo(2001);
WriteTerm(prt[i]);
puts(": is not a particle.");
return 0;
}
if(prt[i]==CompoundArg2(prp))
prp=GetAtomProperty(CompoundArg1(prp),PROP_TYPE);
spin[i]=IntegerValue(CompoundArgN(prp,4));
mass[i]=CompoundArgN(prp,5);
color[i]=GetAtomProperty(prt[i],A_COLOR);
t7=CompoundArgN(prp,7);
if(i<2 && (t7==A_LEFT||t7==A_RIGHT))
neufact*=2;
}
if(dec==0)
sprintf(pname,"%s%s__%s%s",AtomValue(prt[0]),AtomValue(prt[1]),
AtomValue(prt[2]),AtomValue(prt[3]));
else
sprintf(pname,"%s__%s%s",AtomValue(prt[0]),
AtomValue(prt[2]),AtomValue(prt[3]));
for(i=0;pname[i];i++)
{
if(pname[i]=='~') pname[i]='_';
if(pname[i]=='+') pname[i]='p';
if(pname[i]=='-') pname[i]='m';
}
f=fopen("scan.bat",inifile?"a":"w");
if(f==NULL)
{
ErrorInfo(2000);
puts("mkProc: can not open scan.bat");
return 0;
}
if(!inifile)
{
fprintf(f,"#!/bin/sh\n\n");
inifile=1;
}
fprintf(f,"echo Generating process %s `date`\n\n",pname);
fprintf(f,"echo Process %s: >> scan.log\n",pname);
fprintf(f,"num0=`date +%%s`\n");
fprintf(f,"cat > proc.m <<END\n");
if(dec==0)
fprintf(f,"process = {prt[\"%s\"],prt[\"%s\"]} ->",
AtomValue(prt[0]),AtomValue(prt[1]));
else
fprintf(f,"process = {prt[\"%s\"]} ->",
AtomValue(prt[0]));
fprintf(f," {prt[\"%s\"],prt[\"%s\"]}\n",
AtomValue(prt[2]),AtomValue(prt[3]));
if(FAver==4)
fprintf(f,"dir = SetupCodeDir[\"scan_%s\"]\n",pname);
if(FAver>4)
fprintf(f,"name = \"%s\"\n",pname);
fprintf(f,"SetOptions[InsertFields,Model->model%d, GenericModel->model%d,\n",
ModelNumber,ModelNumber);
fprintf(f," ExcludeParticles->{ ");
if(color[0]&&color[1]&&color[2]&&color[3])
{
int glu=1,gno=1;
if(GetAtomProperty(prt[0],A_ANTI)!=prt[1]) glu=0;
if(spin[0]==0&&spin[1]==0&&spin[2]==0&&spin[3]==0) gno=0;
if(glu)
fprintf(f,"prt[\"G\"]%c ",gno?',':' ');
if(gno)
fprintf(f,"prt[\"~%c\"] ",ModelNumber>30?'G':'g');
}
fprintf(f,"} ]\n");
fprintf(f,"END\n\n");
fprintf(f,"if test ! -d scan_%s/squaredme ;\n",pname);
fprintf(f,"then math < %s.m;\n",dec?"scand":"scan");
fprintf(f,"fi\n\n");
fprintf(f,"num1=$((`date +%%s`-num0))\nnum0=`date +%%s`\n\n");
fprintf(f,"if test ! -d scan_%s/squaredme ;\n",pname);
fprintf(f,"then echo Output directory is not created | tee -a scan.log && exit;\n");
fprintf(f,"fi\n\n");
fprintf(f,"if test ! -d drivers/F ;\n");
fprintf(f,"then cat > scan_%s/process.h <<END\n",pname);
for(i=1;i<=4;i++)
{
int i1=i;
if(dec&&i==2) continue;
if(dec&&i>2) i1=i-1;
fprintf(f,"#define TYPE%d %s\n",i1,
spin[i-1]==0?"SCALAR":(spin[i-1]==1?"FERMION":
(mass[i-1]==0?"PHOTON":"VECTOR")));
fprintf(f,"#define MASS%d %s\n",i1,mass[i-1]?AtomValue(mass[i-1]):"0");
fprintf(f,"#define CHARGE%d 0\n\n",i1);
}
fprintf(f,"#define IDENTICALFACTOR %s\n",(prt[2]==prt[3])?"0.5":"1");
fprintf(f,"#define COLOURFACTOR %dD0",neufact);
if(color[0] && color[1]) fprintf(f,"/9D0");
else if(color[0] || color[1]) fprintf(f,"/3D0");
fprintf(f,"\n");
if(FAver>4)
{fprintf(f,"#define SCALE sqrtS\n#define LUMI \"lumi_parton.F\"\n");
fprintf(f,"c#define FORCE_ONSHELL\n");
}
fprintf(f,"#define NCOMP 2\n#include \"%cto2.F\"\nEND\n\nfi\n\n",dec?'1':'2');
/*
fprintf(f,"cp model%d.h scan_%s/model.h\n",ModelNumber,pname);
fprintf(f,"cp mdl_ini%d.F scan_%s/mdl_ini.F\n\n",ModelNumber,pname);
*/
if(FAver==4)
fprintf(f,"cp main.F scan_%s/\n\n",pname);
if(thcut!=0.0)
{
fprintf(f,"echo \"#define THETACUT (%f*degree)\" > scan_%s/run.F\n",
thcut,pname);
fprintf(f,"grep -v THETACUT drivers/run.F >> scan_%s/run.F\n",pname);
}
fprintf(f,"cd scan_%s\n",pname);
fprintf(f,"sz0=`du -sm .`\n");
fprintf(f,"if test ! -f run ;\n");
fprintf(f,"then ./configure ;\n");
fprintf(f,"fi\n\n");
fprintf(f,"rm run ru*.01000*/*\n");
fprintf(f,"gmake\n");
fprintf(f,"if test ! -f run ;\n");
fprintf(f,"then echo Run file is not created | tee -a ../scan.log && exit;\n");
fprintf(f,"fi\n");
fprintf(f,"num2=$((`date +%%s`-num0))\nnum0=`date +%%s`\n\n");
fprintf(f,"sz1=`du -sm .`\n");
fprintf(f,"./run uuuu 1000,1000\n");
if(FAver>4)
fprintf(f,"../exval6 ru*.01000*/* >> ../scan.log\n\n\n");
fprintf(f,"cd ..\n");
// fprintf(f,"grep \"| 1000.000\" scan_%s/ru*.01000*/* >> scan.log\n\n\n",
// pname);
if(FAver==4)
fprintf(f,"./exval scan_%s/ru*.01000*/* >> scan.log\n\n\n",pname);
fprintf(f,"num3=$((`date +%%s`-num0))\n\n");
fprintf(f,"echo $num1 + $num2 + $num3 = $(((num1+num2+num3)/60))");
fprintf(f," min \\\n $sz0/$sz1 MB >> scan.log\n");
fprintf(f,"rm -rf scan_%s\n\n",pname);
fclose(f);
return 0;
}
static Term dif_term(Term t)
{
if(t==A_SQRT2 || t==A_I || is_float(t) || is_integer(t))
return 0;
if(is_atom(t) && is_parameter(t))
return MakeCompound1(OPR_USCORE,t);
if(!is_compound(t))
{
printf("Can't variate "); WriteTerm(t); puts(""); return 0;
}
if(CompoundName(t)==OPR_PLUS && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return d2;
if(d2==0)
return d1;
return MakeCompound2(OPR_PLUS,d1,d2);
}
if(CompoundName(t)==OPR_MINUS && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return d2;
if(d2==0)
return d1;
return MakeCompound2(OPR_MINUS,d1,d2);
}
if(CompoundName(t)==OPR_MINUS && CompoundArity(t)==1)
{
Term d1;
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
return MakeCompound1(OPR_MINUS,d1);
}
if(CompoundName(t)==A_SQRT && CompoundArity(t)==1)
{
Term d1;
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
if(is_compound(d1) && CompoundName(d1)==OPR_MLT &&
CompoundArg1(d1)==NewInteger(2))
{
Term d2;
d2=ConsumeCompoundArg(d1,2);
FreeAtomic(d1);
return MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV,d2,t));
}
return MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV, d1,
MakeCompound2(OPR_MLT, NewInteger(2), t)));
}
if(CompoundName(t)==OPR_POW && CompoundArity(t)==2)
{
Term d1;
int ppow;
ppow=IntegerValue(CompoundArg2(t));
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
if(ppow==2)
return MakeCompound2(OPR_MLT,NewInteger(2),
MakeCompound2(OPR_MLT, CompoundArg1(t), d1));
return MakeCompound2(OPR_MLT, d1, MakeCompound2(OPR_POW,
CompoundArg1(t),NewInteger(ppow-1)));
}
if(CompoundName(t)==OPR_MLT && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return MakeCompound2(OPR_MLT,CompoundArg1(t),d2);
if(d2==0)
return MakeCompound2(OPR_MLT,CompoundArg2(t),d1);
return MakeCompound2(OPR_PLUS,
MakeCompound2(OPR_MLT,CompoundArg1(t),d2),
MakeCompound2(OPR_MLT,CompoundArg2(t),d1));
}
if(CompoundName(t)==OPR_DIV && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return
MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV,
MakeCompound2(OPR_MLT,d2,CompoundArg1(t)),
MakeCompound2(OPR_POW,CompoundArg2(t),NewInteger(2))
)
);
if(d2==0)
return MakeCompound2(OPR_DIV,d1,CompoundArg2(t));
return
MakeCompound2(OPR_DIV,
MakeCompound2(OPR_MINUS,
MakeCompound2(OPR_MLT,d1,CompoundArg2(t)),
MakeCompound2(OPR_MLT,d2,CompoundArg1(t))
),
MakeCompound2(OPR_POW,CompoundArg2(t),NewInteger(2))
);
}
printf("Can't variate "); WriteTerm(t); puts("");
return 0;
}
Term AtomicTo1(Term t, Term ind)
{
List rl;
Term ret;
Term t1;
Atom ttype;
if(is_compound(t) && CompoundName(t)==A_ALG1)
{
List l;
ttype=A_ALG1;
rl=CopyTerm(CompoundArg2(t));
for(l=rl;l;l=ListTail(l))
SetCompoundArg(ListFirst(l),2,0);
goto cnt;
}
if(is_compound(t) && CompoundName(t)==A_FBRACET)
{
t=alg1_mk_wild(t,&rl,&ind);
ttype=OPR_WILD;
goto cnt;
}
/*
if(is_compound(t) && CompoundName(t)==A_CC)
{
t=cc_particle(t,&rl);
ttype=OPR_FIELD;
goto cnt;
}
*/
if(is_let(t,&rl))
{
ttype=OPR_LET;
goto cnt;
}
if(is_parameter(t) || (is_compound(t) && (CompoundName(t)==A_COS ||
CompoundName(t)==A_SIN)) )
{
rl=NewList();
ttype=OPR_PARAMETER;
goto cnt;
}
if(is_particle(t,&rl))
{
ttype=OPR_FIELD;
goto cnt;
}
if(is_special(t,&rl))
{
ttype=OPR_SPECIAL;
goto cnt;
}
ErrorInfo(301);
printf(" \'%s\' undefined object.\n",AtomValue(t));
FreeAtomic(ind);
longjmp(alg1_jmp_buf,1);
cnt:
ret=MakeCompound(A_MTERM,4);
SetCompoundArg(ret,1,NewInteger(1));
SetCompoundArg(ret,2,NewInteger(1));
t1=0;
if(!is_empty_list(rl))
{
Term ttt;
int skipped;
rl=CopyTerm(rl);
if(is_empty_list(ind))
{
SetCompoundArg(ret,3,AppendFirst(NewList(),MakeCompound2(ttype,rl,t)));
return AppendFirst(NewList(),ret);
}
skipped=must_skip(ListLength(ind),rl);
if(skipped==-1)
{
ErrorInfo(302);
printf(" can not set indices ");
WriteTerm(ind);
printf(" to \'%s\'.\n",AtomValue(t));
FreeAtomic(ind); FreeAtomic(rl);
longjmp(alg1_jmp_buf,1);
}
t1=rl;
ttt=ind;
while(!is_empty_list(rl))
{
if(skipped!=0 && should_skip(skipped,CompoundArg1(ListFirst(rl))))
{ rl=ListTail(rl); continue; }
SetCompoundArg(ListFirst(rl),2,ListFirst(ttt));
rl=ListTail(rl);
ttt=ListTail(ttt);
}
FreeAtomic(ind);
}
if(ttype==OPR_PARAMETER && is_compound(t))
{
Term mmm=MakeCompound(ttype,CompoundArity(t)+2);
SetCompoundArg(mmm,1,t1);
SetCompoundArg(mmm,2,CompoundName(t));
SetCompoundArg(mmm,3,CompoundArg1(t));
if(CompoundArity(t)==2)
{
Term m=ExprTo1(ConsumeCompoundArg(t,2));
m=CompoundArg1(m);
if(ListLength(m)!=1)
{
ErrorInfo(0);
puts("bad expression in sin/cos.");
longjmp(alg1_jmp_buf,1);
}
m=ListFirst(m);
SetCompoundArg(mmm,4,m);
}
SetCompoundArg(ret,3,AppendFirst(NewList(),mmm));
}
else
SetCompoundArg(ret,3,AppendFirst(NewList(),MakeCompound2(ttype,t1,t)));
return AppendFirst(NewList(),ret);
}
Term ExpandTerm(Term t)
{
List il=0;
Term res;
/*puts("");
WriteTerm(t);
puts("\n");*/
if(is_compound(t) && (CompoundName(t)==OPR_USCORE || CompoundName(t)==OPR_CARET))
{
t=SplitIndices(t,&il);
if(t==0)
longjmp(alg1_jmp_buf,1);
}
if(is_function(t,NULL))
return ExpandTerm(CallFunction(t,il));
if(is_float(t))
{
ErrorInfo(303);
printf(" illegal use of floating point number %f.\n",FloatValue(t));
FreeAtomic(t);
longjmp(alg1_jmp_buf,1);
}
if(is_integer(t))
{
if(IntegerValue(t)==0)
return 0;
if(il)
{
ErrorInfo(304);
puts("Integer can't have indices.\n");
longjmp(alg1_jmp_buf,1);
}
res=MakeCompound(A_MTERM,4);
SetCompoundArg(res,1,t);
SetCompoundArg(res,2,NewInteger(1));
return AppendFirst(0,res);
}
if(t==A_I)
{
res=MakeCompound(A_MTERM,4);
SetCompoundArg(res,1,NewInteger(1));
SetCompoundArg(res,2,NewInteger(-1));
return AppendFirst(0,res);
}
if(is_atom(t) || (is_compound(t) && CompoundName(t)==A_FBRACET) ||
(is_compound(t) && CompoundName(t)==A_ALG1 && CompoundArity(t)==2) ||
(is_compound(t) && (CompoundName(t)==A_SIN || CompoundName(t)==A_COS)
&& CompoundArity(t)<3 && is_integer(CompoundArg1(t))))
return AtomicTo1(t,il);
if(!is_empty_list(il))
{
ErrorInfo(307);
printf(" bad indices ");
WriteTerm(il);
printf(" in expression.\n");
longjmp(alg1_jmp_buf,1);
}
if(opSetGpm && is_compound(t) && CompoundArity(t)==2 && CompoundArg1(t)==NewInteger(1)
&& is_atom(CompoundArg2(t))
&& (CompoundArg2(t)==A_GAMMA5 || GetAtomProperty(CompoundArg2(t),A_GAMMA5))
&& (CompoundName(t)==OPR_PLUS || CompoundName(t)==OPR_MINUS))
{
Term ret,sp;
ret=MakeCompound(A_MTERM,4);
SetCompoundArg(ret,1,NewInteger(2));
SetCompoundArg(ret,2,NewInteger(1));
sp=MakeCompound(OPR_SPECIAL,2);
if(CompoundName(t)==OPR_PLUS)
SetCompoundArg(sp,2,A_GAMMAP);
else
SetCompoundArg(sp,2,A_GAMMAM);
SetCompoundArg(sp,1,CopyTerm(GetAtomProperty(A_GAMMA5,PROP_INDEX)));
SetCompoundArg(ret,3,AppendLast(NewList(),sp));
return AppendLast(NewList(),ret);
}
if(is_compound(t) && CompoundName(t)==OPR_PLUS && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
return ConcatList(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_MINUS && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
mult_no(t2,-1);
return ConcatList(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_MINUS && CompoundArity(t)==1)
{
Term t1;
t1=ConsumeCompoundArg(t,1);
FreeAtomic(t);
t1=ExpandTerm(t1);
mult_no(t1,-1);
return t1;
}
if(is_compound(t) && CompoundName(t)==OPR_MLT && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
return multiply_l(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_DIV && CompoundArity(t)==2)
{
Term t1,t2,t2s;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2s=CopyTerm(t2);
t2=ExpandTerm(t2);
if(ListLength(t2)!=1)
{
ErrorInfo(306);
printf(" cannot divide by \'");
WriteTerm(t2s); printf("\'.\n");
FreeAtomic(t1); FreeAtomic(t2); FreeAtomic(t2s);
longjmp(alg1_jmp_buf,1);
}
FreeAtomic(t2s);
invert_term(ListFirst(t2));
return multiply_l(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_POW && CompoundArity(t)==2)
{
Term t1,t2,ret;
int i,pp;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
if(!is_integer(t2) || IntegerValue(t2)<1)
{
ErrorInfo(307);
printf(" illegal power \'");
WriteTerm(t2); printf("\'.\n");
FreeAtomic(t1); FreeAtomic(t2);
longjmp(alg1_jmp_buf,1);
}
pp=IntegerValue(t2);
t1=ExpandTerm(t1);
ret=CopyTerm(t1);
for(i=2;i<=pp;i++)
{
Term tmp;
tmp=CopyTerm(t1);
ret=multiply_l(ret,tmp);
}
FreeAtomic(t1);
return ret;
}
ErrorInfo(309);
printf("bad expression ");
WriteTerm(t);
puts("");
longjmp(alg1_jmp_buf,1);
}
static int set_ppl(void)
{
List l;
if(PROP_PPL==0) PROP_PPL=NewAtom("pprtlst",0);
if(prop_gened)
return 1;
if(vlist==0)
{
vlist=all_vert_list();
for(l=vlist; !is_empty_list(l); l=ListTail(l))
{
Term a2;
a2=ListFirst(l);
alg2_common_s(a2);
alg2_common_n(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
}
}
for(l=vlist; !is_empty_list(l); l=ListTail(l))
{
List pl,l1,l2,lr;
pl=CompoundArg1(ListFirst(l));
if(ListLength(pl)<3 || CompoundArg2(ListFirst(l))==NewInteger(0) ||
is_empty_list(CompoundArgN(ListFirst(l),5)))
continue;
#ifdef DBG_PPL
WriteVertex(pl); printf(": ");
#endif
l1=pl;
while(!is_empty_list(l1))
{
Atom pp,app;
Term prop;
pp=CompoundArg1(ListFirst(l1));
prop=GetAtomProperty(pp,PROP_TYPE);
app=remcc(pp);
if(!ListMember(plist,app))
plist=AppendFirst(plist,app);
#ifdef DBG_PPL
WriteTerm(app); printf(" -> ");
#endif
lr=NewList();
l2=pl;
while(!is_empty_list(l2))
{
Atom a;
if(l2==l1)
{
l2=ListTail(l2);
continue;
}
a=remcc(CompoundArg1(ListFirst(l2)));
lr=AppendLast(lr,a);
l2=ListTail(l2);
}
prop=GetAtomProperty(app,PROP_PPL);
if(prop==0)
SetAtomProperty(app,PROP_PPL,AppendFirst(NewList(),lr));
else
AppendLast(prop,lr);
#ifdef DBG_PPL
WriteTerm(lr); printf(" ");
#endif
while(!is_empty_list(l1) &&
remcc(CompoundArg1(ListFirst(l1)))==app)
l1=ListTail(l1);
}
#ifdef DBG_PPL
puts("");
#endif
}
if(ListLength(plist)>1)
plist=SortedList(plist,p__cmp);
prop_gened=1;
return 1;
}
Term ProcLet(Term t, Term ind)
{
Term t1,nm,sub,kl=0;
List il,ol,l1;
int transf_fl=0;
Atom anti1=0, anti2=0;
ol=il=NewList();
t1=ConsumeCompoundArg(t,1);
FreeAtomic(t);
t1=ProcessAlias(t1);
if(is_compound(t1) && CompoundArity(t1)==2 && CompoundName(t1)==OPR_COMMA)
{
Term a1,a2;
a1=ConsumeCompoundArg(t1,1);
a2=ConsumeCompoundArg(t1,2);
FreeAtomic(t1);
ProcLet(MakeCompound1(OPR_LET,a1),0);
ProcLet(MakeCompound1(OPR_LET,a2),0);
return 0;
}
if(!is_compound(t1) || CompoundArity(t1)!=2 ||
(CompoundName(t1)!=OPR_EQSIGN && CompoundName(t1)!=OPR_RARROW))
{
ErrorInfo(325);
printf("bad argument in let statement\n");
return 0;
}
if(CompoundName(t1)==OPR_EQSIGN && is_atom(CompoundArg1(t1)) &&
is_atom(CompoundArg2(t1)) &&
(CompoundArg2(t1)==A_GAMMA5 || GetAtomProperty(CompoundArg2(t1),
A_GAMMA5)))
{
SetAtomProperty(CompoundArg1(t1),A_GAMMA5,NewInteger(1));
}
if(CompoundName(t1)==OPR_RARROW)
transf_fl=1;
if(CompoundName(t1)==OPR_EQSIGN && is_atom(CompoundArg1(t1)) &&
is_compound(CompoundArg2(t1)) &&
CompoundName(CompoundArg2(t1))==A_ANTI &&
is_atom(CompoundArg1(CompoundArg2(t1))))
{
anti1=CompoundArg1(t1);
anti2=CompoundArg1(CompoundArg2(t1));
}
nm=ConsumeCompoundArg(t1,1);
sub=ConsumeCompoundArg(t1,2);
FreeAtomic(t1);
if(transf_fl)
allow_transf_lets=0;
if(is_compound(nm) && (CompoundName(nm)==OPR_USCORE ||
CompoundName(nm)==OPR_CARET))
nm=SplitIndices(nm,&il);
if(!is_atom(nm))
{
ErrorInfo(325);
printf("bad left argument in let call\n");
FreeAtomic(sub);
FreeAtomic(t1);
return 0;
}
if(transf_fl)
{
if(!is_parameter(nm) && !is_particle(nm,NULL))
{
ErrorInfo(728);
printf("Unknown object '%s'.\n",AtomValue(nm));
return 0;
}
}
if(GetAtomProperty(nm,A_KEEP_LETS))
{
Term prp;
kl=ExprTo1kl(CopyTerm(sub));
if(kl==0)
return 0;
prp=GetAtomProperty(nm,A_KEEP_LETS);
SetCompoundArg(prp,1,kl);
}
sub=ExprTo1(sub);
alg1_set_cos0(sub);
if(sub==0)
return 0;
if(transf_fl)
allow_transf_lets=1;
t1=CopyTerm(CompoundArg2(sub));
if(is_empty_list(il))
{
l1=t1;
while(!is_empty_list(l1))
{
Term t;
t=CompoundArg2(ListFirst(l1));
if(!is_label(t))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
ol=AppendLast(ol,t);
l1=ListTail(l1);
}
/* mk_let(nm,sub,ol,t1); */
}
else
{
List t2;
t2=0;
if(ListLength(il)!=ListLength(t1))
{
ErrorInfo(327);
printf("distinct indices number ");
printf("in let statement.\n");
FreeAtomic(sub);
FreeAtomic(t1);
return 0;
}
l1=t1;
while(!is_empty_list(l1))
{
Term t;
t=CompoundArg2(ListFirst(l1));
if(!is_atom(t) || !ListMember(il,t))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
ol=AppendLast(ol,t);
l1=ListTail(l1);
}
l1=il;
while(!is_empty_list(l1))
{
List l2;
if(!ListMember(ol,ListFirst(l1)))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
for(l2=t1;l2;l2=ListTail(l2))
if(ListFirst(l1)==CompoundArg2(ListFirst(l2)))
{
t2=AppendLast(t2,ListFirst(l2));
break;
}
l1=ListTail(l1);
}
RemoveList(t1);
t1=t2;
FreeAtomic(ol);
ol=il;
}
/* mk_let(nm,sub,ol,t1); */
l1=t1;
while(!is_empty_list(l1))
{
SetCompoundArg(ListFirst(l1),2,0);
l1=ListTail(l1);
}
/*WriteTerm(sub); puts(""); getchar();*/
t=MakeCompound(OPR_LET,5);
SetCompoundArg(t,1,sub);
SetCompoundArg(t,2,ol);
SetCompoundArg(t,3,alg1_inv_alg(sub));
if(transf_fl==0)
{
Term tt;
tt=alg1_guess_mpl(sub);
if(tt)
{
SetCompoundArg(t,4,NewInteger(1));
SetCompoundArg(t,5,tt);
}
else
{
int tp;
tt=alg1_guess_mtr(sub, &tp);
if(tt)
{
SetCompoundArg(t,4,NewInteger(tp));
SetCompoundArg(t,5,tt);
}
}
ReportRedefined(nm,"let-substitution");
SetAtomProperty(nm,PROP_INDEX,t1);
SetAtomProperty(nm,PROP_TYPE,t);
alg1_let_cw(nm);
if(anti1 && anti2)
{
SetAtomProperty(anti1,A_ANTI,anti2);
SetAtomProperty(anti2,A_ANTI,anti1);
}
else
if(only_prm(CompoundArg1(t)))
SetAtomProperty(nm,A_ANTI,nm);
return 0;
}
l1=GetAtomProperty(nm,PROP_INDEX);
if(!EqualTerms(l1,t1))
{
ErrorInfo(729);
puts("transformed object has other indices types");
return 0;
}
if(GetAtomProperty(nm,OPR_LET))
{
WarningInfo(0);
printf("Warning: transformation rule for '%s' is redefined.\n",
AtomValue(nm));
}
SetAtomProperty(nm,OPR_LET,t);
return 0;
}
Term ProcImPrt(Term t, Term ind)
{
int spin, col, anti;
Atom n, an;
Term prt;
Atom pcomm=0, ptname=0;
if(!is_compound(t) || CompoundArity(t)<3 || CompoundArity(t)>5 ||
!is_integer(CompoundArg1(t)) || !is_integer(CompoundArg2(t)) ||
!is_integer(CompoundArgN(t,3)) ||
(CompoundArity(t)>3 && !is_atom(CompoundArgN(t,4))) ||
(CompoundArity(t)>4 && !is_atom(CompoundArgN(t,5))) )
{
ErrorInfo(502);
printf("AuxPrt: bad arguments ");WriteTerm(t);puts("");
return 0;
}
spin=IntegerValue(CompoundArg1(t));
col= IntegerValue(CompoundArg2(t));
anti=IntegerValue(CompoundArgN(t,3));
if(CompoundArity(t)>3)
pcomm=CompoundArgN(t,4);
if(CompoundArity(t)>4)
ptname=CompoundArgN(t,5);
FreeAtomic(t);
n=NewName();
if(anti)
an=NewName();
else
an=n;
if(1)
{
prt=MakeCompound(OPR_PARTICLE,8);
SetCompoundArg(prt,1,n);
SetCompoundArg(prt,2,an);
SetCompoundArg(prt,3,pcomm?pcomm:NewAtom("im particle",0));
SetCompoundArg(prt,4,NewInteger(spin?2:0));
SetCompoundArg(prt,5,spin==2?0:NewAtom("Maux",0));
if(spin<2)
SetCompoundArg(prt,7,OPR_MLT);
else
SetCompoundArg(prt,7,A_GAUGE);
if(col>1)
{
Term cl;
if(col==8)
cl=MakeCompound2(A_COLOR,NewAtom("c8",0),NewAtom("c8",0));
else
cl=MakeCompound2(A_COLOR,NewAtom("c3",0),NewAtom("c3b",0));
SetCompoundArg(prt,8,AppendFirst(NewList(),cl));
}
AddIMParticle(prt);
if(ptname)
{
char bbb[64];
SetAtomProperty(n,A_TEXNAME,ptname);
sprintf(bbb,"{\\bar{%s}}",AtomValue(ptname));
SetAtomProperty(an,A_TEXNAME,NewAtom(bbb,0));
}
}
if(spin<2)
{
if(!intr_param)
{
Term t1,t2,t3;
t1=NewCompound(NewFunctor(OPR_PARAMETER,1));
t2=NewCompound(NewFunctor(OPR_EQSIGN,2));
t3=NewCompound(NewFunctor(OPR_COLON,2));
SetCompoundArg(t1,1,t2);
SetCompoundArg(t2,1,NewAtom("Maux",0));
SetCompoundArg(t2,2,t3);
SetCompoundArg(t3,1,NewInteger(1));
SetCompoundArg(t3,2,NewAtom("mass of aux particles",0));
ProcessParameter(t1,0);
intr_param=1;
}
return n;
}
sprintf(nnbuf,"%s.t",AtomValue(n));
n=NewAtom(nnbuf,0);
return n;
}
void ProcessTerm(Term t)
{
Term res;
Atom procc=0;
char regbuf[80];
if(is_compound(t)&&CompoundName(t)==OPR_LOCAL)
{
List l1,la=ConsumeCompoundArg(t,1);
if(l_pro==0)
{
ErrorInfo(0);
puts("local: must be within template.");
return;
}
la=CommaToList(la);
for(l1=la;l1;l1=ListTail(l1))
l_ali=AppendLast(l_ali,
InterfSetAlias(MakeCompound1(OPR_ALIAS,ListFirst(l1)),0));
RemoveList(la);
return;
}
/* if(is_compound(t) && GetAtomProperty(CompoundName(t),OPR_ALIAS))
{*/
if(!is_compound(t) || (CompoundName(t)!=OPR_ALIAS &&
CompoundName(t)!=OPR_IN && CompoundName(t)!=OPR_WHERE) )
{
t=ProcessAlias(t);
proc_hash(t);
}
/*WriteTerm(t);puts("");*/
/*}*/
if(is_list(t))
{
List l, alisav;
l_pro++;
alisav=l_ali;
l_ali=0;
for(l=t;l;l=ListTail(l))
ProcessTerm(ListFirst(l));
if(l_ali)
RemoveAlias(l_ali);
RemoveList(t);
l_pro--;
l_ali=alisav;
return;
}
if(is_atom(t))
procc=t;
if(is_compound(t))
{
procc=CompoundName(t);
}
if(procc==0)
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Not a valid operator \'");
WriteTerm(t);
printf("\'.\n");
FreeAtomic(t);
return;
}
if(!IsTermInput())
sprintf(regbuf, "ProcTerm: File %s, line %d: %s statement.",
CurrentInputFile(), CurrentInputLine(), AtomValue(procc));
else
sprintf(regbuf, "(tty): %s statement.",AtomValue(procc));
RegisterLine(regbuf);
if(!is_function(t,NULL))
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Unknown operator \'%s\' in expression\n\t",AtomValue(procc));
WriteTerm(t);
puts("");
FreeAtomic(t);
UnregisterLine();
return;
}
if(is_compound(t) && ((VerbMode && CompoundName(t)==OPR_LTERM) ||
VerbMode==3))
{
char sment[1024];
sWriteTerm(sment,t);
sment[55]='.';
sment[56]='.';
sment[57]='.';
sment[58]=0;
printf("%s:%3d: %s\n",CurrentInputFile(),CurrentInputLine(),sment);
}
res=CallFunction(t,0);
if(res!=0 && (IsTermInput()))
{
if(is_compound(res) && CompoundArity(t)==2 &&
CompoundName(res)==A_ALG1)
res=Alg1ToExpr(res);
if(is_list(res))
DumpList(res);
else
{
WriteTerm(res);
puts("");
}
FreeAtomic(res);
}
UnregisterLine();
}
