passagemath-singular 10.6.31rc3__cp314-cp314-manylinux_2_27_x86_64.manylinux_2_28_x86_64.whl

sage_wheels/share/singular/LIB/bfun.lib

@@ -0,0 +1,1964 @@
+/////////////////////////////////////////////////////////////////////////////
+version="version bfun.lib 4.3.1.3 Feb_2023 "; // $Id: a7fb178fc64d45b6d2539c9f85efaac32ad2aec4 $
+category="Noncommutative";
+info="
+LIBRARY: bfun.lib     Algorithms for b-functions and Bernstein-Sato polynomial
+AUTHORS: Daniel Andres, daniel.andres@math.rwth-aachen.de
+@* Viktor Levandovskyy,      levandov@math.rwth-aachen.de
+
+OVERVIEW:
+Given a polynomial ring R = K[x_1,...,x_n] and a polynomial F in R,
+one is interested in the global b-function (also known as Bernstein-Sato
+polynomial) b(s) in K[s], defined to be the non-zero monic polynomial of minimal
+degree, satisfying a functional identity L * F^{s+1} = b(s) F^s,
+for some operator L in D[s] (* stands for the action of differential operator)@*
+By D one denotes the n-th Weyl algebra
+K<x_1,...,x_n,d_1,...,d_n | d_j x_j = x_j d_j +1>.
+One is interested in the following data:@*
+  - Bernstein-Sato polynomial b(s) in K[s],@*
+  - the list of its roots, which are known to be rational@*
+  - the multiplicities of the roots.@*
+
+There is a constructive definition of a b-function of a holonomic ideal I in D
+(that is, an ideal I in a Weyl algebra D, such that D/I is holonomic module)
+with respect to the given weight vector w: For a polynomial p in D, its initial
+form w.r.t. (-w,w) is defined as the sum of all terms of p which have
+maximal weighted total degree where the weight of x_i is -w_i and the weight
+of d_i is w_i. Let J be the initial ideal of I w.r.t. (-w,w), i.e. the
+K-vector space generated by all initial forms w.r.t (-w,w) of elements of I.
+Put s = w_1 x_1 d_1 + ... + w_n x_n d_n. Then the monic generator b_w(s) of
+the intersection of J with the PID K[s] is called the b-function of I w.r.t.  w.
+Unlike Bernstein-Sato polynomial, general b-function with respect to
+arbitrary weights need not have rational roots at all. However, b-function
+of a holonomic ideal is known to be non-zero as well.
+
+REFERENCES: [SST] Saito, Sturmfels, Takayama: Groebner Deformations of
+Hypergeometric Differential Equations (2000),@*
+Noro: An Efficient Modular Algorithm for Computing the Global b-function,
+(2002).
+
+
+PROCEDURES:
+bfct(f[,s,t,v]);            compute the BS polynomial of f with linear reductions
+bfctSyz(f[,r,s,t,u,v]);     compute the BS polynomial of f with syzygy-solver
+bfctAnn(f[,s]);             compute the BS polynomial of f via Ann f^s + f
+bfctOneGB(f[,s,t]);         compute the BS polynomial of f by just one GB computation
+bfctIdeal(I,w[,s,t]);       compute the b-function of ideal w.r.t. weight
+pIntersect(f,I[,s]);        intersection of ideal with subalgebra K[f] for a polynomial f
+pIntersectSyz(f,I[,p,s,t]); intersection of ideal with subalgebra K[f] with syz-solver
+linReduce(f,I[,s]);         reduce a polynomial by linear reductions w.r.t. ideal
+linReduceIdeal(I,[s,t]);    interreduce generators of ideal by linear reductions
+linSyzSolve(I[,s]);         compute a linear dependency of elements of ideal I
+
+allPositive(v);             checks whether all entries of an intvec are positive
+scalarProd(v,w);            computes the standard scalar product of two intvecs
+vec2poly(v[,i]);            constructs an univariate polynomial with given coefficients
+
+
+SEE ALSO: dmod_lib, dmodapp_lib, dmodvar_lib, gmssing_lib
+
+KEYWORDS: D-module; global Bernstein-Sato polynomial; Bernstein-Sato polynomial; b-function;
+graded Weyl algebra; initial ideal; initial form; principal intersection; linear interreduction;
+initial ideal approach
+";
+
+
+
+/*
+CHANGELOG
+
+03.03.11:
+- simplified scalarProd
+- fixed bug in bfct when user used vars t,Dt
+- now bFactor is used by bfct, bfctAnn, i.e. the static procs
+  addRoot, listofroots are superfluous
+- fixed printlevel/debug message issue in bfct, bfctAnn
+- fixed small issue for zero ideal input in linReduceIdeal
+
+16.03.11
+- fixed bug in linReduceIdeal when ideal contained unlucky constellation
+  of zeros
+- fixed printlevel/debug message issue in linReduceIdeal
+*/
+
+
+
+LIB "qhmoduli.lib"; // for Max
+LIB "dmod.lib";     // for SannfsBFCT etc
+LIB "dmodapp.lib";  // for initialIdealW etc
+LIB "nctools.lib";  // for isWeyl etc
+LIB "presolve.lib"; // for valvars
+
+//--------------- auxiliary procedures ----------------------------------------
+
+/*
+static proc gradedWeyl (intvec u,intvec v)
+"USAGE:  gradedWeyl(u,v); u,v intvecs
+RETURN:  a ring, the associated graded ring of the basering w.r.t. u and v
+PURPOSE: compute the associated graded ring of the basering w.r.t. u and v
+ASSUME: basering is a Weyl algebra
+EXAMPLE: example gradedWeyl; shows examples
+NOTE:    u[i] is the weight of x(i), v[i] the weight of D(i).
+@*       u+v has to be a non-negative intvec.
+"
+{
+  // todo check assumption
+  int i;
+  def save = basering;
+  int n = nvars(save) div 2;
+  if (nrows(u)<>n || nrows(v)<>n)
+  {
+    ERROR("weight vectors have wrong dimension");
+  }
+  intvec uv,gr;
+  uv = u+v;
+  for (i=1; i<=n; i++)
+  {
+    if (uv[i]>=0)
+    {
+      if (uv[i]==0)
+      {
+        gr[i] = 0;
+      }
+      else
+      {
+        gr[i] = 1;
+      }
+    }
+    else
+    {
+      ERROR("the sum of the weight vectors has to be a non-negative intvec");
+    }
+  }
+  list l = ringlist(save);
+  list l2 = l[2];
+  matrix l6 = l[6];
+  for (i=1; i<=n; i++)
+  {
+    if (gr[i] == 1)
+    {
+       l2[n+i] = "xi("+string(i)+")";
+       l6[i,n+i] = 0;
+    }
+  }
+  l[2] = l2;
+  l[6] = l6;
+  def G = ring(l);
+  return(G);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring @D = 0,(x,y,z,Dx,Dy,Dz),dp;
+  def D = Weyl();
+  setring D;
+  intvec u = -1,-1,1; intvec v = 2,1,1;
+  def G = gradedWeyl(u,v);
+  setring G; G;
+}
+*/
+
+static proc safeVarName (string s)
+{
+  string S = "," + charstr(basering) + "," + varstr(basering) + ",";
+  s = "," + s + ",";
+  while (find(S,s) <> 0)
+  {
+    s[1] = "@";
+    s = "," + s;
+  }
+  s = s[2..size(s)-1];
+  return(s)
+}
+
+proc allPositive (intvec v)
+"USAGE:  allPositive(v);  v an intvec
+RETURN:  int, 1 if all components of v are positive, or 0 otherwise
+PURPOSE: check whether all components of an intvec are positive
+EXAMPLE: example allPositive; shows an example
+"
+{
+  int i;
+  for (i=1; i<=size(v); i++)
+  {
+    if (v[i]<=0)
+    {
+      return(0);
+      break;
+    }
+  }
+  return(1);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  intvec v = 1,2,3;
+  allPositive(v);
+  intvec w = 1,-2,3;
+  allPositive(w);
+}
+
+static proc findFirst (list l, def i)
+"USAGE:  findFirst(l,i);  l a list, i an argument of any type
+RETURN:  int, the position of the first appearance of i in l,
+@*       or 0 if i is not a member of l
+PURPOSE: check whether the second argument is a member of a list
+EXAMPLE: example findFirst; shows an example
+"
+{
+  int j;
+  for (j=1; j<=size(l); j++)
+  {
+    if (l[j]==i)
+    {
+      return(j);
+      break;
+    }
+  }
+  return(0);
+}
+//   findFirst(list(1, 2, list(1)),2);       // seems to be a bit buggy,
+//   findFirst(list(1, 2, list(1)),3);       // but works for the purposes
+//   findFirst(list(1, 2, list(1)),list(1)); // of this library
+//   findFirst(l,list(2));
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,x,dp;
+  list l = 1,2,3;
+  findFirst(l,4);
+  findFirst(l,2);
+}
+
+proc scalarProd (intvec v, intvec w)
+"USAGE:  scalarProd(v,w);  v,w intvecs
+RETURN:  int, the standard scalar product of v and w
+PURPOSE: computes the scalar product of two intvecs
+ASSUME:  the arguments are of the same size
+EXAMPLE: example scalarProd; shows examples
+"
+{
+  if (size(v)!=size(w))
+  {
+    ERROR("non-matching dimensions");
+  }
+  else
+  {
+    intvec u = transpose(v)*w;
+  }
+  return(u[1]);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  intvec v = 1,2,3;
+  intvec w = 4,5,6;
+  scalarProd(v,w);
+}
+
+//-------------- main procedures -------------------------------------------------------
+
+proc linReduceIdeal(ideal I, list #)
+"USAGE:  linReduceIdeal(I [,s,t,u]); I an ideal, s,t,u optional ints
+RETURN:  ideal or list, linear reductum (over field) of I by its elements
+PURPOSE: reduces a list of polys only by linear reductions (no monomial
+@*        multiplications)
+NOTE:    If s<>0, a list consisting of the reduced ideal and the coefficient
+@*       vectors of the used reductions given as module is returned.
+@*       Otherwise (and by default), only the reduced ideal is returned.
+@*       If t<>0 (and by default) all monomials are reduced (if possible),
+@*       otherwise, only leading monomials are reduced.
+@*       If u<>0 (and by default), the ideal is first sorted in increasing order.
+@*       If u is set to 0 and the given ideal is not sorted in the way described,
+@*       the result might not be as expected.
+DISPLAY: If @code{printlevel}=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example linReduceIdeal; shows examples
+"
+{
+  // #[1] = remembercoeffs
+  // #[2] = redtail
+  // #[3] = sortideal
+  int ppl = printlevel - voice + 2;
+  int remembercoeffs = 0; // default
+  int redtail        = 1; // default
+  int sortideal      = 1; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      remembercoeffs = #[1];
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        redtail = #[2];
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="int" || typeof(#[3])=="number")
+        {
+          sortideal = #[3];
+        }
+      }
+    }
+  }
+  int sI = ncols(I);
+  int sZeros = sI - size(I);
+  int i,j,k;
+  ideal J,lmJ,ordJ;
+  list lJ = sort(I);
+  intvec iv,iv2; //todo
+  module M; // for the coefficients
+  // step 1: prepare, e.g. sort I
+  if (sortideal <> 0)
+  {
+    if (sZeros > 0) // I contains zeros
+    {
+      if (remembercoeffs <> 0)
+      {
+        j = 0;
+        k = 0;
+        intvec posNonZero;
+        for (i=1; i<=sI; i++)
+        {
+          if (I[i] == 0)
+          {
+            j++;
+            J[j] = 0;
+            ordJ[j] = -1;
+            M[j] = gen(i);
+          }
+          else
+          {
+            k++;
+            M[k+sZeros] = gen(lJ[2][k]);
+             posNonZero = posNonZero,i;
+          }
+        }
+        if (size(I)>0)
+        {
+          posNonZero = posNonZero[2..nrows(posNonZero)];
+          posNonZero = posNonZero[lJ[2]];
+          for (i=1; i<=size(lJ[1]); i++)
+          {
+             M[i+sZeros] = gen(posNonZero[i]);
+          }
+          kill posNonZero;
+        }
+      }
+      else
+      {
+        for (i=1; i<=sZeros; i++)
+        {
+          J[i] = 0;
+          ordJ[i] = -1;
+        }
+      }
+      I = J,lJ[1];
+    }
+    else // I contains no zeros
+    {
+      I = lJ[1];
+      if (remembercoeffs <> 0)
+      {
+        for (i=1; i<=size(lJ[1]); i++) { M[i] = gen(lJ[2][i]); }
+      }
+    }
+  }
+  else // assume I is already sorted
+  {
+    if (remembercoeffs <> 0)
+    {
+      for (i=1; i<=ncols(I); i++) { M[i] = gen(i);  }
+    }
+  }
+  dbprint(ppl,"// initially sorted ideal:", I);
+  if (remembercoeffs <> 0) { dbprint(ppl,"// used permutations:", M); }
+  // step 2: reduce leading monomials by linear reductions
+  poly lm,c,redpoly,maxlmJ;
+  J[sZeros+1] = I[sZeros+1];
+  lm = I[sZeros+1];
+  maxlmJ = leadmonom(lm);
+  lmJ[sZeros+1] = maxlmJ;
+  int ordlm,reduction;
+  ordJ[sZeros+1] = ord(lm);
+  vector v;
+  int noRedPast;
+  for (i=sZeros+2; i<=sI; i++)
+  {
+    redpoly = I[i];
+    lm = leadmonom(redpoly);
+    ordlm = ord(lm);
+    if (remembercoeffs <> 0) { v = M[i]; }
+    reduction = 1;
+    while (reduction == 1) // while there was a reduction
+    {
+      noRedPast = i;
+      reduction = 0;
+      for (j=sZeros+1; j<noRedPast; j++)
+      {
+        if (lm == 0) { break; } // nothing more to reduce
+        if (lm > maxlmJ) { break; } //lm is bigger than maximal monomial to reduce with
+        if (ordlm == ordJ[j])
+        {
+          if (lm == lmJ[j])
+          {
+            dbprint(ppl-1,"// reducing " + string(redpoly));
+            dbprint(ppl-1,"//  with " + string(J[j]));
+            c = leadcoef(redpoly)/leadcoef(J[j]);
+            redpoly = redpoly - c*J[j];
+            dbprint(ppl-1,"//  to " + string(redpoly));
+            lm = leadmonom(redpoly);
+            ordlm = ord(lm);
+            if (remembercoeffs <> 0) { M[i] = M[i] - c * M[j]; }
+            noRedPast = j;
+            reduction = 1;
+          }
+        }
+      }
+    }
+    for (j=sZeros+1; j<i; j++)
+    {
+      if (redpoly < J[j]) { break; }
+    }
+    J = insertGenerator(J,redpoly,j);
+    lmJ = insertGenerator(lmJ,lm,j);
+    ordJ = insertGenerator(ordJ,poly(ordlm),j);
+    if (remembercoeffs <> 0)
+    {
+      v = M[i];
+      M = deleteGenerator(M,i);
+      M = insertGenerator(M,v,j);
+    }
+    maxlmJ = lmJ[i];
+  }
+  // step 3: reduce tails by linear reductions as well
+  if (redtail <> 0)
+  {
+    dbprint(ppl,"// finished reducing leading monomials");
+    dbprint(ppl-1,string(J));
+    if (remembercoeffs <> 0) { dbprint(ppl-1,"// used reductions:" + string(M)); }
+    for (i=sZeros+1; i<=sI; i++)
+    {
+      lm = lmJ[i];
+      for (j=i+1; j<=sI; j++)
+      {
+        for (k=2; k<=size(J[j]); k++) // run over all terms in J[j]
+        {
+          if (ordJ[i] == ord(J[j][k]))
+          {
+            if (lm == normalize(J[j][k]))
+            {
+              c = leadcoef(J[j][k])/leadcoef(J[i]);
+              dbprint(ppl-1,"// reducing " + string(J[j]));
+              dbprint(ppl-1,"//  with " + string(J[i]));
+              J[j] = J[j] - c*J[i];
+              dbprint(ppl-1,"//  to " + string(J[j]));
+              if (remembercoeffs <> 0) { M[j] = M[j] - c * M[i]; }
+            }
+          }
+        }
+      }
+    }
+  }
+  if (sI == sZeros) // if I=0,0,...,0, we now have one too much by construction due to sort
+  {
+    J = J[1..sZeros];
+  }
+  if (remembercoeffs <> 0) { return(list(J,M)); }
+  else { return(J); }
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  ideal I = 3,x+9,y4+5x,2y4+7x+2;
+  linReduceIdeal(I);     // reduces tails
+  linReduceIdeal(I,0,0); // no reductions of tails
+  list l = linReduceIdeal(I,1); // reduces tails and shows reductions used
+  l;
+  module M = I;
+  matrix(l[1]) - matrix(M)*matrix(l[2]);
+}
+
+proc linReduce(poly f, ideal I, list #)
+"USAGE:  linReduce(f, I [,s,t,u]); f a poly, I an ideal, s,t,u optional ints
+RETURN:  poly or list, linear reductum (over field) of f by elements from I
+PURPOSE: reduce a polynomial only by linear reductions (no monomial multiplications)
+NOTE:    If s<>0, a list consisting of the reduced polynomial and the coefficient
+@*       vector of the used reductions is returned, otherwise (and by default)
+@*       only reduced polynomial is returned.
+@*       If t<>0 (and by default) all monomials are reduced (if possible),
+@*       otherwise, only leading monomials are reduced.
+@*       If u<>0 (and by default), the ideal is linearly pre-reduced, i.e.
+@*       instead of the given ideal, the output of @code{linReduceIdeal} is used.
+@*       If u is set to 0 and the given ideal does not equal the output of
+@*       @code{linReduceIdeal}, the result might not be as expected.
+DISPLAY: If @code{printlevel}=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example linReduce; shows examples
+"
+{
+  int ppl = printlevel - voice + 2;
+  int remembercoeffs = 0; // default
+  int redtail        = 1; // default
+  int prepareideal   = 1; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      remembercoeffs = #[1];
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        redtail = #[2];
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="int" || typeof(#[3])=="number")
+        {
+          prepareideal = #[3];
+        }
+      }
+    }
+  }
+  int i,j,k;
+  int sI = ncols(I);
+  // pre-reduce I:
+  module M;
+  if (prepareideal <> 0)
+  {
+    if (remembercoeffs <> 0)
+    {
+      list sortedI = linReduceIdeal(I,1,redtail);
+      I = sortedI[1];
+      M = sortedI[2];
+      dbprint(ppl-1,"// prepared ideal:" +string(I));
+      dbprint(ppl-1,"//  with operations:" +string(M));
+    }
+    else { I = linReduceIdeal(I,0,redtail); }
+  }
+  else
+  {
+    if (remembercoeffs <> 0)
+    {
+      for (i=1; i<=sI; i++) { M[i] = gen(i); }
+    }
+  }
+  ideal lmI,lcI,ordI;
+  for (i=1; i<=sI; i++)
+  {
+    lmI[i] = leadmonom(I[i]);
+    lcI[i] = leadcoef(I[i]);
+    ordI[i] = ord(lmI[i]);
+  }
+  vector v;
+  poly c;
+  // === reduce leading monomials ===
+  poly lm = leadmonom(f);
+  int ordf = ord(lm);
+  for (i=sI; i>=1; i--)  // I is sorted: smallest lm's on top
+  {
+    if (lm == 0) { break; }
+    else
+    {
+      if (ordf == ordI[i])
+      {
+        if (lm == lmI[i])
+        {
+          c = leadcoef(f)/lcI[i];
+          f = f - c*I[i];
+          lm = leadmonom(f);
+          ordf = ord(lm);
+          if (remembercoeffs <> 0) { v = v - c * M[i]; }
+        }
+      }
+    }
+  }
+  // === reduce tails as well ===
+  if (redtail <> 0)
+  {
+    dbprint(ppl,"// finished reducing leading monomials");
+    dbprint(ppl-1,string(f));
+    if (remembercoeffs <> 0) { dbprint(ppl-1,"// used reductions:" + string(v)); }
+    for (i=1; i<=sI; i++)
+    {
+      dbprint(ppl,"// testing ideal entry "+string(i));
+      for (j=1; j<=size(f); j++)
+      {
+        if (ord(f[j]) == ordI[i])
+        {
+          if (normalize(f[j]) == lmI[i])
+          {
+            c = leadcoef(f[j])/lcI[i];
+            f = f - c*I[i];
+            dbprint(ppl-1,"// reducing with " + string(I[i]));
+            dbprint(ppl-1,"//  to " + string(f));
+            if (remembercoeffs <> 0) { v = v - c * M[i]; }
+          }
+        }
+      }
+    }
+  }
+  if (remembercoeffs <> 0)
+  {
+    list l = f,v;
+    return(l);
+  }
+  else { return(f); }
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  ideal I = 1,y,xy;
+  poly f = 5xy+7y+3;
+  poly g = 7x+5y+3;
+  linReduce(g,I);     // reduces tails
+  linReduce(g,I,0,0); // no reductions of tails
+  linReduce(f,I,1);   // reduces tails and shows reductions used
+  f = x3+y2+x2+y+x;
+  I = x3-y3, y3-x2,x3-y2,x2-y,y2-x;
+  list l = linReduce(f,I,1);
+  l;
+  module M = I;
+  f - (l[1]-(M*l[2])[1,1]);
+}
+
+proc linSyzSolve (ideal I, list #)
+"USAGE:  linSyzSolve(I[,s]);  I an ideal, s an optional int
+RETURN:  vector, coefficient vector of linear combination of 0 in elements of I
+PURPOSE: compute a linear dependency between the elements of an ideal
+@*       if such one exists
+NOTE:    If s<>0, @code{std} is used for Groebner basis computations,
+@*       otherwise, @code{slimgb} is used.
+@*       By default, @code{slimgb} is used in char 0 and @code{std} in char >0.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example linSyzSolve; shows examples
+"
+{
+  int whichengine     = 0; // default
+  int enginespecified = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      whichengine = int( #[1]);
+      enginespecified = 1;
+    }
+  }
+  int ppl = printlevel - voice +2;
+  int sI = ncols(I);
+  // check if we are done
+  if (I[sI]==0)
+  {
+    vector v = gen(sI);
+  }
+  else
+  {
+    // ------- 1. introduce undefined coeffs ------------------
+    def save = basering;
+    list RL = ringlist(save);
+    int nv = nvars(save);
+    int np = npars(save);
+    int p = char(save);
+    string cs = "(" + charstr(save) + ")";
+    if (enginespecified == 0)
+    {
+      if (p <> 0)
+      {
+        whichengine = 1;
+      }
+    }
+    int i;
+    list Lvar;
+    for (i=1; i<=sI; i++)
+    {
+      Lvar[i] = safeVarName("@a(" + string(i) + ")");
+    }
+    list L@A = RL[1..4];
+    L@A[2] = Lvar;
+    L@A[3] = list(list("lp",intvec(1:sI)),list("C",intvec(0)));
+    def @A = ring(L@A);
+    L@A[2] = list(safeVarName("@z"));
+    L@A[3][1] = list("dp",intvec(1));
+    if (size(L@A[1])>1)
+    {
+      L@A[1][2] = L@A[1][2] + Lvar;
+      L@A[1][3][size(L@A[1][3])+1] = list("lp",intvec(1:sI));
+    }
+    else
+    {
+      L@A[1] = list(p,Lvar,list(list("lp",intvec(1:sI))),ideal(0));
+    }
+    def @aA = ring(L@A);
+    def @B = save + @aA;
+    setring @B;
+    ideal I = imap(save,I);
+    // ------- 2. form the linear system for the undef coeffs ---
+     poly W;  ideal QQ;
+    for (i=1; i<=sI; i++)
+    {
+      W = W + par(np+i)*I[i];
+    }
+    while (W!=0)
+    {
+      QQ = QQ,leadcoef(W);
+      W = W - lead(W);
+    }
+    // QQ consists of polynomial expressions in @a(i) of type number
+    setring @A;
+    ideal QQ = imap(@B,QQ);
+    // ------- 3. this QQ is a polynomial ideal, so "solve" the system -----
+    dbprint(ppl, "// linSyzSolve: starting Groebner basis computation with engine:", whichengine);
+    QQ = engine(QQ,whichengine);
+    dbprint(ppl, "// QQ after engine:", QQ);
+    if (dim(QQ) == -1)
+    {
+      dbprint(ppl+1, "// no solutions by linSyzSolve");
+      // output zeroes
+      setring save;
+      kill @A,@aA,@B;
+      return(v);
+    }
+    // ------- 4. in order to get the numeric values -------
+    matrix AA = matrix(maxideal(1));
+    module MQQ = std(module(QQ));
+    AA = NF(AA,MQQ); // todo: we still receive NF warnings
+    dbprint(ppl, "// AA after NF:",AA);
+    //    "AA after NF:"; print(AA);
+    for(i=1; i<=sI; i++)
+    {
+      AA = subst(AA,var(i),1);
+    }
+    dbprint(ppl, "// AA after subst:",AA);
+    //    "AA after subst: "; print(AA);
+    vector v = (module(transpose(AA)))[1];
+    setring save;
+    vector v = imap(@A,v);
+    kill @A,@aA,@B;
+  }
+  return(v);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,x,dp;
+  ideal I = x,2x;
+  linSyzSolve(I);
+  ideal J = x,x2;
+  linSyzSolve(J);
+}
+
+proc pIntersect (poly s, ideal I, list #)
+"USAGE:  pIntersect(f, I [,s]);  f a poly, I an ideal, s an optional int
+RETURN:  vector, coefficient vector of the monic polynomial
+PURPOSE: compute the intersection of ideal I with the subalgebra K[f]
+ASSUME:  I is given as Groebner basis, basering is not a qring.
+NOTE:    If the intersection is zero, this proc might not terminate.
+@*       If s>0 is given, it is searched for the generator of the intersection
+@*       only up to degree s. Otherwise (and by default), no bound is assumed.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example pIntersect; shows examples
+"
+{
+  def save = basering;
+  int n = nvars(save);
+  list RL = ringlist(save);
+  int i,j,k;
+  if (RL[4]<>0)
+  {
+    ERROR ("basering must not be a qring");
+  }
+  // assume I is given in Groebner basis
+  if (attrib(I,"isSB") <> 1)
+  {
+    print("// WARNING: The input has no SB attribute!");
+    print("// Treating it as if it were a Groebner basis and proceeding...");
+    attrib(I,"isSB",1); // set attribute for suppressing NF messages
+  }
+  int bound = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      bound = #[1];
+    }
+  }
+  int ppl = printlevel-voice+2;
+  // ---case 1: I = basering---
+  if (size(I) == 1)
+  {
+    if (simplify(I,2)[1] == 1)
+    {
+      return(gen(1)); // = 1
+    }
+  }
+  // ---case 2: intersection is zero---
+  intvec degs = leadexp(s);
+  intvec possdegbounds;
+  list degI;
+  i = 1;
+  while (i <= ncols(I))
+  {
+    if (i == ncols(I)+1) { break; }
+    degI[i] = leadexp(I[i]);
+    for (j=1; j<=n; j++)
+    {
+      if (degs[j] == 0)
+      {
+        if (degI[i][j] <> 0) { break; }
+      }
+      if (j == n)
+      {
+        k++;
+        possdegbounds[k] = Max(degI[i]);
+      }
+    }
+    i++;
+  }
+  int degbound = Min(possdegbounds);
+  if (bound>0 && bound<degbound) // given bound is too small
+  {
+    print("// Try a bound of at least " + string(degbound));
+    return(vector(0));
+  }
+  dbprint(ppl,"// lower bound for the degree of the insection is " +string(degbound));
+  if (degbound == 0) // lm(s) does not appear in lm(I)
+  {
+    print("// Intersection is zero");
+    return(vector(0));
+  }
+  // ---case 3: intersection is non-trivial---
+  ideal redNI = 1;
+  vector v;
+  list l,ll;
+  l[1] = vector(0);
+  poly toNF,tobracket,newNF,rednewNF,oldNF,secNF;
+  i = 1;
+  while (1)
+  {
+    if (bound>0 && i>bound) { return(vector(0)); }
+    dbprint(ppl,"// Testing degree "+string(i));
+    if (i>1)
+    {
+      oldNF = newNF;
+      tobracket = s^(i-1) - oldNF;
+      if (tobracket==0) // todo bug in bracket?
+      {
+        toNF = 0;
+      }
+      else
+      {
+        toNF = bracket(tobracket,secNF);
+      }
+      newNF = NF(toNF+oldNF*secNF,I);  // = NF(s^i,I)
+    }
+    else
+    {
+      newNF = NF(s,I);
+      secNF = newNF;
+    }
+    ll = linReduce(newNF,redNI,1);
+    rednewNF = ll[1];
+    l[i+1] = ll[2];
+    dbprint(ppl-1,"// newNF is: "+string(newNF));
+    dbprint(ppl-1,"// rednewNF is: "+string(rednewNF));
+    if (rednewNF != 0) // no linear dependency
+    {
+      redNI[i+1] = rednewNF;
+      i++;
+    }
+    else // there is a linear dependency, hence we are done
+    {
+      dbprint(ppl,"// degree of the generator of the intersection is: "+string(i));
+      break;
+    }
+  }
+  dbprint(ppl-1,"// used linear reductions:", l);
+  // we obtain the coefficients of the generator by the used reductions:
+  list Lvar;
+  for (j=1; j<=i+1; j++)
+  {
+    Lvar[j] = safeVarName("a("+string(j)+")");
+  }
+  list Lord = list("dp",intvec(1:(i+1))),list("C",intvec(0));
+  list L@R = RL[1..4];
+  L@R[2] = Lvar; L@R[3] = Lord;
+  def @R = ring(L@R); setring @R;
+  list l = imap(save,l);
+  ideal C;
+  for (j=1;j<=i+1;j++)
+  {
+    C[j] = 0;
+    for (k=1;k<=j;k++)
+    {
+      C[j] = C[j]+l[j][k]*var(k);
+    }
+  }
+  for (j=i;j>=1;j--)
+  {
+    C[i+1]= subst(C[i+1],var(j),var(j)+C[j]);
+  }
+  matrix m = coeffs(C[i+1],maxideal(1));
+  vector v = gen(i+1);
+  for (j=1;j<=i+1;j++)
+  {
+    v = v + m[j,1]*gen(j);
+  }
+  setring save;
+  v = imap(@R,v);
+  kill @R;
+  return(v);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  def D = initialMalgrange(f);
+  setring D;
+  inF;
+  pIntersect(t*Dt,inF);
+  pIntersect(t*Dt,inF,1);
+}
+
+proc pIntersectSyz (poly s, ideal I, list #)
+"USAGE:  pIntersectSyz(f, I [,p,s,t]);  f poly, I ideal, p,t optial ints, p prime
+RETURN:  vector, coefficient vector of the monic polynomial
+PURPOSE: compute the intersection of an ideal I with the subalgebra K[f]
+ASSUME:  I is given as Groebner basis.
+NOTE:    If the intersection is zero, this procedure might not terminate.
+@*       If p>0 is given, this proc computes the generator of the intersection in
+@*       char p first and then only searches for a generator of the obtained
+@*       degree in the basering. Otherwise, it searches for all degrees by
+@*       computing syzygies.
+@*       If s<>0, @code{std} is used for Groebner basis computations in char 0,
+@*       otherwise, and by default, @code{slimgb} is used.
+@*       If t<>0 and by default, @code{std} is used for Groebner basis
+@*       computations in char >0, otherwise, @code{slimgb} is used.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example pIntersectSyz; shows examples
+"
+{
+  // assume I is given as Groebner basis
+  if (attrib(I,"isSB") <> 1)
+  {
+    print("// WARNING: The input has no SB attribute!");
+    print("//  Treating it as if it were a Groebner basis and proceeding...");
+    attrib(I,"isSB",1); // set attribute for suppressing NF messages
+  }
+  int ppl = printlevel-voice+2;
+  int whichengine  = 0; // default
+  int modengine    = 1; // default
+  int solveincharp = 0; // default
+  def save = basering;
+  int n = nvars(save);
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      solveincharp = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        whichengine = int(#[2]);
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="int" || typeof(#[3])=="number")
+        {
+          modengine = int(#[3]);
+        }
+      }
+    }
+  }
+  int i,j;
+  vector v;
+  poly tobracket,toNF,newNF,p;
+  ideal NI = 1;
+  newNF = NF(s,I);
+  NI[2] = newNF;
+  list RL = ringlist(save);
+  if (solveincharp)
+  {
+    int psolveincharp = prime(solveincharp);
+    if (solveincharp <> psolveincharp)
+    {
+      print("// " + string(solveincharp) + " is invalid characteristic of ground field.");
+      print("// " + string(psolveincharp) + " is used.");
+      solveincharp = psolveincharp;
+      kill psolveincharp;
+    }
+    list RLp = RL[1..4];
+    if (typeof(RL[1]) == "int") { RLp[1] = solveincharp; }
+    else { RLp[1][1] = solveincharp; } // parameters
+    def @Rp = ring(RLp);
+    setring @Rp;
+    number c;
+    setring save;
+    int shortSave = short; // workaround for maps Q(a_i) -> Z/p(a_i)
+    short = 0;
+    string str;
+    int badprime;
+    i=1;
+    number c;
+    while (badprime == 0 && i<=size(s)) // detect bad primes
+    {
+      c=denominator(leadcoef(s[i]));
+      setring @Rp;
+      c=fetch(save,c);
+      if (c == 0) { badprime = 1; }
+      setring save;
+      i++;
+    }
+    str = "poly s = " + string(s) + ";";
+    if (size(RL) > 4) // basering is NC-algebra
+    {
+      matrix @C=RL[5];
+      matrix @D=RL[6];
+      setring @Rp;
+      matrix @C[n][n]=fetch(save,@C);
+      matrix @D[n][n]=fetch(save,@D);
+      def Rp = nc_algebra(@C,@D);
+    }
+    else { def Rp = @Rp; }
+    setring Rp;
+    kill @Rp;
+    dbprint(ppl-1,"// solving in ring ", Rp);
+    poly s=fetch(save,s);
+    vector v;
+    number c;
+    ideal NI = 1;
+    setring save;
+    i=1;
+    while (badprime == 0 && i<=size(I)) // detect bad primes
+    {
+      c=leadcoef(cleardenom(I[i]));
+      setring Rp;
+      c=fetch(save,c);
+      if (c == 0) { badprime = 1; }
+      setring save;
+      i++;
+    }
+    if (badprime == 1)
+    {
+      print("// WARNING: bad prime");
+      short = shortSave;
+      return(vector(0));
+    }
+  }
+  i = 1;
+  dbprint(ppl,"// pIntersectSyz starts...");
+  dbprint(ppl-1,"// with ideal I=", I);
+  while (1)
+  {
+    dbprint(ppl,"// testing degree: "+string(i));
+    if (i>1)
+    {
+      tobracket = s^(i-1)-NI[i];
+      if (tobracket!=0)
+      {
+        toNF = bracket(tobracket,NI[2]) + NI[i]*NI[2];
+      }
+      else
+      {
+        toNF = NI[i]*NI[2];
+      }
+      newNF =  NF(toNF,I);
+      NI[i+1] = newNF;
+    }
+    // look for a solution
+    dbprint(ppl-1,"// linSyzSolve starts with: "+string(matrix(NI)));
+    if (solveincharp) // modular method
+    {
+      for (j=1; j<=size(newNF); j++)
+      {
+        c=denominator(leadcoef(s[i]));
+        setring Rp;
+        c=fetch(save,c);
+        if (c == 0)
+        {
+          print("// WARNING: bad prime");
+          setring save;
+          short = shortSave;
+          return(vector(0));
+        }
+        setring save;
+      }
+      str = "NI[" + string(i) + "+1] = " + string(newNF) + ";";
+      setring Rp;
+      NI[i+1]=fetch(save,newNF);
+      // NI[i+1] = [newNF]_{solveincharp}
+      v = linSyzSolve(NI,modengine);
+      if (v!=0) // there is a modular solution
+      {
+        dbprint(ppl,"// got solution in char "+string(solveincharp)+" of degree "+string(i));
+        setring save;
+        v = linSyzSolve(NI,whichengine);
+        if (v==0)
+        {
+          break;
+        }
+      }
+      else // no modular solution
+      {
+        setring save;
+        v = 0;
+      }
+    }
+    else // non-modular method
+    {
+      v = linSyzSolve(NI,whichengine);
+    }
+    matrix MM[1][nrows(v)] = matrix(v);
+    dbprint(ppl-1,"// linSyzSolve ready  with: "+string(MM));
+    kill MM;
+    //  "linSyzSolve ready with"; print(v);
+    if (v!=0)
+    {
+      // a solution:
+      //check for the reality of the solution
+      p = 0;
+      for (j=1; j<=i+1; j++)
+      {
+        p = p + v[j]*NI[j];
+      }
+      if (p!=0)
+      {
+        dbprint(ppl,"// linSyzSolve: bad solution!");
+      }
+      else
+      {
+        dbprint(ppl,"// linSyzSolve: got solution!");
+        // "got solution!";
+        break;
+      }
+    }
+    // no solution:
+    i++;
+  }
+  dbprint(ppl,"// pIntersectSyz finished");
+  if (solveincharp) { short = shortSave; }
+  return(v);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  def D = initialMalgrange(f);
+  setring D;
+  inF;
+  poly s = t*Dt;
+  pIntersectSyz(s,inF);
+  int p = prime(20000);
+  pIntersectSyz(s,inF,p,0,0);
+}
+
+proc vec2poly (list #)
+"USAGE:  vec2poly(v [,i]);  v a vector or an intvec, i an optional int
+RETURN:  poly, an univariate polynomial in i-th variable with coefficients given by v
+PURPOSE: constructs an univariate polynomial in K[var(i)] with given coefficients,
+@*       such that the coefficient at var(i)^{j-1} is v[j].
+NOTE:    The optional argument i must be positive, by default i is 1.
+EXAMPLE: example vec2poly; shows examples
+"
+{
+  def save = basering;
+  int i,ringvar;
+  ringvar = 1; // default
+  if (size(#) > 0)
+  {
+    if (typeof(#[1])=="vector" || typeof(#[1])=="intvec")
+    {
+      def v = #[1];
+    }
+    else
+    {
+      ERROR("wrong input: expected vector/intvec expression");
+    }
+    if (size(#) > 1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        ringvar = int(#[2]);
+      }
+    }
+  }
+  if (ringvar > nvars(save))
+  {
+    ERROR("var out of range");
+  }
+  poly p;
+  for (i=1; i<=nrows(v); i++)
+  {
+    p = p + v[i]*(var(ringvar))^(i-1);
+  }
+  return(p);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  vector v = gen(1) + 3*gen(3) + 22/9*gen(4);
+  intvec iv = 3,2,1;
+  vec2poly(v,2);
+  vec2poly(iv);
+}
+
+/*
+// // listofroots and addRoots aren't needed anymore due to some modifications
+//
+// static proc listofroots (list #)
+// {
+//   def save = basering;
+//   int n = nvars(save);
+//   int i;
+//   poly p;
+//   if (typeof(#[1])=="vector")
+//   {
+//     vector b = #[1];
+//     for (i=1; i<=nrows(b); i++)
+//     {
+//       p = p + b[i]*(var(1))^(i-1);
+//     }
+//   }
+//   else
+//   {
+//     p = #[1];
+//   }
+//   int substitution = int(#[2]);
+//   string s = safeVarName("s");
+//   list RL = ringlist(save); RL = RL[1..4];
+//   RL[2] = list(s); RL[3] = list(list("dp",intvec(1)),list("C",0));
+//   def S = ring(RL); setring S;
+//   ideal J;
+//   for (i=1; i<=n; i++)
+//   {
+//     J[i] = var(1);
+//   }
+//   map @m = save,J;
+//   poly p = @m(p);
+//   if (substitution == 1)
+//   {
+//     p = subst(p,var(1),-var(1)-1);
+//   }
+//   // the rest of this proc is nicked from bernsteinBM from dmod.lib
+//   list P = factorize(p);//with constants and multiplicities
+//   ideal bs; intvec m;   //the BS polynomial is monic, so we are not interested in constants
+//   for (i=2; i<= size(P[1]); i++)  //we delete P[1][1] and P[2][1]
+//   {
+//     bs[i-1] = P[1][i];
+//     m[i-1]  = P[2][i];
+//   }
+//   bs =  normalize(bs);
+//   bs = -subst(bs,var(1),0);
+//   setring save;
+//   ideal bs = imap(S,bs);
+//   kill S;
+//   list BS = bs,m;
+//   return(BS);
+// }
+//
+//
+// static proc addRoot(number q, list L)
+// {
+//   // add root to list in bFactor format
+//   int i,qInL;
+//   ideal I = L[1];
+//   intvec v = L[2];
+//   list LL;
+//   if (v == 0)
+//   {
+//     I = poly(q);
+//     v = 1;
+//     LL = I,v;
+//   }
+//   else
+//   {
+//     for (i=1; i<=ncols(I); i++)
+//     {
+//       if (I[i] == q)
+//       {
+//         qInL = i;
+//         break;
+//       }
+//     }
+//     if (qInL)
+//     {
+//       v[qInL] = v[qInL] + 1;
+//     }
+//     else
+//     {
+//       I = q,I;
+//       v = 1,v;
+//     }
+//   }
+//   LL = I,v;
+//   if (size(L) == 3) // irreducible factor
+//   {
+//     if (L[3] <> "0" && L[3] <> "1")
+//     {
+//       LL = LL + list(L[3]);
+//     }
+//   }
+//   return(LL);
+// }
+*/
+
+static proc bfctengine (poly f, int inorann, int whichengine, int addPD, int stdsum, int methodord, int methodpIntersect, int pIntersectchar, int modengine, intvec u0)
+{
+  int printlevelsave = printlevel;
+  printlevel = printlevel + 1;
+  int ppl = printlevel - voice + 2;
+  int i;
+  def save = basering;
+  int n = nvars(save);
+  if (isCommutative() == 0) { ERROR("basering must be commutative"); }
+  if (char(save) <> 0) { ERROR("characteristic of basering has to be 0"); }
+  list L = ringlist(save);
+  int qr;
+  if (L[4] <> 0) // qring
+  {
+    print("// basering is qring:");
+    print("// discarding the quotient and proceeding...");
+    L[4] = ideal(0);
+    qr = 1;
+    def save2 = ring(L); setring save2;
+    poly f = imap(save,f);
+  }
+  if (inorann == 0) // bfct using initial ideal
+  {
+    // list L = ringlist(basering);
+    intvec iv = valvars(f)[1]; // heuristacally better ordering for initialMalgrange
+    list varL = L[2];
+    varL = varL[iv];
+    L[2] = varL;
+    if (u0 <> 0)
+    {
+      u0 = u0[iv];
+    }
+    def newr = ring(L);
+    kill varL,iv,L;
+    setring newr;
+    poly f = imap(save,f);
+    dbprint(ppl,"// starting computation of the initial ideal of the Malgrange ideal...");
+    def D = initialMalgrange(f,whichengine,methodord,u0);
+    dbprint(ppl,"// ...done");
+    setring D;
+    ideal J = inF;
+    kill inF;
+    poly s = var(1)*var(n+2);
+  }
+  else // bfct using Ann(f^s)
+  {
+    dbprint(ppl,"// starting computation of the s-parametric annihilator...");
+    def D = SannfsBFCT(f,addPD,whichengine,stdsum);
+    dbprint(ppl,"// ...done");
+    setring D;
+    ideal J = LD;
+    kill LD;
+    poly s = var(1);
+  }
+  vector b;
+  dbprint(ppl,"// starting to intersect with subalgebra...");
+  // try it modular
+  if (methodpIntersect <> 0) // pIntersectSyz
+  {
+    if (pIntersectchar == 0) // pIntersectSyz::modular
+    {
+      list L = ringlist(D);
+      int lb = 10000; int ub = 536870909; // bounds for random primes
+      list usedprimes;
+      int sJ = size(J);
+      int sLJq;
+      ideal LJ;
+      for (i=1; i<=sJ; i++)
+      {
+        LJ[i] = leadcoef(cleardenom(J[i]));
+      }
+      int short_save = short; // workaround for map Q(a_i) -> Z/q(a_i)
+      short = 0;
+      int nD = nvars(D);
+      matrix @C[nD][nD] = L[5];
+      matrix @D[nD][nD] = L[6];
+      L = L[1..4];
+      i = 1;
+      while (b == 0)
+      {
+        dbprint(ppl,"// number of run in the loop: "+string(i));
+        int q = prime(random(lb,ub));
+        if (findFirst(usedprimes,q)==0) // if q has not been used already
+        {
+          usedprimes = usedprimes,q;
+          dbprint(ppl,"// using prime: "+string(q));
+          if (typeof(L[1]) == "int") { L[1] = q; }
+          else { L[1][1] = q; } // parameters
+          def @Rq = ring(L); setring @Rq;
+          matrix @C=fetch(D,@C);
+          matrix @D=fetch(D,@D);
+          def Rq = nc_algebra(@C,@D); // def Rq = nc_algebra(1,@D);
+          setring Rq; kill @Rq;
+          ideal LJq=fetch(D,LJ);
+          sLJq = size(LJq);
+          setring D; kill Rq;
+          if (sLJq <> sJ ) // detect unlucky prime
+          {
+            dbprint(ppl,"// " +string(q) + " is unlucky");
+            b = 0;
+          }
+          else
+          {
+            b = pIntersectSyz(s,J,q,whichengine,modengine);
+          }
+        }
+        i++;
+      }
+      short = short_save;
+    }
+    else // pIntersectSyz::non-modular
+    {
+      b = pIntersectSyz(s,J,0,whichengine);
+    }
+  }
+  else // pIntersect: linReduce
+  {
+    b = pIntersect(s,J);
+  }
+  dbprint(ppl,"// ...done"); // with the intersection
+  poly pb = vec2poly(b);
+  if (inorann == 0)
+  {
+    pb = subst(pb,var(1),-var(1)-1);
+  }
+  else // bfctAnn
+  {
+    if (addPD)
+    {
+      pb = pb*(var(1)+1);
+    }
+  }
+  list l = bFactor(pb);
+  setring save;
+  list l = imap(D,l);
+  printlevel = printlevelsave;
+  return(l);
+}
+
+proc bfct (poly f, list #)
+"USAGE:  bfct(f [,s,t,v]);  f a poly, s,t optional ints, v an optional intvec
+RETURN:  list of ideal and intvec
+PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s)
+@*       for the hypersurface defined by f.
+ASSUME:  The basering is commutative and of characteristic 0.
+BACKGROUND: In this proc, the initial Malgrange ideal is computed according to
+@*       the algorithm by Masayuki Noro and then a system of linear equations is
+@*       solved by linear reductions.
+NOTE:    In the output list, the ideal contains all the roots
+@*       and the intvec their multiplicities.
+@*       If s<>0, @code{std} is used for GB computations,
+@*       otherwise, and by default, @code{slimgb} is used.
+@*       If t<>0, a matrix ordering is used for Groebner basis computations,
+@*       otherwise, and by default, a block ordering is used.
+@*       If v is a positive weight vector, v is used for homogenization
+@*       computations, otherwise and by default, no weights are used.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example bfct; shows examples
+"
+{
+  int ppl = printlevel - voice +2;
+  int i;
+  int n = nvars(basering);
+  // in # we have two switches:
+  // one for the engine used for Groebner basis computations,
+  // one for  M() ordering or its realization
+  // in # can also be the optional weight vector
+  int whichengine  = 0; // default
+  int methodord    = 0; // default
+  intvec u0        = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      whichengine = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        methodord = int(#[2]);
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="intvec" && size(#[3])==n && allPositive(#[3])==1)
+        {
+          u0 = #[3];
+        }
+      }
+    }
+  }
+  list b = bfctengine(f,0,whichengine,0,0,methodord,0,0,0,u0);
+  return(b);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  bfct(f);
+  intvec v = 3,2;
+  bfct(f,1,0,v);
+}
+
+proc bfctSyz (poly f, list #)
+"USAGE:  bfctSyz(f [,r,s,t,u,v]);  f poly, r,s,t,u optional ints, v opt. intvec
+RETURN:  list of ideal and intvec
+PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s)
+@*       for the hypersurface defined by f
+ASSUME:  The basering is commutative and of characteristic 0.
+BACKGROUND: In this proc, the initial Malgrange ideal is computed according to
+@*       the algorithm by Masayuki Noro and then a system of linear equations is
+@*       solved by computing syzygies.
+NOTE:    In the output list, the ideal contains all the roots and the intvec
+@*       their multiplicities.
+@*       If r<>0, @code{std} is used for GB computations in characteristic 0,
+@*       otherwise, and by default, @code{slimgb} is used.
+@*       If s<>0, a matrix ordering is used for GB computations, otherwise,
+@*       and by default, a block ordering is used.
+@*       If t<>0, the computation of the intersection is solely performed over
+@*       charasteristic 0, otherwise and by default, a modular method is used.
+@*       If u<>0 and by default, @code{std} is used for GB computations in
+@*       characteristic >0, otherwise, @code{slimgb} is used.
+@*       If v is a positive weight vector, v is used for homogenization
+@*       computations, otherwise and by default, no weights are used.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example bfctSyz; shows examples
+"
+{
+  int ppl = printlevel - voice +2;
+  int i;
+  // in # we have four switches:
+  // one for the engine used for Groebner basis computations in char 0,
+  // one for  M() ordering or its realization
+  // one for a modular method when computing the intersection
+  // and one for the engine used for Groebner basis computations in char >0
+  // in # can also be the optional weight vector
+  int n = nvars(basering);
+  int whichengine = 0; // default
+  int methodord   = 0; // default
+  int pIntersectchar = 0; // default
+  int modengine   = 1; // default
+  intvec u0       = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      whichengine = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        methodord = int(#[2]);
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="int" || typeof(#[3])=="number")
+        {
+          pIntersectchar = int(#[3]);
+        }
+        if (size(#)>3)
+        {
+          if (typeof(#[4])=="int" || typeof(#[4])=="number")
+          {
+            modengine = int(#[4]);
+          }
+          if (size(#)>4)
+          {
+            if (typeof(#[5])=="intvec" && size(#[5])==n && allPositive(#[5])==1)
+            {
+              u0 = #[5];
+            }
+          }
+        }
+      }
+    }
+  }
+  list b = bfctengine(f,0,whichengine,0,0,methodord,1,pIntersectchar,modengine,u0);
+  return(b);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  bfctSyz(f);
+  intvec v = 3,2;
+  bfctSyz(f,0,1,1,0,v);
+}
+
+proc bfctIdeal (ideal I, intvec w, list #)
+"USAGE:  bfctIdeal(I,w[,s,t]);  I an ideal, w an intvec, s,t optional ints
+RETURN:  list of ideal and intvec
+PURPOSE: computes the roots of the global b-function of I w.r.t. the weight (-w,w).
+ASSUME:  The basering is the n-th Weyl algebra in characteristic 0 and for all
+@*       1<=i<=n the identity var(i+n)*var(i)=var(i)*var(i+1)+1 holds, i.e. the
+@*       sequence of variables is given by x(1),...,x(n),D(1),...,D(n),
+@*       where D(i) is the differential operator belonging to x(i).
+@*       Further we assume that I is holonomic.
+BACKGROUND:  In this proc, the initial ideal of I is computed according to the
+@*       algorithm by Masayuki Noro and then a system of linear equations is
+@*       solved by linear reductions.
+NOTE:    In the output list, say L,
+@*  - L[1] of type ideal contains all the rational roots of a b-function,
+@*  - L[2] of type intvec contains the multiplicities of above roots,
+@*  - optional L[3] of type string is the part of b-function without rational roots.
+@*  Note, that a b-function of degree 0 is encoded via L[1][1]=0, L[2]=0 and
+@*  L[3] is 1 (for nonzero constant) or 0 (for zero b-function).
+@*       If s<>0, @code{std} is used for GB computations in characteristic 0,
+@*       otherwise, and by default, @code{slimgb} is used.
+@*       If t<>0, a matrix ordering is used for GB computations, otherwise,
+@*       and by default, a block ordering is used.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example bfctIdeal; shows examples
+"
+{
+  int ppl = printlevel - voice +2;
+  int i;
+  def save = basering;
+  int n = nvars(save) div 2;
+  int whichengine = 0; // default
+  int methodord   = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      whichengine = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        methodord = int(#[2]);
+      }
+    }
+  }
+  if (isWeyl()==0) { ERROR("basering is not a Weyl algebra"); }
+  for (i=1; i<=n; i++)
+  {
+    if (bracket(var(i+n),var(i))<>1)
+    {
+      ERROR(string(var(i+n))+" is not a differential operator for " +string(var(i)));
+    }
+  }
+  int isH = isHolonomic(I);
+  if (isH<>1)
+  {
+    print("WARNING: given ideal is not holonomic");
+    print("... setting bound for degree of b-function to 10 and proceeding");
+    isH = 10;
+  }
+  else { isH = 0; } // no degree bound for pIntersect
+  ideal J = initialIdealW(I,-w,w,whichengine,methodord);
+  poly s;
+  for (i=1; i<=n; i++)
+  {
+    s = s + w[i]*var(i)*var(n+i);
+  }
+  vector b = pIntersect(s,J,isH);
+  list RL = ringlist(save); RL = RL[1..4];
+  RL[2] = list(safeVarName("s"));
+  RL[3] = list(list("dp",intvec(1)),list("C",intvec(0)));
+  def @S = ring(RL); setring @S;
+  vector b = imap(save,b);
+  poly bs = vec2poly(b);
+  list l = bFactor(bs);
+  setring save;
+  list l = imap(@S,l);
+  return(l);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring @D = 0,(x,y,Dx,Dy),dp;
+  def D = Weyl();
+  setring D;
+  ideal I = 3*x^2*Dy+2*y*Dx,2*x*Dx+3*y*Dy+6; I = std(I);
+  intvec w1 = 0,1;
+  intvec w2 = 2,3;
+  bfctIdeal(I,w1);
+  bfctIdeal(I,w2,0,1);
+  ideal J = I[size(I)]; // J is not holonomic by construction
+  bfctIdeal(J,w1); //  b-function of D/J w.r.t. w1 is non-zero
+  bfctIdeal(J,w2); //  b-function of D/J w.r.t. w2 is zero
+}
+
+proc bfctOneGB (poly f,list #)
+"USAGE:  bfctOneGB(f [,s,t]);  f a poly, s,t optional ints
+RETURN:  list of ideal and intvec
+PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s) for the
+@*       hypersurface defined by f, using only one GB computation
+ASSUME:  The basering is commutative and of characteristic 0.
+BACKGROUND: In this proc, the initial Malgrange ideal is computed based on the
+@*       algorithm by Masayuki Noro and combined with an elimination ordering.
+NOTE:    In the output list, the ideal contains all the roots and the intvec
+@*       their multiplicities.
+@*       If s<>0, @code{std} is used for the GB computation, otherwise,
+@*       and by default, @code{slimgb} is used.
+@*       If t<>0, a matrix ordering is used for GB computations,
+@*       otherwise, and by default, a block ordering is used.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example bfctOneGB; shows examples
+"
+{
+  int ppl = printlevel - voice +2;
+  if (!isCommutative()) { ERROR("Basering must be commutative"); }
+  def save = basering;
+  int n = nvars(save);
+  if (char(save) <> 0)
+  {
+    ERROR("characteristic of basering has to be 0");
+  }
+  list L = ringlist(save);
+  int qr;
+  if (L[4] <> 0) // qring?
+  {
+    print("// basering is qring:");
+    print("// discarding the quotient and proceeding...");
+    L[4] = ideal(0);
+    qr = 1;
+    def save2 = ring(L);
+    setring save2;
+    poly f = imap(save,f);
+  }
+  int N = 2*n+4;
+  int i;
+  int whichengine = 0; // default
+  int methodord   = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      whichengine = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        methodord = int(#[2]);
+      }
+    }
+  }
+  // creating the homogenized extended Weyl algebra
+  // create names for vars
+  list Lvar;
+  Lvar[1]   = safeVarName("t");
+  Lvar[2]   = safeVarName("s");
+  Lvar[n+3] = safeVarName("D"+Lvar[1]);
+  Lvar[N]   = safeVarName("h");
+  for (i=1; i<=n; i++)
+  {
+    Lvar[i+2]   = string(var(i));
+    Lvar[i+n+3] = safeVarName("D" + string(var(i)));
+  }
+  // create ordering
+  intvec uv = -1; uv[n+3] = 1; uv[N] = 0;
+  intvec @a = 1:N; @a[2] = 2;
+  intvec @a2 = @a; @a2[2] = 0; @a2[2*n+4] = 0;
+  list Lord;
+  Lord[1] = list("a",@a); Lord[2] = list("a",@a2);
+  if (methodord == 0) // default: block ordering
+  {
+    //ring @Dh = 0,(t,s,x(n..1),Dt,D(n..1),h),(a(@a),a(@a2),a(uv),dp(N-1),lp(1));
+    Lord[3] = list("a",uv);
+    Lord[4] = list("dp",intvec(1:(N-1)));
+    Lord[5] = list("lp",intvec(1));
+    Lord[6] = list("C",intvec(0));
+  }
+  else // M() ordering
+  {
+    intmat @Ord[N][N];
+    @Ord[1,1..N] = uv; @Ord[2,1..N] = 1:(N-1);
+    for (i=1; i<=N-2; i++) { @Ord[2+i,N - i] = -1; }
+    dbprint(ppl,"// weights for ordering: "+string(transpose(@a)));
+    dbprint(ppl,"// the ordering matrix:",@Ord);
+    //ring @Dh = 0,(t,s,x(n..1),Dt,D(n..1),h),(a(@a),a(@a2),M(@Ord));
+    Lord[3] = list("M",intvec(@Ord));
+    Lord[4] = list("C",intvec(0));
+  }
+  // create commutative ring
+  list L@Dh = ringlist(basering);
+  L@Dh = L@Dh[1..4]; // if basering is commutative nc_algebra
+  L@Dh[2] = Lvar; L@Dh[3] = Lord;
+  def @Dh = ring(L@Dh); setring @Dh;
+  dbprint(ppl,"// the ring @Dh:",@Dh);
+  // create non-commutative relations
+  matrix @relD[N][N];
+  @relD[1,2] = var(1)*var(N)^2;     //  s*t = t*s + t*h^2
+  @relD[2,n+3] = var(n+3)*var(N)^2; // Dt*s = s*Dt+Dt*h^2
+  @relD[1,n+3] = var(N)^2;
+  for (i=1; i<=n; i++)
+  {
+    @relD[i+2,n+3+i] = var(N)^2;
+  }
+  dbprint(ppl,"// nc relations:",@relD);
+  def Dh = nc_algebra(1,@relD);
+  setring Dh; kill @Dh;
+  dbprint(ppl,"// computing in ring",Dh);
+  poly f = imap(save,f);
+  f = homog(f,h);
+  // create the Malgrange ideal
+  ideal I = var(1) - f, var(1)*var(n+3) - var(2);
+  for (i=1; i<=n; i++)
+  {
+    I[3+i] = var(i+n+3)+diff(f,var(i+2))*var(n+3);
+  }
+  dbprint(ppl-1, "// the Malgrange ideal: " +string(I));
+  // the hard part: Groebner basis computation
+  dbprint(ppl, "// starting Groebner basis computation with engine: "+string(whichengine));
+  I = engine(I, whichengine);
+  dbprint(ppl, "// finished Groebner basis computation");
+  I = subst(I,h,1); // dehomogenization
+  dbprint(ppl-1,string(I));
+  // 3.3 the initial form
+  I = inForm(I,uv);
+  dbprint(ppl, "// the initial ideal:", string(matrix(I)));
+  // read off the solution
+  intvec tonselect = 1;
+  for (i=3; i<=2*n+4; i++) { tonselect = tonselect,i; }
+  I = nselect(I,tonselect);
+  dbprint(ppl, "// generators containing only s:", string(matrix(I)));
+  I = engine(I, whichengine); // is now a principal ideal;
+  if (qr == 1) { setring save2; }
+  else { setring save; }
+  ideal J; J[2] = var(1);
+  map @m = Dh,J;
+  ideal I = @m(I);
+  poly p = I[1];
+  p = subst(p,var(1),-var(1)-1);
+  list l = bFactor(p);
+  if (qr == 1)
+  {
+    setring save;
+    list l = imap(save2,l);
+  }
+  return(l);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  bfctOneGB(f);
+  bfctOneGB(f,1,1);
+}
+
+
+
+proc bfctAnn (poly f, list #)
+"USAGE:  bfctAnn(f [,a,b,c]);  f a poly, a, b, c optional ints
+RETURN:  list of ideal and intvec
+PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s) for the
+@*       hypersurface defined by f.
+ASSUME:  The basering is commutative and of characteristic 0.
+BACKGROUND: In this proc, Ann(f^s) is computed and then a system of linear
+@*       equations is solved by linear reductions.
+NOTE:    In the output list, the ideal contains all the roots and the intvec
+@*  their multiplicities.
+@*  If a<>0, only f is appended to Ann(f^s), otherwise, and by default,
+@*  f and all its partial derivatives are appended.
+@*  If b<>0, @code{std} is used for GB computations, otherwise, and by
+@*  default, @code{slimgb} is used.
+@*  If c<>0, @code{std} is used for Groebner basis computations of ideals
+@*  <I+J> when I is already a Groebner basis of <I>.
+@*  Otherwise, and by default the engine determined by the switch b is used.
+@*  Note that in the case c<>0, the choice for b will be overwritten only
+@*  for the types of ideals mentioned above.
+@*  This means that if b<>0, specifying c has no effect.
+DISPLAY: If printlevel=1, progress debug messages will be printed,
+@*       if printlevel>=2, all the debug messages will be printed.
+EXAMPLE: example bfctAnn; shows examples
+"
+{
+  def save = basering;
+  int ppl = printlevel - voice + 2;
+  int addPD       = 1; // default
+  int whichengine = 0; // default
+  int stdsum      = 0; // default
+  if (size(#)>0)
+  {
+    if (typeof(#[1])=="int" || typeof(#[1])=="number")
+    {
+      addPD = int(#[1]);
+    }
+    if (size(#)>1)
+    {
+      if (typeof(#[2])=="int" || typeof(#[2])=="number")
+      {
+        whichengine = int(#[2]);
+      }
+      if (size(#)>2)
+      {
+        if (typeof(#[3])=="int" || typeof(#[3])=="number")
+        {
+          stdsum = int(#[3]);
+        }
+      }
+    }
+  }
+  list b = bfctengine(f,1,whichengine,addPD,stdsum,0,0,0,0,0);
+  return(b);
+}
+example
+{
+  "EXAMPLE:"; echo = 2;
+  ring r = 0,(x,y),dp;
+  poly f = x^2+y^3+x*y^2;
+  bfctAnn(f);
+  def R = reiffen(4,5); setring R;
+  RC; // the Reiffen curve in 4,5
+  bfctAnn(RC,0,1);
+}
+
+/*
+static proc hardexamples ()
+{
+  //  some hard examples
+  ring r1 = 0,(x,y,z,w),dp;
+  // ab34
+  poly ab34 = (z3+w4)*(3z2x+4w3y);
+  bfct(ab34);
+  // ha3
+  poly ha3 = xyzw*(x+y)*(x+z)*(x+w)*(y+z+w);
+  bfct(ha3);
+  // ha4
+  poly ha4 = xyzw*(x+y)*(x+z)*(x+w)*(y+z)*(y+w);
+  bfct(ha4);
+  // chal4: reiffen(4,5)*reiffen(5,4)
+  ring r2 = 0,(x,y),dp;
+  poly chal4 = (x4+xy4+y5)*(x5+x4y+y4);
+  bfct(chal4);
+  // (xy+z)*reiffen(4,5)
+  ring r3 = 0,(x,y,z),dp;
+  poly xyzreiffen45 = (xy+z)*(y4+yz4+z5);
+  bfct(xyzreiffen45);
+
+// sparse ideal as suggested by Alex; gives 1 as std
+ideal I1 = 28191*y^2+14628*x*Dy, 24865*x^2+24072*x*Dx+17756*Dy^2;
+std(I1);
+}
+*/