#include       <math.h>
#include       <ctype.h> /* isspace */

#include "def.h"
#include "macro.h"

#define INIT_CYCLO(a) \
do {\
erg +=  b_ksd_n(CYCLOTOMIC, CALLOCOBJECT(), NULL, a);\
} while(0)


#define  nb_quores(a,b,c,d) quores(a,b,c,d)

static INT      space_saving = TRUE;
static INT    basis_type = STD_BASIS;

/*    STATIC VARIABLES RELATING TO THE MAINTENANCE OF CYCLOTOMIC DATA    */
#ifdef    CYCLOTRUE
/*    cyclo_table points to an array of CYCLO_DATA with     */
/*    no_cyclos cyclos.  cyclo_table_set is a flag which    */
/*    indicates whether the table is present or not.        */

static    INT    cyclo_table_set = 0L, cyclo_list_set = 0L;
static    INT    zzno_cyclos;
static    CYCLO_DATA    *zzcyclo_table;
static    OP    zzcyclo_list = NULL, zzcyclo_tail = NULL;
static INT number_mem;

#endif /* CYCLOTRUE */

static INT insert_zero_into_monopoly(OP);
static INT integer_coefficients(OP);
static INT find_sqrad_data(OP);
static INT adjust_sqrad_data(OP);
static INT fprint_sqrad(FILE*, OP);
static INT fprint_cyclo(FILE*, OP);
static INT standardise_cyclo_0(OP, INT);
static INT make_index_monopoly_cyclo(OP, OP, OP, INT);
static INT add_cyclo_cyclo_0(OP, OP, OP, INT);
static INT mult_cyclo_cyclo_0(OP, OP, OP, INT);
static INT invers_cyclo_norm(OP, OP, OP);
static INT SCMPCO(OBJECTKIND, OBJECTKIND, OP);

# ifdef    CYCLOTRUE

static INT setup_cyclotomic_table(char*);
static CYCLO_DATA *cyclo_ptr(OP);
static CYCLO_DATA *add_cyclo_data(OP);
static INT free_cyclo_list(void);
static INT free_cyclo_table(void);

# endif
OP s_n_s(OP a)
{
    if (a == NULL)
    {
        error("s_n_s:a == NULL");
        return (OP) NULL;
    }
    return (((a)->ob_self).ob_number)->n_self;
}


INT c_n_s(OP a, OP b)

{
    ((a->ob_self).ob_number)->n_self = b;
    return OK;
}


OP s_n_d(OP a)
{
    if (a == NULL)
    {
        error("s_n_d:a == NULL");
        return (OP) NULL;
    }
    return (((((a)->ob_self).ob_number)->n_data).o_data);
}


INT c_n_d(OP a, OP b)
{
    ((((((a)->ob_self).ob_number)->n_data).o_data) = (b));
    return OK;
}


OP s_n_dci(OP a)
{
    return ((((((a)->ob_self).ob_number)->n_data).c_data)->index);
}


OP s_n_dcd(OP a)
{
    return ((((((a)->ob_self).ob_number)->n_data).c_data)->deg);
}

OP s_n_dcp(OP a)
{
    return  ((((((a)->ob_self).ob_number)->n_data).c_data)->poly);
}


/*
 * Determines and returns the number of digits of the
 * integer a. a may be an INTEGER  or a LONGINT.
 */
INT number_of_digits(OP a)
{
    INT  i = 1L;
    OP   b = CALLOCOBJECT();
    OP ten = CALLOCOBJECT();

    M_I_I(10L,ten);
    copy(a,b);
    if (LT(b,cons_null) == TRUE)
        addinvers_apply(b);

    while (GE(b,ten) == TRUE)
    {
        ganzdiv(b,ten,b);
        i++; 
    }
    freeall(b);
    freeall(ten);
    return(i);
}


INT number_of_bits(OP a)
{
    INT erg = OK;
    CTTO(INTEGER,LONGINT,"number_of_bits(1)",a);
    {
    INT    i = 1L;
    OP b,ten;

    if (S_O_K(a) == INTEGER)
        {
        INT ai = S_I_I(a);
        while (ai >= 2) { ai /= 2; i++; }
        return i;
        }

    b = CALLOCOBJECT();
    COPY(a,b);
    if (LT(b,cons_null) == TRUE)
        ADDINVERS_APPLY(b);

    while (GE(b,cons_zwei) == TRUE)
    {
        ganzdiv(b,cons_zwei,b);
        i++;
    }
    freeall(b);
    return(i);
    }
    ENDR("number_of_bits");
}


INT integer_factors_to_integer(OP l, OP a)
{
    INT    ret    = ERROR;
#ifdef    MONOPOLYTRUE
    OP    b = CALLOCOBJECT();
    OP    ptr;

    if (S_O_K(l) != MONOPOLY)
        goto exit_label;
    if (not EMPTYP(a))
        freeself(a);
    M_I_I(1L,a);
    ptr    = l;
    if (EMPTYP(S_PO_S(ptr)))
        ptr    = S_L_N(ptr);    /* skip the empty term    */
    while (ptr != NULL)
    {
        hoch(S_PO_S(ptr),S_PO_K(ptr),b);
        mult(a,b,a);
        ptr    = S_L_N(ptr);
    }
    ret    = OK;
exit_label:
    freeall(b);
#else
    error("integer_factors_to_integer: MONOPOLY not available");
#endif
    return(ret);
}


/* Given the number n, which should be an positive INTEGER or LONGINT
 * or a MONOPOLY representing a factorisation of an integer greater
 * than 1 , the result returns the list of positive integers coprime
 * to n.
 */
INT make_coprimes(OP number, OP result)
{
    INT    end_flag = 0L, flag= -1L;
    INT    erg    = ERROR;
    OP    ptr, ptr_zwei, ptr_drei, num=NULL;
#ifdef MONOPOLYTRUE
    OP    new, list=NULL;
    OP vec,prime,count_eins,count_zwei;

    CTTTO(INTEGER,MONOPOLY,LONGINT,"make_coprimes(1)",number);

    vec = CALLOCOBJECT();
    prime = CALLOCOBJECT();
    count_eins = CALLOCOBJECT();
    count_zwei = CALLOCOBJECT();

    init(LIST,result);
    if (S_O_K(number) == MONOPOLY)
    {
        list    = number;
        num    = CALLOCOBJECT();
        flag    = 1L;    /* remember to free num    */
        integer_factors_to_integer(list,num);
    }
    else
    {
        if (((S_O_K(number) != INTEGER) && (S_O_K(number) != LONGINT))
            || (LT(number,cons_eins) == TRUE))
            goto exit_label;
        if (EQ(number,cons_eins) == TRUE)
        {
            new    = CALLOCOBJECT();
            M_I_I((INT)1,new);
            insert(new,result,NULL,NULL);
            erg    = OK;
            goto exit_label;
        }
        num    = number;
        list    = CALLOCOBJECT();
        flag    = 0L;    /* remember to free list    */
        integer_factor(num,list);
    }
    m_i_i((INT)1,count_eins);
    init(LIST,vec);
    ptr    = vec;
    while (TRUE)
    {    /* vec is initialised to the list of numbers 1 , . . ., num */
        S_L_S(ptr)    = CALLOCOBJECT();
        copy(count_eins,S_L_S(ptr));
        if (LT(count_eins,num) == TRUE)
        {
            new    = CALLOCOBJECT();
            S_L_N(ptr)    = new;
            ptr    = new;
            init(LIST,new);
            INC(count_eins);
        }
        else
        {
            S_L_N(ptr)    = NULL;
            break;
        }
    }
    ptr    = list;
    while (ptr != NULL)
    {
        copy(S_PO_S(ptr),prime);
	M_I_I(1,count_eins);
	M_I_I(1,count_zwei);
        ptr_zwei    = vec;
        while (LE(count_eins,num) == TRUE)
        {    /* delete all multiples of prime from vec */
            if (EQ(count_zwei,prime) == TRUE)
            {
		M_I_I(1,count_zwei);
                if (not EMPTYP(S_L_S(ptr_zwei)))
                    FREESELF(S_L_S(ptr_zwei));
            }
            else
                INC_INTEGER(count_zwei);
            INC_INTEGER(count_eins);
            ptr_zwei    = S_L_N(ptr_zwei);
        }
        ptr    = S_L_N(ptr);
    }
    ptr    = result;
    ptr_drei    = result;
    copy(cons_eins,count_eins);
    ptr_zwei    = vec;
    while (TRUE)
    {
        if (EQ(count_eins,num) == TRUE)
            end_flag    = 1L;
        if (not EMPTYP(S_L_S(ptr_zwei)))
        {
            S_L_S(ptr)    = CALLOCOBJECT();
            copy(count_eins,S_L_S(ptr));
            if (end_flag)
            {
                S_L_N(ptr)    = NULL;
                break;
            }
            else
            {
                new    = CALLOCOBJECT();
                init(LIST,new);
                S_L_N(ptr)    = new;
                ptr_drei    = ptr;
                ptr    = new;
            }
        }
        if (end_flag)
        {
            freeall(ptr);
            S_L_N(ptr_drei)    = NULL;
            break;
        }
        INC(count_eins);
        ptr_zwei    = S_L_N(ptr_zwei);
    }
    erg    = OK;
exit_label:
	FREEALL4(vec,prime,count_eins,count_zwei);
    if (flag == 1L) freeall(num);
    else  if (flag != -1L) freeall(list);
#endif
    ENDR("make_coprimes");
}


/* number of numbers coprime to a */
INT euler_phi(OP a, OP b)
{
    OP c = CALLOCOBJECT();
    INT erg;
    erg    = make_coprimes(a,c);
    erg += length(c,b);
    erg += freeall(c);
    return erg;
}


/* true if power of a prime */
INT prime_power_p(OP a)
{
    INT erg = OK;
    CTTO(INTEGER,LONGINT,"prime_power_p(1)",a);
    if (NULLP(a)) return FALSE;
    if (NEGP(a)) return FALSE;

    {
    OP b; INT res;
    b = CALLOCOBJECT();
    factorize(a,b);
    if (EQ(S_V_I(b,0),S_V_I(b,S_V_LI(b)-1))) res = TRUE;
    else res = FALSE;
    FREEALL(b);
    return res;
    }

    ENDR("prime_power_p");
}


/* true if prime */
INT primep(OP a)
{
    OP c,d,e;
    INT erg = TRUE;

    if (EQ(a,cons_zwei))
        {
        erg = TRUE;
        goto p1;
        }
    if (negp(a) || NULLP(a) || EVEN(a) )
        {
        erg = FALSE;
        goto p1;
        }
    CALLOCOBJECT3(c,d,e);

    ganzsquareroot(a,c);
    M_I_I(3,d);
    while (le(d,c))
        {
        mod(a,d,e);
        if (NULLP(e) )
            { erg = FALSE; break; }
        ADD_APPLY(cons_zwei,d);
        }
    FREEALL3(c,d,e);
p1:
    return erg;
    ENDR("primep");
}

/*    INTEGER SQUARE ROOTS    */

/*
 * If a is a non-negative integer (INTEGER or LONGINT) s is set to the
 * integer part of its square root.  In this case, the return value is
 * OK or IMPROPER according as the integer is a perfect square or not.
 * Otherwise, the return value is ERROR.
 */
static INT nb_square_root(OP a, OP s)
{
    INT    a_eins,d_eins,e_eins,ret    = ERROR;
    INT erg = OK;
    OP b,c,d,e,diff;
    CTTO(INTEGER,LONGINT,"nb_square_root(1)",a);

    b = CALLOCOBJECT();
    c = CALLOCOBJECT();
    d = CALLOCOBJECT();
    e = CALLOCOBJECT();
    diff = CALLOCOBJECT();

    if (negp(a))    /* a < 0L */
    {
        fprintf(stderr,"Negative number has no real square root\n");
        goto exit_label;
    }
    if (NULLP(a))
    {
        m_i_i(0l,s);
        ret    = OK;
        goto exit_label;
    }
    d_eins    = number_of_digits(a);

    e_eins    = (d_eins + 1L) / 2L;

    M_I_I(10L,d);
    M_I_I(e_eins-1L,b);
    hoch(d,b,b);
    MULT(d,b,c);
    FREESELF(d); MULT(b,b,d);
    if (EQ(a,d) == TRUE)
    {
        copy(b,s);
        ret    = OK;
        goto exit_label;
    }
    do
    {
        FREESELF(d);
        ADD(b,c,d);
        if (negp(d))
            error("square_root : negative integer unexpectedly encountered\n");

        half_apply(d);
        FREESELF(diff);
        ADDINVERS(b,diff);
        ADD_APPLY(c,diff);
        FREESELF(e); MULT(d,d,e);
        a_eins    = COMP(a,e);
        if (a_eins < 0L)
            copy(d,c);
        else if (a_eins > 0L)
            copy(d,b);
        else
        {
            copy(d,s);
            ret    = OK;
            goto exit_label;
        }

    }        while (GE(diff,cons_zwei) == TRUE);
    copy(b,s);
    ret = IMPROPER;
exit_label:
    FREEALL5(b,c,d,e,diff);
    CTTO(INTEGER,LONGINT,"nb_square_root(e2)",s);
    return(ret);
    ENDR("nb_square_root");
}

#ifdef LONGINTTRUE
INT ganzsquareroot_longint(OP a, OP b)
{
    INT erg ;
    erg = nb_square_root(a,b);
    return (erg == IMPROPER ? OK : erg);
}
#endif /* LONGINTTRUE */


INT ganzsquareroot_integer(OP a, OP b)
{
    INT erg ;
    erg = nb_square_root(a,b);
    return (erg == IMPROPER ? OK : erg);
}

/*  INTEGER FACTORISATION    */

/* Routines for prime factorization of integers.
 *
 *  - prime_table points to an array of INT with the first no_primes
 *    primes.
 *  - prime_table_set is a flag which indicates whether the table is
 *    present or not.
 */

static INT    prime_table_set    = 0L, no_primes;
static INT  *prime_table;

/* Reads the table of primes from the file PRIMES.DAT. The first entry
 * should be no_primes, then the list of primes.  Assumes that INT
 * means long int.  Returns OK if the table is set; otherwise, returns
 * ERROR.
 */
static INT setup_prime_table(void)
{
# ifdef PRIMES_FILE

    FILE    *f;
    if ( (f = fopen("PRIMES.DAT","r")) == NULL ||
        fscanf(f," %ld",&no_primes) == 0 || no_primes < 1L ||
        (prime_table = (INT *)SYM_calloc((int)no_primes,sizeof(INT))) == NULL )
    {
        no_primes    = 0L;
        return(ERROR);
    }
    for (i=0L;i<no_primes;i++)
        if (fscanf(f," %ld",&prime_table[i]) != 1)
        {
            SYM_free(prime_table);
            no_primes    = 0L;
            return(ERROR);
        }
    prime_table_set    = 1L;
# else
    no_primes    = 15L;
    if ((prime_table = (INT *)SYM_calloc((int)no_primes,sizeof(INT))) == NULL )
    {
        no_primes    = 0L;
        return(ERROR);
    }
    prime_table[0] = 2L;
    prime_table[1] = 3L;
    prime_table[2] = 5L;
    prime_table[3] = 7L;
    prime_table[4] = 11L;
    prime_table[5] = 13L;
    prime_table[6] = 17L;
    prime_table[7] = 19L;
    prime_table[8] = 23L;
    prime_table[9] = 29L;
    prime_table[10] = 31L;
    prime_table[11] = 37L;
    prime_table[12] = 41L;
    prime_table[13] = 43L;
    prime_table[14] = 47L;
    prime_table_set    = 1L;

# endif /* PRIMES_FILE */

    return(OK);
}

#ifdef    MONOPOLYTRUE
/* This routine factorizes an integer using the table of primes.
 *
 *   a -- the integer to be factored;
 *   l -- a list in which the prime factors of a, which are contain-
 *        ed in the table, and their exponents are inserted as monomials
 *        with the primes as the selfs and the exponents as the koeffs;
 *   g -- the remaining factor;
 *   m -- the last number tried as a factor.
 *   first_prime -- the variable to point to the first prime factor
 *                  if that is all that is required. For a full factorization,
 *                   it must be set to NULL.
 *
 * l must be a MONOPOLY. a,l,g,m and first_prime must be different.
 */
static INT integer_factor_0(OP a, OP l, OP g, OP m, OP first_prime)
{
    INT    i,erg    = ERROR;
    OP    b = CALLOCOBJECT(), c = CALLOCOBJECT(), d = CALLOCOBJECT(),
        e = CALLOCOBJECT(), k = CALLOCOBJECT(), f;

    if (S_O_K(a) != INTEGER && S_O_K(a) != LONGINT)
        goto exit_label;
    if (S_O_K(l) != MONOPOLY)
        goto exit_label;
    if (a == b || a == c || a == l || a == first_prime || b == c || b == l
        || a == first_prime  || c == l || c == first_prime|| l == first_prime)
        goto exit_label;
    copy(a,b);
    if (EQ(b,cons_eins) == TRUE)
    {
        f    = CALLOCOBJECT();
        m_sk_mo(cons_eins,cons_eins,f);
        insert(f,l,add_koeff,NULL);
    }
    else if (LT(b,cons_null) == TRUE)
    {
        addinvers_apply(b);
        f    = CALLOCOBJECT();
        M_I_I(-1L,c);
        m_sk_mo(c,cons_eins,f);
        insert(f,l,add_koeff,NULL);
    }
    if (EINSP(b))
    {
        erg    = OK;
        copy(b,g);
        copy(b,m);
        goto exit_label;
    }
    nb_square_root(b,e); /* e = sqrt(a) */

    CTTO(INTEGER,LONGINT,"integer_factor_0(i1)",e);
    if (!prime_table_set)
        if (setup_prime_table() == ERROR) goto exit_label;
    for (i=0L;i<no_primes;i++)
    {
        m_i_i(0,k);
        m_i_i((INT)prime_table[i],c);
        if (GT(c,e) == TRUE)
        {
	    /* all primes not greater than sqrt(b) have been tried. */
            if (first_prime != NULL)
            {
                copy(b,first_prime);
                erg    = OK;
                goto exit_label;
            }
            f    = CALLOCOBJECT();
            m_i_i(1L,d);
            m_sk_mo(b,d,f);
            insert(f,l,add_koeff,NULL);
            m_i_i(1L,b);
            break;
        }
        mod(b,c,d);

        while(NULLP(d))
        {
            if (first_prime != NULL)
            {
                copy(c,first_prime);
                erg    = OK;
                goto exit_label;
            }
            INC(k);
            ganzdiv(b,c,b);
            mod(b,c,d);
            nb_square_root(b,e); /* e = sqrt(b) */
        }
        if (GT(k,cons_null) == TRUE)
        {
            f    = CALLOCOBJECT();
            m_sk_mo(c,k,f);
            insert(f,l,add_koeff,NULL);
        }
        if (EINSP(b)) break;

    }
    erg    = OK;
    copy(b,g);
    copy(c,m);
exit_label:
    FREEALL(b);
    FREEALL(c);
    FREEALL(d);
    FREEALL(e);
    FREEALL(k);
    CTO(MONOPOLY,"integer_factor_0(e2)",l);
    CTO(INTEGER,"integer_factor_0(e3)",g);
    ENDR("integer_factor_0");
}
#endif /* MONOPOLYTRUE */

/* This routine finds all prime factors between two bounds
 *   a -- the integer to be factored;
 *   l -- a list in which the prime factors of a, between the given
 *        bounds, and their exponents are inserted as monomials
 *        with the primes as the selfs and the exponents as the koeffs;
 *        if l is not a MONOPOLY, it is initialised to one;
 *   b -- the remaining factor;
 *   f_eins -- the lower bound on trial factors.
 *             If it is even, it is replaced by f_eins+1.
 *   f_zwei -- the upper bound on trial factors.
 *   first_prime -- the variable to point to the first prime factor
 *                  if that is all that is required. For a full
 *                  factorization, it must be set to NULL.
 *
 * l must be a MONOPOLY. a,l,b,f_eins,f_zwei,first_prime must be different.
 */

static INT integer_factor_1(OP a, OP f_eins, OP f_zwei, OP b, OP l, OP first_prime)
{
    INT    flag = 1L;
    INT erg = OK;
    INT    ret = ERROR, new_factor = 0L, myfirst = 1L;
#ifdef    MONOPOLYTRUE
    OP    c = CALLOCOBJECT(), f = CALLOCOBJECT(), e = CALLOCOBJECT(),
        e_eins = CALLOCOBJECT(), q = CALLOCOBJECT(), r = CALLOCOBJECT(),
        k, g;
    if (S_O_K(l) != MONOPOLY)
        init(MONOPOLY,l);
    copy(a,c);
    if (LT(c,cons_null) == TRUE)
    {
        addinvers(c,c);
        M_I_I(1L,f);
        M_I_I(-1L,e);
        k = CALLOCOBJECT();
        m_sk_mo(e,f,k);
        insert(k,l,add_koeff,NULL);
    }
    k    = CALLOCOBJECT();
    copy(f_zwei,e);
    copy(f_eins,f);
    if (LT(f,cons_eins) == TRUE)    /* Make the initial divisor >= 2 */
        copy(cons_zwei,f);
    nb_quores(f,cons_zwei,q,r);
    if (nullp(r))
    {
        if (einsp(q)) /* f = 2 */
            flag = 0L;
        else    /* f is even and greater than 2 */
            INC(f);
    }
    nb_quores(c,f,q,r);

    while (LE(f,e) == TRUE)
    {
        while (nullp(r))
{
            /* The value of c entering this loop is divisible by f
             * exactly k times, where k refers to its value exiting
             * the loop. */
            if (first_prime != NULL)
            {
                copy(f,first_prime);
                ret    = OK;
                goto exit_label;
            }
            if (myfirst)
            {
                M_I_I(1L,k);
                new_factor    = 1L;
                myfirst    = 0L;
            }
            else
                INC(k);
            ganzdiv(c,f,c);
            nb_quores(c,f,q,r);
        }
        if (new_factor)
        {   /* make new monomial and insert in the factor list */
            g    = CALLOCOBJECT();
            m_sk_mo(f,k,g);
            insert(g,l,add_koeff,NULL);
            new_factor    = 0L;
            if (EQ(c,cons_eins) == TRUE)
                break;
            nb_square_root(c,e_eins);
            /* reduce the upper limit of the trial factors */
            if (LT(e_eins,e) == TRUE)
                copy(e_eins,e);
            /* the current c is a prime or it has prime factors
             * are less than f_eins, and the factorization is 'complete'. */
            if (LT(e,f) == TRUE)
                break;
        }
        myfirst    = 1L;
        /* Increase f by 2 and find corresponding q and r */
        INC(f);
        if (flag) INC(f);
        flag    = 1L;
        nb_quores(c,f,q,r);
    }
    copy(c,b);
    ret    = OK;
exit_label:
    freeall(c);
    freeall(q);
    freeall(r);
    freeall(f);
    freeall(k);
    freeall(e); 
    freeall(e_eins);
#else /* MONOPOLYTRUE */
    error("integer_factor_1: MONOPOLY not available");
#endif /* MONOPOLYTRUE */
    return(ret);
}

/*    This is the main integer factorization routine.
 *
 *      a -- the integer to be factored;
 *      l -- a list in which the prime factors of a and their exponents
 *           are inserted as monomials with the primes as the selfs and the
 *           exponents as the koeffs. l need not be initialized to a MONOPOLY.
 */
INT integer_factor(OP a, OP l)
{
    INT    erg    = ERROR;

    OP b,c,d,e;
    CTTO(INTEGER,LONGINT,"integer_factor(1)",a);
    CE2(a,l,integer_factor);

    b = CALLOCOBJECT();
    c = CALLOCOBJECT();
    d = CALLOCOBJECT();
    e = CALLOCOBJECT();

    init(MONOPOLY,l);

    /* First factorize using the list of primes in "PRIMES.DAT" */
    if (integer_factor_0(a,l,b,c,NULL) != OK)
    {
        copy(a,b);
        M_I_I(1L,c);
    }
    if (EQ(b,cons_eins) == TRUE) /* Factorization complete. */
    {
        erg    = OK;
        goto exit_label;
    }
    copy(b,d);
    if (integer_factor_1(b,c,d,e,l,NULL) == OK)
    {
        /* If e > 1, it is a prime greater than those in l */
        m_i_i(1L,c);
        if (gt(e,c) == TRUE)
        {
            m_sk_mo(e,c,d);
            insert(d,l,add_koeff,NULL);
            m_i_i(1L,e);
            d    = CALLOCOBJECT();
        }
        erg    = OK;
    }
    else
        printf("\ninteger_factor: factorization error");
exit_label:
    FREEALL4(b,c,d,e);
    CTO(MONOPOLY,"integer_factor(e2)",l);
    ENDR("integer_factor");
}

/*
 * This routine finds the smallest prime factor of an integer.
 *
 *    a -- the integer;
 *    first_prime -- its smallest prime factor.
 */
INT first_prime_factor(OP a, OP first_prime)
{
    INT    ret    = ERROR;
#ifdef    MONOPOLYTRUE
    OP    b = CALLOCOBJECT();
    OP    c = CALLOCOBJECT();
    OP    d = CALLOCOBJECT();
    OP    e = CALLOCOBJECT();
    OP    l = CALLOCOBJECT();

    if (S_O_K(a) != INTEGER && S_O_K(a) != LONGINT)
        goto exit_label;
    init(MONOPOLY,l);
    m_i_i(1L,first_prime);
    copy(a,d);
    if (LT(d,cons_null) == TRUE)
        addinvers(d,d);
    if (einsp(d))
    {
        ret    = OK;
        goto exit_label;
    }
    if (integer_factor_0(d,l,b,c,first_prime) == OK)
        if (einsp(first_prime))
            if (integer_factor_1(d,c,d,e,l,first_prime) != OK
                || einsp(first_prime))
                goto exit_label;
    ret    = OK;
exit_label:
    if (ret != OK)
        printf("\nfirst_prime_factor: factorization error");
    freeall(b);
    freeall(c);
    freeall(d);
    freeall(e);
    freeall(l);
#else
    error("integer_factor: MONOPOLY not available");
#endif
    return(ret);
}

/*    SQUARE-FREE PARTS    */

/*
 * This routine find the square-free part of the integer, which is
 * given as a prime factors list.
 *
 *   la -- a MONOPOLY containing the prime factorization of the integer
 *   lb, lc -- return the MONOPOLYs containing the prime factorization
 *             of the square-free and square parts, respectively.
 *
 * The parameters la,lb,lc must be distinct.
 */
INT square_free_part_0(OP la, OP lb, OP lc)
{
    INT    erg    = ERROR;
    INT    flag_b    = 1L, flag_c    = 1L;
    OP    u , x , y ,
        z , ptr, w;

    CTO(MONOPOLY,"square_free_part_0(1)",la);

    u = CALLOCOBJECT();
    x = CALLOCOBJECT();
    y = CALLOCOBJECT();
    z = CALLOCOBJECT();

    ptr    = la;
    init(MONOPOLY,lb);
    init(MONOPOLY,lc);
    while (ptr != NULL)
    {
        copy(S_PO_S(ptr),u);  /* the prime    */
        copy(S_PO_K(ptr),x);  /* the exponent */
        if (negp(x))
            error("square_free_part_0 : unexpected negative exponent");
        nb_quores(x,cons_zwei,z,y);
        if (nullp(y))   /* even power */
        {
            w    = CALLOCOBJECT();
            m_sk_mo(u,z,w);
            insert(w,lc,add_koeff,NULL);
            flag_c    = 0L;
        }
        else
        {
            if (not nullp(z))
            {
                w    = CALLOCOBJECT();
                m_sk_mo(u,z,w);
                insert(w,lc,add_koeff,NULL);
                flag_c    = 0L;
            }
            w    = CALLOCOBJECT();
            m_sk_mo(u,cons_eins,w);
            insert(w,lb,add_koeff,NULL);
            flag_b    = 0L;
        }
        ptr    = S_L_N(ptr);
    }
    if (flag_b)
    {
        w    = CALLOCOBJECT();
        m_sk_mo(cons_eins,cons_eins,w);
        insert(w,lb,add_koeff,NULL);
    }
    if (flag_c)
    {
        w    = CALLOCOBJECT();
        m_sk_mo(cons_eins,cons_eins,w);
        insert(w,lc,add_koeff,NULL);
    }
    erg    = OK;

    freeall(u);
    freeall(x);
    freeall(y);
    freeall(z);
    CTO(MONOPOLY,"square_free_part_0(e2)",lb);
    CTO(MONOPOLY,"square_free_part_0(e3)",lc);
    ENDR("square_free_part_0");
}

/*
 * This routine find the square-free part of the integer, i.e. the
 * product of the prime factors (and -1 , if the integer is < 0.
 *
 *   a -- the integer, it is either an INTEGER, LONGINT or a
 *        MONOPOLY containing the prime factorization of an integer.
 *   b -- the square-free part (a = b * c  2)
 *   c -- the square-root of the square part.
 *   la -- returns a MONOPOLY containing the prime factorization of
 *         a if a is not a MONOPOLY and la is not NULL.
 *   lb, lc -- returns the MONOPOLYs containing the prime
 *             factorizations of b and c.
 *
 * The parameters a,b,c must be distinct.  If la,lb,lc are not
 * NULL they must be distinct also.
 */
INT square_free_part(OP a, OP b, OP c, OP la, OP lb, OP lc)
{
    INT    erg    = ERROR;
    OP    la_tmp=NULL, lb_tmp=NULL, lc_tmp=NULL;

    CTTTO(INTEGER,LONGINT,MONOPOLY,"square_free_part(1)",a);

    if (S_O_K(a) == INTEGER || S_O_K(a) == LONGINT)
    {
        if (la == NULL)
            la_tmp    = CALLOCOBJECT();
        else
            la_tmp    = la;
        init(MONOPOLY,la_tmp);
        integer_factor(a,la_tmp);
    }
    else if (S_O_K(a) == MONOPOLY)
        la_tmp    = a;
    else
        goto exit_label;
    if (lb == NULL)
        lb_tmp    = CALLOCOBJECT();
    else
        lb_tmp    = lb;
    init(MONOPOLY,lb_tmp);
    if (lc == NULL)
        lc_tmp    = CALLOCOBJECT();
    else
        lc_tmp    = lc;
    init(MONOPOLY,lc_tmp);
    square_free_part_0(la_tmp,lb_tmp,lc_tmp);
    integer_factors_to_integer(lb_tmp,b);
    integer_factors_to_integer(lc_tmp,c);
    erg    = OK;
exit_label:
    if (la == NULL && la_tmp != a) freeall(la_tmp);
    if (lb == NULL) freeall(lb_tmp);
    if (lc == NULL) freeall(lc_tmp);

    CTTO(INTEGER,LONGINT,"square_free_part(e2)",b);
    CTTO(INTEGER,LONGINT,"square_free_part(e3)",c);
    ENDR("square_free_part");
}


/*
 * The Jacobi Symbol: (a/b) b odd.
 *
 * a and b are integers. c must point to a location different from a and b.
 * if a and b have a common factor, c is set to 0 and ERROR is returned.
 * otherwise, c is set to the the jacobi symbol (a/b). Note that b must
 * be odd.
 */
INT jacobi(OP a, OP b, OP c)
{
    INT erg = OK;
    OP    x , y , z , w , y_eins , y_zwei ,
        z_eins , z_zwei , four , eight    ;
    INT    ret    = ERROR;
    INT    d, f = 0L;

    CTTO(INTEGER,LONGINT,"jacobi(1)",a);
    CTTO(INTEGER,LONGINT,"jacobi(2)",b);
    CE3(a,b,c,jacobi);
    M_I_I(0,c);

    if (EVEN(b))
    {
        printf("Jacobi Symbol: Second integer must be odd\n");
        goto e2;
    }
    x =CALLOCOBJECT(), y = CALLOCOBJECT(), z = CALLOCOBJECT(),
    w = CALLOCOBJECT(), y_eins = CALLOCOBJECT(), y_zwei = CALLOCOBJECT(),
    z_eins = CALLOCOBJECT(), z_zwei = CALLOCOBJECT(),
    four = CALLOCOBJECT(), eight    = CALLOCOBJECT();
    M_I_I(4,four);
    M_I_I(8,eight);

    COPY(a,x);
    COPY(b,y);
    if (NEGP(y)) ADDINVERS_APPLY(y);

    while (NEQ(y,cons_eins))
    {
        mod(x,y,z);
        if (NULLP(z))    /* The numbers are not relatively prime */
            goto exit_label;
        if (ODD(z))
        {
            FREESELF(w);
            ADDINVERS(y,w);
            ADD_APPLY(w,z);
        }
        d        = 0L;
        while (EVEN(z))
        {
            d    = 1L - d;
            ganzdiv(z,cons_zwei,z);
            if (NULLP(z))    /* The numbers are not relatively prime */
                goto exit_label;
        }
        FREESELF(x);COPY(y,x);
        FREESELF(y_eins);COPY(y,y_eins);
        DEC(y_eins);
        mod(y_eins,eight,y_zwei);
        FREESELF(z_eins);COPY(z,z_eins);
        DEC(z_eins);
        mod(z_eins,eight,z_zwei);
        FREESELF(y_eins);MULT(y_zwei,z_zwei,y_eins);
        mod(y_eins,eight,y_eins);
        if (GE(y_eins,four))
            f    = 1L - f;
        if (d)    /* an odd power of two */
        {
            INC(y);
            mod(y,eight,y_eins);
            if (GE(y_eins,four))
                f    = 1L - f;
        }
        if (NEGP(z))
            ADDINVERS_APPLY(z);
        FREESELF(y);COPY(z,y);
    }
    m_i_i(1,c);
    if (f)
        M_I_I(-1,c);
    ret    = OK;
exit_label:
    FREEALL(x);
    FREEALL(y);
    FREEALL(z);
    FREEALL(w);
    FREEALL(y_eins);
    FREEALL(y_zwei);
    FREEALL(z_eins);
    FREEALL(z_zwei);
    FREEALL(four);
    FREEALL(eight);
e2:
    return(ret);
    ENDR("jacobi");
}


/*
 * The Kronecker Symbol: (a/b). a square-free and congruent to 0 or 1 mod 4.
 * a and b are integers. c must point to a location different from a and b.
 * if a and b have a common factor, c is set to 0 and ERROR is returned.
 *  otherwise, c is set to the the jacobi symbol (a/b). Note that b must
 *  be odd.
 */
INT kronecker(OP a, OP b, OP c)
{
    INT    flag    = 0L;
    INT    ret    = ERROR;
    INT erg = OK;
    OP    a_eins = CALLOCOBJECT(), a_zwei = CALLOCOBJECT(), b_null = CALLOCOBJECT(),
        b_eins = CALLOCOBJECT(), b_zwei = CALLOCOBJECT(), b_drei = CALLOCOBJECT(),
        four = CALLOCOBJECT();

    if (c == a || c == b || nullp(a) || nullp(b))
        goto exit_label;
    COPY(a,a_eins);
    COPY(b,b_eins);
    if (NEGP(b_eins))
        ADDINVERS_APPLY(b_eins);
    M_I_I(4L,four);
    copy(cons_null,c);
    mod(a_eins,four,a_zwei);
    if (NULLP(a_zwei))
        flag    = 1L;
    else if (!einsp(a_zwei))
        goto exit_label;
    nb_quores(b_eins,cons_zwei,b_zwei,b_drei);
    copy(cons_null,b_null);
    if (NULLP(b_drei))    /* b is even. */
    {
        if (flag)    /* a is even also. */
            goto exit_label;
        do
        {
            INC(b_null);
            copy(b_zwei,b_eins);
            nb_quores(b_eins,cons_zwei,b_zwei,b_drei);
        }        while (nullp(b_drei));
    }                /* b_eins is the largest odd factor of b. */
    nb_quores(b_null,cons_zwei,b_null,b_zwei);
    if (NULLP(b_zwei))    /* b is divisible by an odd power of two and a is odd. */
    {
        m_i_i(8L,b_drei);
        mod(a_eins,b_drei,b_zwei);
        if (NEQ(b_zwei,cons_eins))
            flag    = 1L;        /* negate the final value */
    }
    else
        flag    = 0L;
    /* At this point, b_eins is odd */
    jacobi(a_eins,b_eins,c);
    if (flag)
        ADDINVERS_APPLY(c);
    ret    = OK;
exit_label:
    FREEALL(a_eins);
    FREEALL(a_zwei);
    FREEALL(four);
    FREEALL(b_null);
    FREEALL(b_eins);
    FREEALL(b_zwei);
    FREEALL(b_drei);
    return(ret);
    ENDR("kronecker");
}


INT eq_cyclotomic(OP a, OP b)
{
    INT erg = OK,r;
    OP c;
    CTO(CYCLOTOMIC,"eq_cyclotomic(1)",a);
    if (S_O_K(b) != CYCLOTOMIC) return FALSE;
    c = CALLOCOBJECT();
    sub(a,b,c);
    r = NULLP(c);
    FREEALL(c);
    return r;
    ENDR("eq_cyclotomic");
}


INT eq_sqrad(OP a, OP b)
{
    INT erg = OK,r;
    OP c;
    CTO(SQ_RADICAL,"eq_sqrad(1)",a);
    if (S_O_K(b) != SQ_RADICAL) return FALSE;
    c = CALLOCOBJECT();
    sub(a,b,c);
    r = NULLP(c);
    FREEALL(c);
    return r;
    ENDR("eq_sqrad");
}

INT eq_fieldobject_int(OBJECTKIND type, OP a, INT i)
{
    INT    ret = FALSE;
    OP    b = CALLOCOBJECT();
    OP    c = CALLOCOBJECT();
    INT erg = OK;
    M_I_I(-i,b);
    switch(S_O_K(a))
    {
#ifdef MONOPOLYTRUE
    case MONOPOLY:
        add_scalar_monopoly(b,a,c);
        ret    = nullp_monopoly(c);
        break;
#endif /* MONOPOLYTRUE */
#ifdef CYCLOTRUE
    case CYCLOTOMIC:
        add_scalar_cyclo(b,a,c);
        ret    = nullp_monopoly(S_N_S(c));
        break;
#endif /* CYCLOTRUE */
#ifdef SQRADTRUE
    case SQ_RADICAL:
        add_scalar_sqrad(b,a,c);
        ret    = nullp_monopoly(S_N_S(c));
        break;
#endif /* SQRADTRUE */
    default:
        error("eq_fieldobject_int: invalid type\n");
    }
    FREEALL(b); 
    FREEALL(c);
    return(ret);
    ENDR("eq_fieldobject_int");
}

#ifdef NUMBERTRUE

static struct number * callocnumber(void)
{
    struct number *result=(struct number *)
        SYM_calloc(1,sizeof(struct number));
    if (result == NULL) error("callocnumber:no mem");
    number_mem++;
    return(result);
}
#endif /* NUMBERTRUE */


INT m_ksd_n(OBJECTKIND kind, OP self, OP data, OP result)
{
    INT erg = ERROR;
#ifdef NUMBERTRUE
    erg = b_ksd_n(kind,CALLOCOBJECT(),CALLOCOBJECT(),result);
    if ((S_O_K(self) != MONOPOLY)  ||
          ((kind == SQ_RADICAL) && (S_O_K(data) != LIST)))
        return( error("m_ksd_n: invalid self or data") );
    erg += copy(self,S_N_S(result));
    erg += copy(data,S_N_D(result));
#endif /* NUMBERTRUE */
    return erg;
}


INT init_sqrad(OP a)
{
    INT erg = OK;
    CTO(EMPTY,"init_sqrad(1)",a);
    erg +=  b_ksd_n(SQ_RADICAL, CALLOCOBJECT(), CALLOCOBJECT(), a);
    ENDR("init_sqrad");
}


INT init_cyclo(OP a)
{
    INT erg = OK;
    CTO(EMPTY,"init_cyclo(1)",a);

    erg +=  b_ksd_n(CYCLOTOMIC, CALLOCOBJECT(), NULL, a);

    ENDR("init_cyclo");
}


#ifdef NUMBERTRUE
INT b_ksd_n(OBJECTKIND kind, OP self, OP data, OP result)
{
    OBJECTSELF obself;
    if (not EMPTYP(result))
        freeself(result);
    obself.ob_number = callocnumber();
    b_ks_o(kind,obself,result);
    if (EMPTYP(self))
        init(MONOPOLY,self);
    if (kind == SQ_RADICAL && EMPTYP(data))
        init(LIST,data);
    if ((S_O_K(self) != MONOPOLY)  ||
        ((kind == SQ_RADICAL) && (S_O_K(data) != LIST)))
            return( error("b_ksd_n: invalid self or data") );
    S_N_S(result)    = self;
    S_N_D(result)    = data;
    return(OK);
}
#endif /* NUMBERTRUE */

INT objectwrite_number(FILE *f, OP number)
{
#ifdef NUMBERTRUE
    fprintf(f, " %" PRIINT "\n" ,(INT)S_O_K(number));
    objectwrite(f,S_N_S(number));
    switch (S_O_K(number))
    {
    case    SQ_RADICAL:
        objectwrite(f,S_N_D(number));
        break;
    case    CYCLOTOMIC:
        objectwrite(f,S_N_DCI(number));
        break;
    default:
        error("Invalid number type\n");
    }
    return(OK);
#else /* NUMBERTRUE */
    error("objectwrite_number:NUMBER not available");
    return(ERROR);
#endif /* NUMBERTRUE */
}


INT objectread_number(FILE *f, OP number, OBJECTKIND type)
{
#ifdef NUMBERTRUE
    init(type,number);
    objectread(f,S_N_S(number));
    switch (S_O_K(number))
    {
    case    SQ_RADICAL:
        objectread(f,S_N_D(number));
        break;
    case    CYCLOTOMIC:
        {
            OP    index = CALLOCOBJECT();
            objectread(f,index);
            S_N_DC(number)    = add_cyclo_data(index);
        }
        break;
    default:
        error("Invalid number type\n");
    }
    return(OK);
#endif /* NUMBERTRUE */
}


INT fprint_number(FILE *f, OP n)
{
    INT    saving;
#ifdef NUMBERTRUE
    switch (S_O_K(n))
    {
    case    SQ_RADICAL:
        /*    Are all coefficients fractions with denominator 2    */
        if (S_O_K(S_PO_K(S_N_S(n))) == BRUCH)
        {
            OP    nn = CALLOCOBJECT();
            saving    = space_saving;
            space_saving = FALSE;
            mult_scalar_sqrad(cons_zwei,n,nn);
            space_saving = saving;
            if (integer_coefficients(S_N_S(nn)) == TRUE)
            {
                fprintf(f," 1/2 (");
                fprint_sqrad(f,nn);
                fprintf(f,")");
                freeall(nn);
                zeilenposition    += 7L;
                return(OK);
            }
            freeall(nn);
        }
        fprintf(f," ( ");
        fprint_sqrad(f,n);
        fprintf(f," )");
        zeilenposition    += 5L;
        break;
    case    CYCLOTOMIC:
        fprintf(f," ( ");
        fprint_cyclo(f,n);
        fprintf(f," )");
        zeilenposition    += 5L;
        break;
    default:
        ;
    }
#endif /* NUMBERTRUE */
    return(OK);
}


INT freeself_number(OP n)

{
#ifdef NUMBERTRUE
    OBJECTSELF d;
    INT erg = OK;
    d = S_O_S(n);
    erg = freeall(S_N_S(n));
    if (erg == ERROR)
        return error("freeself_number:error in freeall S_N_S");

    switch (S_O_K(n))
    {
    case    SQ_RADICAL:
        if (not EMPTYP(S_N_D(n)))
            freeall(S_N_D(n));
        else
            error("freeself_number: no data to release");
        break;
    case    CYCLOTOMIC:
        break;
    default:
        ;
    }
    SYM_free(d.ob_number);
    number_mem--;
    C_O_K(n,EMPTY);
#endif /* NUMBERTRUE */
    return OK;
}


INT comp_number(OP a, OP b)
{
#ifdef NUMBERTRUE
    switch (S_O_K(a))
    {
    case    SQ_RADICAL:
        comp_sqrad(a,b);
        break;
    case    CYCLOTOMIC:
        comp_cyclo(a,b);
        break;
    default:
        return error("comp_number:invalid number type\n");
    }
    return(OK);
#else /* NUMBERTRUE */
    return error("comp_number:NUMBER not available");
#endif /* NUMBERTRUE */
}


INT copy_number(OP a, OP b)
{
#ifdef NUMBERTRUE
    if (a == b)
        error("copy_number: First and second arguments are the same\n");
    init(S_O_K(a),b);
    if (S_N_S(a) != NULL) copy(S_N_S(a),S_N_S(b));
    switch (S_O_K(a))
    {
    case    SQ_RADICAL:
        copy(S_N_D(a),S_N_D(b));
        break;
    case    CYCLOTOMIC:
        S_N_DC(b)    = S_N_DC(a);
        break;
    default:
        return error("copy_number:invalid number type\n");
    }
    return(OK);
#endif /* NUMBERTRUE */
}


INT complex_conjugate(OP a, OP b)
{
    OP    ptr;
    if (a != b)
        copy(a,b);
#ifdef NUMBERTRUE
    switch (S_O_K(b))
    {
    case    SQ_RADICAL:
        ptr    = S_N_S(b);
        while (ptr != NULL)
        {
            if (not EMPTYP(S_PO_K(ptr)))
                complex_conjugate(S_PO_K(ptr),S_PO_K(ptr));
            if (LT(S_PO_S(ptr),cons_null) == TRUE)
                addinvers_apply(S_PO_K(ptr));
            ptr    = S_L_N(ptr);
        }
        break;
    case    CYCLOTOMIC:
        ptr    = S_N_S(b);
        while (ptr != NULL)
        {
            if (not EMPTYP(S_PO_K(ptr)))
            {
                complex_conjugate(S_PO_K(ptr),S_PO_K(ptr));
                addinvers_apply(S_PO_S(ptr));
                add_apply(S_N_DCI(b),S_PO_S(ptr));
            }
            ptr    = S_L_N(ptr);
        }
        break;
    default:
        break;
    }
#endif /* NUMBERTRUE */
    return(OK);
}

INT setup_numbers(INT basis, INT saving, char *filename)
{
#ifdef CYCLOTRUE
    number_mem = (INT)0;
#endif /* CYCLOTRUE */
#ifdef    MONOPOLYTRUE
    setup_prime_table();
#endif  /* MONOPOLYTRUE */
#ifdef    NUMBERTRUE
    basis_type        = basis;
    space_saving    = saving;
    setup_cyclotomic_table(filename);
#endif /* NUMBERTRUE */
    return(OK);
}


INT release_numbers(void)
{
#ifdef    MONOPOLYTRUE
    if (prime_table_set)
        {
        SYM_free(prime_table);
        prime_table = NULL;
        }
#endif
#ifdef    NUMBERTRUE
    if (cyclo_table_set)
        {
        free_cyclo_table();
        SYM_free(zzcyclo_table);
        cyclo_table_set = 0;
        }
    if (cyclo_list_set)
        {
        free_cyclo_list();
        freeall(zzcyclo_list);
        cyclo_list_set = 0;
        }
#endif
    return(OK);
}

INT nb_ende(void)
{
#ifdef CYCLOTRUE
    if (number_mem != 0L)
        fprintf(stderr, "error in number memory %" PRIINT "\n" ,number_mem);
    return OK;
#endif
}

INT reset_basis(INT basis)
{
#ifdef    NUMBERTRUE
    basis_type    = basis;
    if (basis == NO_REDUCE || basis == POWER_REDUCE)
        printf("\nWARNING: not a valid basis\n");
#endif
    return(OK);
}

INT reset_saving(INT saving)
{
#ifdef    NUMBERTRUE
    space_saving    = saving;
#endif
    return(OK);
}

INT tex_monom_plus(INT form, OP a)
{
    return tex_monom(a);
}


INT tidy(OP a)
{
    INT    i,j;
    OP    ptr;
    switch (S_O_K(a))
    {
#ifdef BRUCHTRUE
    case BRUCH :
        tidy(S_B_O(a));
        tidy(S_B_U(a));
        break;
#endif /* BRUCHTRUE */
    case INTEGER :
        break;
#ifdef LISTTRUE
    case POLYNOM:
    case LIST :
        ptr = a;
        while (ptr != NULL)
        {
            tidy(S_L_S(ptr));
            ptr    = S_L_N(ptr);
        }
        break;
#endif /* LISTTRUE */
#ifdef LONGINTTRUE
    case LONGINT :
        break;
#endif /* LONGINTTRUE */
#ifdef MATRIXTRUE
    case MATRIX :
        for (i=0L;i<S_M_LI(a);i++)
            for (j=0L;j<S_M_HI(a);j++)
                tidy(S_M_IJ(a,i,j));
        break;
#endif /* MATRIXTRUE */
#ifdef MONOMTRUE
    case MONOM :
        tidy(S_MO_S(a));
        tidy(S_MO_K(a));
        break;
#endif /* MONOMTRUE */
#ifdef NUMBERTRUE
    case SQ_RADICAL:
        break;
    case CYCLOTOMIC:
        standardise_cyclo_0(a,basis_type);
        break;
#endif /* NUMBERTRUE */
#ifdef VECTORTRUE
    case VECTOR :
        for (i=0L;i<S_V_LI(a);i++)
            tidy(S_V_I(a,i));
        break;
#endif /* VECTORTRUE */
    default:
        return error("tidy: invalid type\n");
    }
    return(OK);
}


#ifdef    MONOPOLYTRUE
/*    MONOPOLYS    */

INT eval_monopoly(OP a, OP b, OP c)
{
    INT erg = OK;
    OP z,d;

    CTO(MONOPOLY,"eval_monopoly",a);
    CE3(a,b,c,eval_monopoly);

    erg += m_i_i((INT)0,c);
    z = a;
    d = CALLOCOBJECT();
    while (z != NULL)
        {
        CTO(INTEGER,"eval_monopoly:non integer self part",
                S_MO_S(S_L_S(z)));
        erg += hoch(b,S_MO_S(S_L_S(z)),d);
        MULT_APPLY(S_MO_K(S_L_S(z)),d);
        erg += add_apply(d,c);
        z = S_L_N(z);
        }
    erg += freeall(d);

    ENDR("eval_monopoly");
}

INT einsp_monopoly(OP a)
{
    if (S_L_S(a) == NULL)
        return FALSE;
    if (S_L_N(a) != NULL)
        return FALSE;
    if (not nullp(S_MO_S(S_L_S(a))))
        return FALSE;
    if (not einsp(S_MO_K(S_L_S(a))))
                return FALSE;
    return TRUE;
}

/* make self koeff next monopoly */
INT m_skn_mp(OP s, OP k, OP n, OP e)
{
    INT erg=OK;
    COP("m_skn_mp(4)",e);

    if ( n == NULL) {
        erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,e);
        COPY(s,S_PO_S(e));
        COPY(k,S_PO_K(e));
    }
    else {
        erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),CALLOCOBJECT(),e);
        COPY(s,S_PO_S(e));
        COPY(k,S_PO_K(e));
        COPY(n,S_PO_N(e));
    }
    ENDR("m_skn_mp");
}


/* build self koeff next monopoly */
INT b_skn_mp(OP s, OP k, OP n, OP e)
{
    INT erg=OK;
    COP("b_skn_mp(4)",e);

    FREESELF(e);
    erg += b_sn_l(CALLOCOBJECT(),n,e);
    C_O_K(e,MONOPOLY);
    erg += b_sk_mo(s,k,S_L_S(e));
    ENDR("b_skn_mp");
}


/* tries to convert the parameter in to a MONOPOLY object */
INT cast_apply_monopoly(OP a)
{
    INT erg = OK;
    EOP("cast_apply_monopoly(1)",a); /* check if empty object */
    {
    switch (S_O_K(a))
        {
        case BRUCH:
        case INTEGER:
        case LONGINT:
        case FF:
            erg += m_skn_mp(cons_null,a,NULL,a);
            break;
	case POLYNOM:
	    NYI("cast_apply_monopoly:POLYNOM->MONOPOLY");
	    break;
        default:
            WTO("cast_apply_monopoly:can not convert",a);
            break;
        }
    }
    ENDR("cast_apply_monopoly");
}


/* a becomes a monopoly */
INT scan_monopoly(OP a)
{
    OBJECTKIND kt,st;
    INT erg = OK;
    CTO(EMPTY,"scan_monopoly(1)",a);

    erg += printeingabe("type of monopoly self ");
    st=scanobjectkind();
    erg += printeingabe("type of monopoly koeff ");
    kt=scanobjectkind();
    erg += SCMPCO(st,kt,a);

    ENDR("scan_monopoly");
}
#endif /* MONOPOLYTRUE */

/* scan_monopoly_co */
static INT SCMPCO(OBJECTKIND self_type, OBJECTKIND coeff_type, OP result)
{
    INT    ret = ERROR;
    INT    i,n;
# ifdef    MONOPOLYTRUE
    OP    x = CALLOCOBJECT(), y = CALLOCOBJECT(), z;
    char a[30];

    init(MONOPOLY,result);
    printeingabe("Length of list: ");
    scanf( "%" PRIINT ,&n);
    for (i=0L;i<n;i++)
    {
        sprintf(a, "%" PRIINT "-th monomial (self) " ,i);
        printeingabe(a);
        scan(self_type,x);
        sprintf(a, "%" PRIINT "-th monomial (koeff) " ,i);
        printeingabe(a);
        scan(coeff_type,y);
        if (nullp(y))
            continue;
        z = CALLOCOBJECT();
        m_sk_mo(x,y,z);
        insert(z,result,add_koeff,NULL);
    }
    if (empty_listp(result))
        insert_zero_into_monopoly(result);
    freeall(x);
    freeall(y);
    ret    = OK;
#else
    error("SCMPCO: MONOPOLY not available");
#endif
    return(ret);
}


# ifdef    MONOPOLYTRUE

/* Removes those terms from a MONOPOLY with zero coefficients unless
 * this makes the list empty. In this case, one term with self and
 * koeff both 0 is left.
 */
INT remove_zero_terms(OP a)
{
    OP    term, ptr = a, a_tmp;
    INT erg = OK;

    CTO(MONOPOLY,"remove_zero_terms",a);
    ptr = a; term = NULL;
again:
    if (!empty_listp(ptr))
    while (ptr != NULL)
        {
        if (not NULLP(S_PO_K(ptr)) )
            {
            term = ptr;
            ptr = S_L_N(ptr);
            }
        else {
            a_tmp = ptr;
            ptr = S_L_N(ptr);
            C_L_N(a_tmp, NULL);
            if (term == NULL)
                {
                /* first element will be removed */
                if (ptr == NULL) { M_I_I(0,S_PO_S(a)); goto ende; }
                FREESELF(a);
                *a = *ptr;
                C_O_K(ptr,EMPTY);
                FREEALL(ptr);
                ptr = a;
                goto again;
                }
            else {
                C_L_N(term,ptr);
                FREEALL(a_tmp);
                }
            }
        }

    if (empty_listp(a))
        insert_zero_into_monopoly(a);

ende:
    ENDR("remove_zero_terms");
}


/* This is used to convert an empty monopoly into a non-empty one */
static INT insert_zero_into_monopoly(OP a)
{
    OP  m = CALLOCOBJECT();
    b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m);
    M_I_I(0L,S_MO_K(m));
    M_I_I(0L,S_MO_S(m));
    insert(m,a,add_koeff,NULL);
    return(OK);
}
# endif /* MONOPOLYTRUE */

static INT integer_coefficients(OP a)
{
    OP    ptr = a;
# ifdef    MONOPOLYTRUE
    if (S_O_K(a) != MONOPOLY)
        error("integer_coefficients: parameter is not a MONOPOLY");
    if (!empty_listp(ptr))
        while (ptr != NULL)
        {
            if (S_O_K(S_PO_K(ptr)) != INTEGER && S_O_K(S_PO_K(ptr)) != LONGINT)
                return(FALSE);
            ptr    = S_L_N(ptr);
        }
#else
    error("integer_coefficients: MONOPOLY not available");
#endif
    return(TRUE);
}

# ifdef    MONOPOLYTRUE
INT add_scalar_monopoly(OP a, OP b, OP c)
{
    OP    ptr;
    INT erg = OK;
    CTO(MONOPOLY,"add_scalar_monopoly",b);
    if (c == a)
        erg += ERROR;
    if (c != b)
        copy(b,c);
    ptr    = CALLOCOBJECT();
    erg += init(MONOPOLY,ptr);
    C_L_S(ptr,CALLOCOBJECT());
    erg += m_sk_mo(cons_null,a,S_L_S(ptr));
    erg += add_apply(ptr,c);
    erg += remove_zero_terms(c);
    erg += freeall(ptr);
    ENDR("add_scalar_monopoly");
}
#endif

INT mult_apply_scalar_monopoly(OP a, OP b)
{
    INT erg = OK;
    OP z;
    CTO(MONOPOLY,"mult_apply_scalar_monopoly(2)",b);
    if (NULLP(a))
        erg += init(MONOPOLY,b);
    else {
        FORALL(z,b,{MULT_APPLY(a,S_MO_K(z)); } );
        }
    ENDR("mult_apply_scalar_monopoly");
}

INT mult_scalar_monopoly(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(ANYTYPE,"mult_scalar_monopoly(1)",a);
    CTO(MONOPOLY,"mult_scalar_monopoly(2)",b);
    CTO(EMPTY,"mult_scalar_monopoly(3)",c);
    if (NULLP(a)) {
        erg += init(MONOPOLY,c);
        }
    else {
        OP z;
        COPY(b,c);
        FORALL(z,c, { MULT_APPLY(a,S_MO_K(z)); } );
        }
    CTO(MONOPOLY,"mult_scalar_monopoly(e3)",c);
    ENDR("mult_scalar_monopoly");
}

# ifdef    MONOPOLYTRUE
INT add_monopoly_monopoly(OP a, OP b, OP c)
{
    OP temp_eins, temp_zwei;
    INT erg = OK;
    CTO(MONOPOLY,"add_monopoly_monopoly(1)",a);
    CTO(MONOPOLY,"add_monopoly_monopoly(2)",b);
    CTO(EMPTY,"add_monopoly_monopoly(3)",c);

    temp_eins = CALLOCOBJECT();
    temp_zwei = CALLOCOBJECT();
    copy(a,temp_eins);
    copy(b,temp_zwei);
    init(S_O_K(a), c);
    insert(temp_eins,c,add_koeff,NULL);
    insert(temp_zwei,c,add_koeff,NULL);
    erg += remove_zero_terms(c);
    ENDR("add_monopoly_monopoly");
}


INT mult_monopoly_monopoly(OP a, OP b, OP c)
{
    OP    new, a_ptr, b_ptr, c_tmp;
    OP    temp_eins, temp_zwei;
    INT erg = OK;
    CTO(MONOPOLY,"mult_monopoly_monopoly(1)",a);
    CTO(MONOPOLY,"mult_monopoly_monopoly(2)",b);
    CTO(EMPTY,"mult_monopoly_monopoly(3)",c);

    c_tmp    = c;

    erg += init(MONOPOLY, c_tmp);

    if (S_L_S(b) == NULL)
        goto mmm_ende;
    if (S_L_S(a) == NULL)
        goto mmm_ende;

    b_ptr = b;
    if (EMPTYP(S_PO_S(b_ptr))) /* skip the empty term */
        b_ptr = S_L_N(b_ptr);
    while (b_ptr != NULL)
    {
        a_ptr = a;
        if (EMPTYP(S_PO_S(a_ptr))) /* skip the empty term */
            a_ptr = S_L_N(a_ptr);
        while (a_ptr != NULL)
        {
            temp_eins = CALLOCOBJECT();
            temp_zwei = CALLOCOBJECT();
            ADD(S_PO_S(a_ptr), S_PO_S(b_ptr), temp_eins);
            MULT(S_PO_K(a_ptr), S_PO_K(b_ptr), temp_zwei);
            new    = CALLOCOBJECT();
            erg += b_sk_mo(temp_eins,temp_zwei,new);
            insert(new,c_tmp,add_koeff,NULL);
            a_ptr = S_L_N(a_ptr);
        }
        b_ptr = S_L_N(b_ptr);
    }
    erg += remove_zero_terms(c);
mmm_ende:
    CTO(MONOPOLY,"mult_monopoly_monopoly(e3)",c);
    ENDR("mult_monopoly_monopoly");
}
#endif /* MONOPOLYTRUE */

/*
 * This routine deals with MONOPOLYs which are effectively
 * LISTs of MONOMs whose coefficients are scalars and selfs
 * are non-negative integers -- they correspond to polynomials
 * in one variable. The quotient (qpoly) and remainder (rpoly)
 * of the division of poly by dpoly are calculated.  The
 * parameters poly,dpoly,qpoly and rpoly must all be different.
 *
 * a/b = c rest d, with monopoly = univariate polynomial.
 * (simple version, not optimized)
*/
INT quores_monopoly(OP a, OP b, OP c, OP d)
{
    INT erg = OK;
    OP degree_d,degree_b,leading_coeff_b,leading_coeff_d;
    OP h,z,ca;
    CTO(MONOPOLY,"quores_monopoly(1)",a);
    CTO(MONOPOLY,"quores_monopoly(2)",b);
    CTO(EMPTY,"quores_monopoly(3)",c);
    CTO(EMPTY,"quores_monopoly(4)",d);
    SYMCHECK(c==d,"quores_monopoly:should be different objects");

    if (NULLP(b)) error("quores_monopoly(2):null");

    if (NULLP(a))  {
		erg += copy(a,c);
		erg += copy(a,d);
		goto endr_ende;
		}

    init(MONOPOLY,c);
    COPY(a,d);

    CALLOCOBJECT6(degree_d,degree_b,leading_coeff_b,leading_coeff_d,h,ca);

    degree_monopoly(b,degree_b);
    ldcf_monopoly(b,leading_coeff_b);

again:
    CTO(MONOPOLY,"quores_monopoly(i3)",c);
    CTO(MONOPOLY,"quores_monopoly(i4)",d);
    FREESELF(degree_d);
    degree_monopoly(d,degree_d);
    if (LT(degree_d,degree_b))  goto ee; /* finished */

    /* else:
     * multiply b by leadcoeff_d/leadcoeff_b, subtract this from d
     */
    FREESELF(leading_coeff_d);
    ldcf_monopoly(d,leading_coeff_d);
    m_iindex_monopoly( S_I_I(degree_d) - S_I_I(degree_b),ca);
    div(leading_coeff_d,leading_coeff_b,h);
    copy(h,S_PO_K(ca));
    mult_apply(b,h);
    FORALL(z,h,M_I_I(S_I_I(S_MO_S(z)) + S_I_I(degree_d) - S_I_I(degree_b),
                     S_MO_S(z)));
    addinvers_apply(h);
    ADD_APPLY(h,d);
    ADD_APPLY(ca,c);
    goto again;
ee:
    FREEALL6(degree_d,degree_b,leading_coeff_b,leading_coeff_d,h,ca);
    CTO(MONOPOLY,"quores_monopoly(e3)",c);
    CTO(MONOPOLY,"quores_monopoly(e4)",d);

    ENDR("quores_monopoly");
}

#ifdef    MONOPOLYTRUE
INT add_monopoly(OP a, OP b, OP c)
{
    INT erg = OK;
    OP d;
    CTO(MONOPOLY,"add_monopoly(1)",a);
    CTO(EMPTY,"add_monopoly(3)",c);

    switch(S_O_K(b))
    {
    case INTEGER:
    case FF:
    case LONGINT:
        erg += add_scalar_monopoly(b,a,c);
        goto ee;
    case BRUCH:
        erg += add_bruch(b,a,c);
        goto ee;

    case MONOPOLY:
        erg += add_monopoly_monopoly(a,b,c);
        goto ee;
    case LAURENT:
        d = CALLOCOBJECT();
        erg += t_LAURENT_OBJ(b,d);
        erg += add(a,d,c);
        erg += freeall(d);
        goto ee;
    case POLYNOM:
        d=CALLOCOBJECT();
        erg += t_POLYNOM_MONOPOLY(b,d);
        erg += add_monopoly_monopoly(a,d,c);
        erg += freeall(d);
        goto ee;

    default:
        WTO("add_monopoly(2)",b);
        goto ee;
    }
ee:
    ENDR("add_monopoly");
}


INT mult_monopoly_polynom(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(POLYNOM,"mult_monopoly_polynom(2)",b);
    CTO(MONOPOLY,"mult_monopoly_polynom(1)",a);
    CTO(EMPTY,"mult_monopoly_polynom(3)",c);
    if(has_one_variable(b)==TRUE)
        {
        OP d;
        d=CALLOCOBJECT();
        erg += t_POLYNOM_MONOPOLY(b,d);
        erg += mult_monopoly_monopoly(a,d,c);
        FREEALL(d);
        }
    else
        erg += mult_scalar_polynom(a,b,c);
    ENDR("mult_monopoly_polynom");
}


INT mult_monopoly(OP a, OP b, OP c)
{
    OP d;
    INT erg = OK;
    CTO(MONOPOLY,"mult_monopoly(1)",a);
    CTO(ANYTYPE,"mult_monopoly(2)",b);
    CTO(EMPTY,"mult_monopoly(3)",c);

    switch(S_O_K(b))
    {
    case BRUCH:
        if (scalarp(S_B_O(b)) && scalarp(S_B_U(b)))
            erg += mult_scalar_monopoly(b,a,c);
        else
            {
            erg += copy(b,c);
            erg += mult(a,S_B_O(b),S_B_O(c));
            erg += kuerzen(c);
            }
        goto ee;
    case INTEGER:
    case FF:
    case LONGINT:
        erg += mult_scalar_monopoly(b,a,c);
        goto ee;
    case MONOPOLY:
        erg += mult_monopoly_monopoly(a,b,c);
        goto ee;
#ifdef MATRIXTRUE
    case MATRIX:
        erg += mult_scalar_matrix(a,b,c);
        goto ee;
#endif /* MATRIXTRUE */
#ifdef MONOMTRUE
    case MONOM:
        erg += mult_scalar_monom(a,b,c);
        break;
#endif /* MONOMTRUE */
#ifdef LAURENTTRUE
    case LAURENT:
        d = CALLOCOBJECT();
        erg += t_LAURENT_OBJ(b,d);
        erg += mult(a,d,c);
        erg += freeall(d);
        break;
#endif /* LAURENTTRUE */
#ifdef POLYTRUE
    case POLYNOM:
        erg += mult_monopoly_polynom(a,b,c);
        break;
#endif /* POLYTRUE */
#ifdef SCHUBERTTRUE
    case SCHUBERT: erg +=  mult_scalar_schubert(a,b,c);
            break;
#endif /* SCHUBERTTRUE */
    case VECTOR:
         erg += mult_scalar_vector(a,b,c);
        break;
    default:
        WTT("mult_monopoly",a,b);
    }

ee:
    CTO(ANYTYPE,"mult_monopoly(3)",c);
    ENDR("mult_monopoly");
}


/* a and b may be equal */
INT addinvers_monopoly(OP a, OP b)
{
    INT erg = OK;
    CTO(MONOPOLY,"addinvers_monopoly(1)",a);
    CTO(EMPTY,"addinvers_monopoly(2)",b);
    erg += mult_scalar_monopoly(cons_negeins,a,b);
    ENDR("addinvers_monopoly");
}


INT add_apply_monopoly(OP a, OP b)
{
    INT    erg = OK;
    OP    c;
    CTO(MONOPOLY,"add_apply_monopoly(1)",a);
    EOP("add_apply_monopoly(2)",b);

    c = CALLOCOBJECT();
    SWAP(c,b);
    erg +=  add_monopoly(a,c,b);
    FREEALL(c);
    ENDR("add_apply_monopoly");
}


INT mult_apply_monopoly(OP a, OP b)
{
    INT    erg = OK;
    OP    c;
    CTO(MONOPOLY,"mult_apply_monopoly(1)",a);
    EOP("mult_apply_monopoly(2)",b);

    c = CALLOCOBJECT();
    erg += mult_monopoly(a,b,c);
    erg += copy(c,b);
    erg += freeall(c);

    ENDR("mult_apply_monopoly");
}

INT addinvers_apply_monopoly(OP a)
{
    INT erg = OK;
    OP z;
    CTO(MONOPOLY,"addinvers_apply_monopoly(1)",a);
    FORALL(z,a,ADDINVERS_APPLY(S_MO_K(z)));
    ENDR("addinvers_apply_monopoly");
}
#endif /* MONOPOLYTRUE */


INT nullp_monopoly(OP a)
{
    INT erg = OK;
# ifdef    MONOPOLYTRUE
    OP ptr = a;
    CTO(MONOPOLY,"nullp_monopoly",a);

    if (empty_listp(a))
        return(TRUE);
    if (EMPTYP(S_L_S(ptr)))
        ptr = S_L_N(ptr);
    if (ptr == NULL || empty_listp(ptr))
        return(TRUE);
    if (S_L_N(ptr) != NULL)
        return(FALSE);
    if (EQ(S_PO_S(ptr),cons_null) && EQ(S_PO_K(ptr),cons_null))
        return(TRUE);
#endif
    return(FALSE);
    ENDR("nullp_monopoly");
}


INT comp_monopoly(OP a, OP b)
{
    INT erg = OK,ret;
    CTO(MONOPOLY,"comp_monopoly(1)",a);
    CTO(MONOPOLY,"comp_monopoly(2)",b);
    ret = comp_list(a,b);
    return ret;
    ENDR("comp_monopoly");
}


INT raise_power_monopoly(OP a, OP b)
{
    INT erg = OK;
    OP    ptr;
    CTTO(INTEGER,LONGINT,"raise_power_monopoly(1)",a);
    CTO(MONOPOLY,"raise_power_monopoly(2)",b);

    if (EINSP(a))  {
        }
    else if (POSP(a))
        {
        FORALL(ptr,b,{ MULT_APPLY(a,S_MO_S(ptr)); });
        }
    else {
        SYMCHECK(1,"raise_power_monopoly: exponent <= 0");
        }
    CTO(MONOPOLY,"raise_power_monopoly(e2)",b);
    ENDR("raise_power_monopoly");
}

INT scale_monopoly(OP a, OP b)
{
    OP    ptr;
# ifdef    MONOPOLYTRUE
    OP    factor = CALLOCOBJECT(), minus = CALLOCOBJECT();
    M_I_I(-1L,minus);
    ptr    = b;
    if (EMPTYP(S_PO_S(ptr)))
        ptr    = S_L_N(ptr);
    if (EQ(a,minus) == TRUE)
        while (ptr != NULL)
        {
            mod(S_PO_S(ptr),cons_zwei,factor);
            if (EQ(factor,cons_eins) == TRUE)
                mult(minus,S_PO_K(ptr),S_PO_K(ptr));
            ptr    = S_L_N(ptr);
        }
    else
        while (ptr != NULL)
        {
            hoch(a,S_PO_S(ptr),factor);
            mult(factor,S_PO_K(ptr),S_PO_K(ptr));
            ptr    = S_L_N(ptr);
        }
    freeall(factor);
    freeall(minus);
#endif
    return(OK);
}


INT objectread_monopoly(FILE *f, OP a)
{
# ifdef    MONOPOLYTRUE
    objectread_list(f,a);
    C_O_K(a,MONOPOLY);
#endif
    return(OK);
}

# ifdef    MONOPOLYTRUE
INT tex_monopoly(OP a)
{
    INT myfirst = 1L;
    OP    ptr = a;
    fprintf(texout," ");
    while (ptr != NULL)
    {
        if (!negp(S_PO_K(ptr)) && !myfirst)
            fprintf(texout," + {");
        else
            fprintf(texout,"{");
        tex(S_PO_K(ptr));
        fprintf(texout,"} x {");
        tex(S_PO_S(ptr));
        fprintf(texout,"}\n");
        ptr    = S_L_N(ptr);
        myfirst = 0L;
        texposition += 6;
    }
    fprintf(texout,"\n");
    texposition = 0;
    return(OK);
}

/*    CONSTRUCTION OF SPECIAL TYPES OF MONOPOLY    */

/*
 * Given the number n, which should be an positive INTEGER or LONGINT,
 * the result returns the polynomial x**n-1.
 */
INT m_iindex_monopoly(INT ii, OP mon)
{
    INT erg = OK;
    COP("m_iindex_monopoly",mon);
    erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,mon);
    erg += m_i_i(ii,S_PO_S(mon));
    erg += m_i_i(1L,S_PO_K(mon));
    ENDR("m_iindex_monopoly");
}

INT make_unitary0_monopoly(OP number, OP result)
{
    OP    new;
    OP    e = CALLOCOBJECT(), coeff = CALLOCOBJECT();
    init(MONOPOLY,result);
    M_I_I(0L,e); /* we use the macro, because e is empty */
    M_I_I(-1L,coeff);
    new = CALLOCOBJECT();
    m_sk_mo(e,coeff,new);
    insert(new,result,add_koeff,NULL);
    m_i_i(1L,coeff);
    new = CALLOCOBJECT();
    m_sk_mo(number,coeff,new);
    insert(new,result,add_koeff,NULL);
    freeall(e);
    freeall(coeff);
    return(OK);
}
#endif /* MONOPOLYTRUE */

/*
 * Given the number n, which should be an positive INTEGER or LONGINT,
 * the result returns the MONOPOLY x**(n-1)+x**(n-2)+...+x+1.
 */
INT make_unitary_eins_monopoly(OP number, OP result)
{
    OP    new, ptr;
    INT erg = OK;
# ifdef    MONOPOLYTRUE
    OP    e = CALLOCOBJECT(), coeff = CALLOCOBJECT();
    init(MONOPOLY,result);
    ptr    = result;
    M_I_I(0L,e);
    M_I_I(1L,coeff);
    while (LT(e,number) == TRUE)
    {
        new = CALLOCOBJECT();
        init(MONOPOLY,new);
        S_L_S(new) = CALLOCOBJECT();
        m_sk_mo(e,coeff,S_L_S(new));
        insert(new,result,NULL,NULL);
        INC(e);
    }
    freeall(e);
    freeall(coeff);
    return(OK);
#else
    return(ERROR);
#endif
}

/* Given the number n, which should be an positive INTEGER or LONGINT
 * or a MONOPOLY representing a prime factorisation of an integer greater
 * than 1 , the result returns the cyclotomic polynomial of index n.
 */
INT make_cyclotomic_monopoly(OP number, OP result)
{
    INT  ret = ERROR;
    OP   ptr;
# ifdef    MONOPOLYTRUE
    OP   minus, e, factor, poly_eins, poly_zwei, poly_drei,
         list = CALLOCOBJECT();

    if (S_O_K(number) == MONOPOLY)
        copy(number,list);
    else
    {
        if (((S_O_K(number) != INTEGER) && (S_O_K(number) != LONGINT))
            || (LT(number,cons_eins) == TRUE))
            goto exit_label;

        if (einsp(number))
        {
            make_unitary0_monopoly(number,result);
            ret    = OK;
            goto exit_label;
        }
        integer_factor(number,list);
    }
    ptr    = list;
    if (EMPTYP(S_PO_S(ptr)))
        ptr    = S_L_N(ptr);
    factor = CALLOCOBJECT();
    copy(S_PO_S(ptr),factor);

    if (S_L_N(ptr) == NULL)    /* list has just one prime factor */
    {
        make_unitary_eins_monopoly(factor,result);
        dec(S_PO_K(ptr));
        e = CALLOCOBJECT();
        integer_factors_to_integer(ptr,e);
        raise_power_monopoly(e,result);
        freeall(e);
        ret    = OK;
        freeall(factor);
        goto exit_label;
    }
    else
    {
        poly_eins = CALLOCOBJECT();
        ptr    = S_L_N(ptr);
        make_cyclotomic_monopoly(ptr,poly_eins);
        if (EQ(factor,cons_zwei) == TRUE)
        {
            minus    = CALLOCOBJECT();
            M_I_I(-1L,minus);
            scale_monopoly(minus,poly_eins);
            copy(poly_eins,result);
            freeall(minus);
        }
        else
        {
            poly_zwei = CALLOCOBJECT();
            poly_drei = CALLOCOBJECT();
            copy(poly_eins,poly_zwei);
            raise_power_monopoly(factor,poly_eins);
            quores_monopoly(poly_eins,poly_zwei,result,poly_drei);
            freeall(poly_zwei);
            freeall(poly_drei);
        }
        freeall(poly_eins);
        ret    = OK;
    }
    ptr    = list;
    if (EMPTYP(S_PO_S(ptr)))
        error("nb internal error 234");
    dec(S_PO_K(ptr));
    ptr     = S_L_N(ptr);
    while (ptr != NULL)
    {
        m_i_i(0L,S_PO_K(ptr));
        ptr    = S_L_N(ptr);
    }
    integer_factors_to_integer(list,factor);
    raise_power_monopoly(factor,result);
    freeall(factor);
exit_label:
    freeall(list);
#endif
    return(ret);
}


#ifdef    SQRADTRUE
/*    SQUARE RADICALS        */

INT make_monopoly_sqrad(OP a, OP b)
{
    INT    flag = 0L;
    INT erg = OK;
    OP    ptr, new, b_tmp, sqfree , sqpart ;

    CTO(MONOPOLY,"make_monopoly_sqrad(1)",a);
    if (b == a)
    {
        flag    = 1L;
        b_tmp    = CALLOCOBJECT();
    }
    else
    {
        init(SQ_RADICAL,b);
        b_tmp    = S_N_S(b);
    }
    sqfree = CALLOCOBJECT();
    sqpart = CALLOCOBJECT();
    init(MONOPOLY, b_tmp);
    ptr = a;
    while (ptr != NULL)
    {
        if (not nullp(S_PO_S(ptr)))
        {
            square_free_part(S_PO_S(ptr),sqfree,
                sqpart,NULL,NULL,NULL);
            MULT_APPLY(S_PO_K(ptr),sqpart);
            new     = CALLOCOBJECT();
            m_sk_mo(sqfree,sqpart,new);
            insert(new,b_tmp,add_koeff,
                comp_monomvector_monomvector);
        }
        ptr = S_L_N(ptr);
    }
    if (flag)
    {
        init(SQ_RADICAL,b);
        freeall(S_N_S(b));
        S_N_S(b)    =  b_tmp;
    }
    remove_zero_terms(S_N_S(b));
    find_sqrad_data(b);
    freeall(sqfree);
    freeall(sqpart);
    ENDR("make_monopoly_sqrad");
}
#endif /* SQRADTRUE */


#ifdef    SQRADTRUE

/* a: the scalar; b: the result.    */
INT make_scalar_sqrad(OP a, OP b)
{
    OP c;
    INT erg = OK;
    EOP("make_scalar_sqrad(1)",a);

    c    = CALLOCOBJECT();
    erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,c);
    erg += copy(a,S_PO_K(c));
    M_I_I(1L,S_PO_S(c));
    erg += make_monopoly_sqrad(c,b);
    if (not EMPTYP(S_N_D(b)))
        erg += freeself(S_N_D(b));
    erg += find_sqrad_data(b);
    erg += freeall(c);

    ENDR("make_scalar_sqrad");
}
#endif

#ifdef SQRADTRUE
INT scan_sqrad(OP a)
{
    OP c = CALLOCOBJECT();
    INT erg=OK;
    erg += printeingabe("self of sqrad");
    erg += scan(MONOPOLY,c);
    erg += make_monopoly_sqrad(c,a);
    erg += find_sqrad_data(a);
    erg += freeall(c);
    return erg;
}
#endif /* SQRADTRUE */

#ifdef SQRADTRUE
INT add_scalar_sqrad(OP a, OP b, OP c)
{
    OP    ptr;
    INT erg = OK;
    CTO(SQ_RADICAL,"add_scalar_sqrad(2)",b);
    CTO(EMPTY,"add_scalar_sqrad(3)",c);

    erg += copy(b,c);
    ptr = CALLOCOBJECT();
    erg += init(MONOPOLY,ptr);
    C_L_S(ptr,CALLOCOBJECT());
    erg += m_sk_mo(cons_eins,a,S_L_S(ptr));
    ADD_APPLY(ptr,S_N_S(c));
    erg += freeall(ptr);
    if (space_saving)
        convert_sqrad_scalar(c);

    ENDR("add_scalar_sqrad");
}


INT mult_apply_scalar_sqrad(OP a, OP b)
{
    OP c;
    INT erg = OK;
    CTO(SQ_RADICAL,"mult_apply_scalar_sqrad(2)",b);
    c = CALLOCOBJECT();
    SWAP(c,b);
    erg += mult_scalar_sqrad(a,c,b);
    FREEALL(c);
    ENDR("mult_apply_scalar_sqrad");
}


INT mult_scalar_sqrad(OP a, OP b, OP c)
{
    OP    ptr;
    INT erg = OK;
    CTO(SQ_RADICAL,"mult_scalar_sqrad(2)",b);
    CTTO(INTEGER,EMPTY,"mult_scalar_sqrad(3)",c);

    if (S_O_K(c)==INTEGER) C_O_K(c,EMPTY);

    if (space_saving && nullp(a))
    {
        COPY(a,c);
        goto endr_ende;
    }

    COPY(b,c);
    ptr = S_N_S(c);
    if (EMPTYP(S_PO_S(ptr)))
        ptr = S_L_N(ptr);
    while (ptr != NULL)
    {

        MULT_APPLY(a,S_PO_K(ptr));
        ptr = S_L_N(ptr);
    }

    remove_zero_terms(S_N_S(c));
    if (nullp_sqrad(c))
        find_sqrad_data(c);

    ENDR("mult_scalar_sqrad");
}

INT add_sqrad_sqrad(OP a, OP b, OP c)
{
    INT    flag = 0L;
    INT erg = OK;
    OP    c_tmp, data_a ,data_b;
    CTO(SQ_RADICAL,"add_sqrad_sqrad(1)",a);
    CTO(SQ_RADICAL,"add_sqrad_sqrad(2)",b);
    CTO(EMPTY,"add_sqrad_sqrad(3)",c);

    data_a = CALLOCOBJECT();
    data_b = CALLOCOBJECT();
    find_sqrad_data(a);
    find_sqrad_data(b);
    copy(S_N_D(a),data_a);
    copy(S_N_D(b),data_b);
    if (!empty_listp(data_b))
        insert(data_b,data_a,NULL,NULL);
    else
        freeall(data_b);
    if (c == a || c == b)
    {
        flag    = 1L;
        c_tmp    = CALLOCOBJECT();
    }
    else
    {
        init(SQ_RADICAL,c);
        c_tmp    = S_N_S(c);
    }
    FREESELF(c_tmp);
    erg += add_monopoly_monopoly(S_N_S(a),S_N_S(b),c_tmp);
    if (flag)
    {
        if (not EMPTYP(S_N_S(c)))
            erg += freeall(S_N_S(c));
        S_N_S(c)    = c_tmp;
    }
    if (not EMPTYP(S_N_D(c)))
        erg += freeall(S_N_D(c));
    S_N_D(c)    = data_a;
    adjust_sqrad_data(c);
    ENDR("add_sqrad_sqrad");
}

#endif /* SQRADTRUE */
INT mult_sqrad_sqrad(OP a, OP b, OP c)
{
    INT    flag = 0L;
    INT erg = OK;

    OP    a_ptr, b_ptr, c_tmp, new;
    OP    temp_eins, temp_zwei, temp_drei, data_a, data_b;
    CTO(SQ_RADICAL,"mult_sqrad_sqrad(1)",a);
    CTO(SQ_RADICAL,"mult_sqrad_sqrad(2)",b);

    find_sqrad_data(a);
    find_sqrad_data(b);
    data_a = CALLOCOBJECT();
    data_b = CALLOCOBJECT();
    COPY(S_N_D(a),data_a);
    COPY(S_N_D(b),data_b);
    if (!empty_listp(data_b))
        insert(data_b,data_a,NULL,NULL);
    else
        freeall(data_b);
    if (c == a || c == b)
    {
        flag    = 1L;
        c_tmp    = CALLOCOBJECT();
    }
    else
    {
        init(SQ_RADICAL,c);
        c_tmp    = S_N_S(c);
    }
    init(MONOPOLY,c_tmp);
    b_ptr = S_N_S(b);
    if (EMPTYP(S_PO_S(b_ptr))) /* skip the empty term */
        b_ptr = S_L_N(b_ptr);
    temp_eins = CALLOCOBJECT();
    temp_zwei = CALLOCOBJECT();
    temp_drei = CALLOCOBJECT();
    while (b_ptr != NULL)
    {
        if (not nullp(S_PO_S(b_ptr)))
        {
            a_ptr = S_N_S(a);
            while (a_ptr != NULL)
            {
                if (not nullp(S_PO_S(a_ptr)))
                {
                ggt(S_PO_S(a_ptr), S_PO_S(b_ptr), temp_eins);
                if (NEGP(S_PO_S(a_ptr)) && NEGP( S_PO_S(b_ptr) ) )
                    ADDINVERS_APPLY(temp_eins);
                ganzdiv(S_PO_S(a_ptr), temp_eins, temp_zwei);
                ganzdiv(S_PO_S(b_ptr), temp_eins, temp_drei);
                MULT_APPLY(S_PO_K(a_ptr),temp_eins);
                MULT_APPLY(S_PO_K(b_ptr),temp_eins);
                MULT_APPLY(temp_drei,temp_zwei);
                new    = CALLOCOBJECT();
                m_sk_mo(temp_zwei,temp_eins,new);
                insert(new,c_tmp,add_koeff,NULL);
                }
                a_ptr = S_L_N(a_ptr);
            }
        }
        b_ptr = S_L_N(b_ptr);
    }
    if (empty_listp(c_tmp))
        insert_zero_into_monopoly(c_tmp);
    if (flag)
    {
        init(SQ_RADICAL,c);
        freeall(S_N_S(c));
        S_N_S(c)    = c_tmp;
    }
    if (not EMPTYP(S_N_D(c)))
        freeall(S_N_D(c));
    S_N_D(c)    = data_a;
    adjust_sqrad_data(c);
    freeall(temp_eins);
    freeall(temp_zwei);
    freeall(temp_drei);
    return(OK);
    ENDR("mult_sqrad_sqrad");
}

#ifdef    SQRADTRUE
INT add_sqrad(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(SQ_RADICAL,"add_sqrad(1)",a);
    CTO(EMPTY,"add_sqrad(3)",c);

    switch(S_O_K(b))
    {
    case CYCLOTOMIC: /* SQ + CYC = CYC */
        erg += add_cyclo(b,a,c);
        break;
    case INTEGER:
    case LONGINT:
    case BRUCH:
        erg += add_scalar_sqrad(b,a,c);
        break;
    case POLYNOM:
        erg += add_scalar_polynom(a,b,c);
        break;
    case SQ_RADICAL:
        erg += add_sqrad_sqrad(a,b,c);
        break;
    case EMPTY:
        erg += copy_number(a,c);
        break;
    default:
        WTO("add_sqrad(2)",b);
        goto ende;
    };
    if (space_saving)
        convert_sqrad_scalar(c);

ende:
    ENDR("add_sqrad");
}
#endif /* SQRADDTRUE */

/* typ a ist SQ_RADICAL */
INT mult_sqrad(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(SQ_RADICAL,"mult_sqrad(1)",a);
    if (S_O_K(c)!=EMPTY) FREESELF(c);

    switch(S_O_K(b))
    {
    case INTEGER:
    case LONGINT:
    case CYCLOTOMIC:
    case BRUCH:
        erg += mult_scalar_sqrad(b,a,c);
        goto ende;;

#ifdef MATRIXTRUE
    case MATRIX:
        erg += mult_scalar_matrix(a,b,c);
        break;
#endif /* MATRIXTRUE */

#ifdef MONOMTRUE
    case MONOM:
        erg += mult_scalar_monom(a,b,c);
        break;
#endif /* MONOMTRUE */

    case SQ_RADICAL:
        erg += mult_sqrad_sqrad(a,b,c);
        break;

#ifdef POLYTRUE
    case POLYNOM:
        erg +=  mult_scalar_polynom(a,b,c);
        break;
#endif /* POLYTRUE */

#ifdef SCHUBERTTRUE
    case SCHUBERT:
        erg +=  mult_scalar_schubert(a,b,c);
        break;
#endif /* SCHUBERTTRUE */

    case VECTOR:
        erg += mult_scalar_vector(a,b,c);
        break;

    default:
        WTO("mult_sqrad(2)",b);
        break;
    }
    if (space_saving)
        convert_sqrad_scalar(c);
ende:
    ENDR("mult_sqrad");
}

#ifdef    MONOPOLYTRUE
INT addinvers_sqrad(OP a, OP b)
{
    if (S_O_K(a) != SQ_RADICAL)
        return error("addinvers_sqrad:object not sqrad");
    find_sqrad_data(a);
    mult_scalar_sqrad(cons_negeins,a,b);
    return(OK);
}
#endif /* MONOPOLYTRUE */

#ifdef    SQRADTRUE
INT invers_sqrad(OP a, OP b)
{
    INT ret = OK;
    INT flag = 0L;
    OP  b_tmp=NULL, y_tmp, new, ptr,  prime, x_tmp = CALLOCOBJECT(),
        data_length = CALLOCOBJECT(), mono_length = CALLOCOBJECT();

    if (S_O_K(a) != SQ_RADICAL)
    {
        ret    += invers(a,b);    /* try the general routine */
        goto exit_label;
    }
    ret += find_sqrad_data(a);
    if (nullp_sqrad(a))
        error("invers_sqrad: 0 has no inverse\n");
    if (b == a)
    {
        b_tmp    = CALLOCOBJECT();
        flag    = 1L;
    }
    else
        b_tmp    = b;
    ret += init(SQ_RADICAL,b_tmp);
    ret += init(MONOPOLY,S_N_S(b_tmp));
    ret += length(S_N_D(a),data_length);
    ret += length(S_N_S(a),mono_length);
    if (nullp(data_length))    /* No radicals */
    {
        ptr    = S_N_S(a);
        ret += invers(S_PO_K(ptr),x_tmp);
        new    = CALLOCOBJECT();
        ret += m_sk_mo(cons_eins,x_tmp,new);
        insert_list(new,S_N_S(b_tmp),NULL,NULL);
        goto exit_label;
    }
    else if (einsp(mono_length))    /* One radical */
    {
        ptr    = S_N_S(a);
        mult(S_PO_S(ptr),S_PO_K(ptr),x_tmp);
        invers(x_tmp,x_tmp);
        new    = CALLOCOBJECT();
        m_sk_mo(S_PO_S(ptr),x_tmp,new);
        insert_list(new,S_N_S(b_tmp),NULL,NULL);
        ret    = OK;
        goto exit_label;
    }
    /* more than one radical; the conjugate is built up in b_tmp */

    y_tmp    = CALLOCOBJECT();
    copy(a,x_tmp);
    make_scalar_sqrad(cons_eins,b_tmp);
    ptr    = S_N_D(a);
    while (ptr != NULL)
    {
        prime        = S_L_S(ptr);
        if (S_O_K(x_tmp) != SQ_RADICAL)
            make_scalar_sqrad(x_tmp,x_tmp);
        conj_sqrad(x_tmp,prime,y_tmp);
        if (comp_sqrad(x_tmp,y_tmp) != 0L)
        {
            mult_sqrad_sqrad(x_tmp,y_tmp,x_tmp);
            mult_sqrad_sqrad(b_tmp,y_tmp,b_tmp);
        }
        ptr    = S_L_N(ptr);
    }
    /* at this point x_tmp should be scalar */
    if (convert_sqrad_scalar(x_tmp) == ERROR)
    {
        freeall(y_tmp);
        error("invers_sqrad: the norm is not a scalar\n");
        goto exit_label;
    }
    if (negp(x_tmp))
    {
        ret +=  mult_apply_scalar_sqrad(cons_negeins,b_tmp);
        ret += addinvers_apply(x_tmp);
    }

    ret += invers(x_tmp,y_tmp);
    ret += mult_apply_scalar_sqrad(y_tmp,b_tmp);

    ret += freeall(y_tmp);
exit_label:
    if (flag)
    {
        copy(b_tmp,b);
        freeall(b_tmp);
    }
    freeall(x_tmp);
    freeall(data_length);
    freeall(mono_length);
    return(ret);
}


INT add_apply_sqrad(OP a, OP b)
{
    INT    erg=OK;
    OP    c = CALLOCOBJECT();
    erg += add_sqrad(a,b,c);
    erg += copy(c,b);
    erg += freeall(c);
    return erg;
}
#endif /* SQRADTRUE */


INT mult_apply_sqrad(OP a, OP b)
{
    INT    ret = ERROR;
#ifdef SQRADTRUE
    OP    c;
    c = CALLOCOBJECT();
    ret    = mult_sqrad(a,b,c);
    copy(c,b);
    freeall(c);
#endif /* SQRADTRUE */
    return(ret);
}

#ifdef SQRADTRUE
INT addinvers_apply_sqrad(OP a)
{
    INT erg = OK;
    OP b;
    CTO(SQ_RADICAL,"addinvers_apply_sqrad(1)",a);
    b = CALLOCOBJECT();
    SWAP(a,b);
    erg += addinvers_sqrad(b,a);
    FREEALL(b);
    ENDR("addinvers_apply_sqrad");
}


INT nullp_sqrad(OP a)
{
    INT erg = OK;
    OP ptr;
    CTO(SQ_RADICAL,"nullp_sqrad(1)",a);
    ptr = S_N_S(a);
    if (nullp_monopoly(ptr))
        return(TRUE);
    return(FALSE);
    ENDR("nullp_sqrad");
}


INT einsp_sqrad(OP a)
{
    INT erg = OK;
    OP ptr;
    CTO(SQ_RADICAL,"einsp_sqrad(1)",a);
    ptr  = S_N_S(a);
    if (ptr == NULL) return FALSE;
    if (S_L_S(ptr) == NULL) return FALSE;
    if (not EINSP(S_PO_S(ptr))) return FALSE;
    if (not EINSP(S_PO_K(ptr))) return FALSE;
    if (S_PO_N(ptr) != NULL) return FALSE;
    return TRUE;

    ENDR("einsp_sqrad");
}
#endif /* SQRADTRUE */

#ifdef CYCLOTRUE
INT einsp_cyclotomic(OP a)
{
    INT erg = OK;
    OP ptr;
    CTO(CYCLOTOMIC,"einsp_cyclotomic(1)",a);
    ptr  = S_N_S(a);
    if (ptr == NULL) return FALSE;
    if (S_L_S(ptr) == NULL) return FALSE;
    if (not EINSP(S_PO_S(ptr))) return FALSE;
    if (not EINSP(S_PO_K(ptr))) return FALSE;
    if (S_PO_N(ptr) != NULL) return FALSE;
    return TRUE;

    ENDR("einsp_cyclotomic");
}
#endif /*CYCLOTRUE */

INT comp_sqrad(OP a, OP b)
{
#ifdef SQRADTRUE
    return(comp_list(S_N_S(a),S_N_S(b)));
#endif /* SQRADTRUE */
}


#ifdef SQRADTRUE
static INT fprint_sqrad(FILE *f, OP a)
{
    INT myfirst = 1L, rational = 0L;
    OP    ptr;
    ptr = S_N_S(a);
    zeilenposition    += 4L;
    if (nullp_sqrad(a))
    {
        fprintf(f," 0");
        return(OK);
    }
    while (ptr != NULL)
    {
        if (zeilenposition > 60L)
        {
            zeilenposition  = 0L;
            fprintf(f,"\n");
        }
        if (einsp(S_PO_S(ptr)))
            rational    = 1L;    /* A rational term */
        else
            rational    = 0L;
        /* print the coefficient part of a term */
        if (!negp(S_PO_K(ptr)) && !myfirst)
            fprintf(f," +");
        if (negeinsp(S_PO_K(ptr)))
        {
            if (rational)
                fprintf(f," - 1");
            else
                fprintf(f," -");
        }
        else if (einsp(S_PO_K(ptr)))
        {
            if (rational)
                fprintf(f," 1");
        }
        else
        {
            fprintf(f," ");
            fprint(f,S_PO_K(ptr));
        }

        if (not rational) /* print the radical part of a term */
        {
            fprintf(f," sqr(");
            fprint(f,S_PO_S(ptr));
            fprintf(f,")");
            zeilenposition    += 6L;
        }
        ptr    = S_L_N(ptr);
        myfirst = 0L;
    }
    return(OK);
}
#endif /* SQRADTRUE */

INT tex_sqrad(OP a)
{
    INT myfirst = 1L;
# ifdef    SQRADTRUE
    OP    ptr = S_N_S(a);
    find_sqrad_data(a);
    if (nullp_sqrad(a))
    {
        fprintf(texout," 0\n");
        return(OK);
    }
    fprintf(texout," ");
    while (ptr != NULL)
    {
        if (!negp(S_PO_K(ptr)) && !myfirst)
            fprintf(texout," + {");
        else
            fprintf(texout,"{");
        tex(S_PO_K(ptr));
        if (NEQ(S_PO_S(ptr),cons_eins))
        {
            fprintf(texout,"} \\sqrt{");
            tex(S_PO_S(ptr));
        }
        fprintf(texout,"}");
        ptr    = S_L_N(ptr);
        myfirst = 0L;
    }
    fprintf(texout," ");
    return(OK);
#else
    error("tex_sqrad: SQ_RADICAL not available");
    return(ERROR);
#endif
}

static INT find_sqrad_data(OP a)
{
#ifdef    SQRADTRUE
    OP    new, num, next_num, ptr, next_ptr, data_ptr, list_ptr,
        list_copy = CALLOCOBJECT(),    prime_list = CALLOCOBJECT(),
        quo = CALLOCOBJECT(), rem = CALLOCOBJECT();

    if (S_N_D(a) == NULL)
        S_N_D(a)    = CALLOCOBJECT();
    data_ptr    = S_N_D(a);
    /* Assume the data is OK if it is a non-empty LIST */
    if (not EMPTYP(data_ptr) && S_O_K(data_ptr) == LIST
        && not empty_listp(data_ptr))
        {
        goto fsd_ende;
        }
    init(LIST,data_ptr);
    copy(S_N_S(a),list_copy);
    ptr    = list_copy;
    num    = S_PO_S(ptr);
    if (LT(num,cons_null) == TRUE)    /* negative radicals */
    {
        new    = CALLOCOBJECT();
        M_I_I(-1L,new);
        insert_list(new,data_ptr,NULL,NULL);
        while (ptr != NULL)    /* multiply negative radicals by -1 */
        {
            num    = S_PO_S(ptr);
            if (LT(num,cons_null) == TRUE)
                addinvers_apply(num);
            else
                break;
            ptr    = S_L_N(ptr);
        }
    }
    ptr    = list_copy;
    while (ptr != NULL)
    {
        num    = S_PO_S(ptr);
        if (not einsp(num) && not nullp(num))
        {
            integer_factor(num,prime_list);
            list_ptr    = prime_list;
            while (list_ptr != NULL)
            {
                new    = CALLOCOBJECT();
                copy(S_PO_S(list_ptr),new); /* new is the next prime    */
                next_ptr    = S_L_N(ptr);
                while (next_ptr != NULL)
                {
                    next_num    = S_PO_S(next_ptr);
                    if (NEQ(next_num,cons_eins) == TRUE)
                    {
                        nb_quores(next_num,new,quo,rem);
                        if (nullp(rem))
                            copy(quo,next_num);
                    }
                    next_ptr    = S_L_N(next_ptr);
                }
                insert_list(new,data_ptr,NULL,NULL);
                list_ptr    = S_L_N(list_ptr);
            }
            freeself(prime_list);
        }
        ptr    = S_L_N(ptr);
    }
fsd_ende:
    freeall(list_copy);
    freeall(prime_list);
    freeall(rem);
    freeall(quo);
    return(OK);
#else
    error("find_sqrad_data: SQ_RADICAL not available");
    return(ERROR);
#endif
}

/* a: the sqrad */
static INT adjust_sqrad_data(OP a)
{
    INT    inserted = 1L;
    INT erg = OK;

    OP    new=NULL, quo, rem, ptr, data_ptr, a_copy, prime_list, num_ptr;
    if (S_O_K(a) != SQ_RADICAL)
        return(ERROR);
    if (S_N_D(a) == NULL || EMPTYP(S_N_D(a)))
        return(find_sqrad_data(a));
    if (empty_listp(S_N_D(a)))
        return(OK);
    prime_list    = CALLOCOBJECT();
    init(LIST,prime_list);
    a_copy    = CALLOCOBJECT();
    copy(a,a_copy);
    ptr    = S_N_S(a_copy);
    num_ptr    = S_PO_S(ptr);
    if (LT(num_ptr,cons_null) == TRUE)  /* negative radicals */
    {
        new    = CALLOCOBJECT();
        M_I_I(-1L,new);
        insert_list(new,prime_list,NULL,NULL);
        while (ptr != NULL) /* multiply negative radicals by -1 */
        {
            num_ptr    = S_PO_S(ptr);
            if (LT(num_ptr,cons_null) == TRUE)
                addinvers_apply(num_ptr);
            else
                break;
            ptr    = S_L_N(ptr);
        }
    }
    data_ptr    = S_N_D(a);
    quo = CALLOCOBJECT();
    rem = CALLOCOBJECT();
    while (data_ptr != NULL)
    {
    if (negeinsp(S_L_S(data_ptr))) /* negatives have been taken care of */
        {
            data_ptr    = S_L_N(data_ptr);
            continue;
        }
        if (inserted)
            new    = CALLOCOBJECT();
        copy(S_L_S(data_ptr),new);    /* new is the next prime */
        inserted    = 0L;
        ptr    = S_N_S(a_copy);
        while (ptr != NULL)
        {
            num_ptr    = S_PO_S(ptr);
            if (einsp(num_ptr) || nullp(num_ptr))
            {
                ptr    = S_L_N(ptr);
                continue;
            }
            nb_quores(num_ptr,new,quo,rem);
            if (nullp(rem))
            {
                copy(quo,num_ptr);
                if (not inserted)
                {
                    insert(new,prime_list,NULL,NULL);
                    inserted    = 1L;
                }
            }
            ptr    = S_L_N(ptr);
        }
        data_ptr    = S_L_N(data_ptr);
    }
    if (not inserted)
        FREESELF(new);
    else
        new    = CALLOCOBJECT();
    make_monopoly_sqrad(S_N_S(a_copy),new); /* reconstitute the sqrad */
    if (convert_sqrad_scalar(new) == ERROR)
    {
        FREESELF(S_N_D(a));
        FREEALL(prime_list);
        find_sqrad_data(a);
    }
    else
    {
        FREEALL(S_N_D(a));
        S_N_D(a)    = prime_list;
    }
    FREEALL(quo);
    FREEALL(rem);
    FREEALL(new);
    FREEALL(a_copy);
    return(OK);
    ENDR("adjust_sqrad_data");
}


/* a: the sqrad; b: the radical; c: the conjugate */
INT conj_sqrad(OP a, OP b, OP c)
{
    OP    la, lb, rem, minus, ptr, new;
#ifdef    SQRADTRUE

    if (not EMPTYP(c))
        freeself(c);

    la = CALLOCOBJECT();
    lb = CALLOCOBJECT();
    rem = CALLOCOBJECT();
    minus = CALLOCOBJECT();
    M_I_I(-1L,minus);
    init(MONOPOLY,la);
    init(MONOPOLY,lb);
    ptr    = S_N_S(a);
    if (EQ(b,minus) == TRUE)
        while (ptr != NULL)
        {
            new    = CALLOCOBJECT();
            copy(S_L_S(ptr),new);
            if (LT(S_MO_S(new),cons_null) == TRUE)
                insert_list(new,lb,NULL,NULL);
            else
                insert_list(new,la,NULL,NULL);
            ptr    = S_L_N(ptr);
        }
    else
        while (ptr != NULL)
        {
            new    = CALLOCOBJECT();
            copy(S_L_S(ptr),new);
            mod(S_MO_S(new),b,rem);
            if (nullp(rem))
                insert_list(new,lb,NULL,NULL);
            else
                insert_list(new,la,NULL,NULL);
            ptr    = S_L_N(ptr);
        }
    if (empty_listp(lb))
        insert_zero_into_monopoly(lb);
    mult_apply_scalar_monopoly(minus,lb);
    insert(lb,la,NULL,NULL);
    if (c == a)
        freeall(S_N_S(a));
    else
        {
            init(SQ_RADICAL,c);
            copy(S_N_D(a),S_N_D(c));
        }
    remove_zero_terms(la);
    if (S_N_S(c) != NULL)
        {
        freeall(S_N_S(c));
        }
    S_N_S(c)    = la;
    freeall(rem);
    freeall(minus);
    return(OK);
#else /* SQRADTRUE */
    error("conj_sqrad: SQ_RADICAL not available");
    return(ERROR);
#endif /* SQRADTRUE */
}

#ifdef SQRADTRUE
INT squareroot_integer(OP a, OP b)
{
    INT erg = OK;
    OP c;
    CTTO(INTEGER,LONGINT,"squareroot_integer(1)",a);
    CTO(EMPTY,"squareroot_integer(2)",b);

    if (NULLP_INTEGER(a)) {
        M_I_I(0,b);
        goto ende;
        }

    c = CALLOCOBJECT();
    erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,c);
    COPY_INTEGER(a,S_PO_S(c));
    M_I_I(1,S_PO_K(c));
    erg += make_monopoly_sqrad(c,b);
    FREEALL(c);
ende:
    ENDR("squareroot_integer");
}


INT squareroot_longint(OP a, OP b)
{
    return squareroot_integer(a,b);
}
#endif /* SQRADTRUE */

#ifdef    SQRADTRUE
INT squareroot_bruch(OP a, OP b)
{
    INT erg=OK;
    OP  c,d;
    CTO(BRUCH,"squareroot_bruch(1)",a);
    CTO(EMPTY,"squareroot_bruch(2)",b);

    c = CALLOCOBJECT();
    d = CALLOCOBJECT();
    MULT(S_B_O(a),S_B_U(a),c);
    erg += squareroot(c,b);
    erg += invers(S_B_U(a),d);
    MULT_APPLY(d,b);
    FREEALL(c);
    FREEALL(d);
    CTO(SQ_RADICAL,"squareroot_bruch(e2)",b);
    ENDR("squareroot_bruch");
}


INT convert_sqrad_scalar(OP a)
{
    INT    ret = ERROR;
    OP tmp;
    if (S_O_K(a) != SQ_RADICAL || S_L_N(S_N_S(a)) != NULL)
        return(ret);
    tmp    = S_PO_S(S_N_S(a));
    if (not einsp(tmp) && not nullp(tmp))
        return(ret);
    ret    = OK;
    if (nullp(tmp))
    {
        m_i_i(0L,a);
        return(ret);
    }
    tmp    = CALLOCOBJECT();
    copy(S_PO_K(S_N_S(a)),tmp);
    copy(tmp,a);
    freeall(tmp);
    return OK;
}
#endif /* SQRADTRUE */

/* Convert the square root of an integer a to a cyclotomic number */
INT convert_radical_cyclo(OP a, OP b)
{
    INT    myeven, posi, last = 1L,ff=0;
    OP    new, ptr, mono_ptr;
    INT    erg = OK;
# ifdef NUMBERTRUE
    OP k,m,mpos,x,y,z,w,atmp,four;


    CTTO(INTEGER,LONGINT,"convert_radical_cyclo(1)",a);
    if (EINSP(a)) ff=1;

    k = CALLOCOBJECT();
    m = CALLOCOBJECT();
    mpos = CALLOCOBJECT();
    x = CALLOCOBJECT();
    y = CALLOCOBJECT();
    z = CALLOCOBJECT();
    w = CALLOCOBJECT();
    four = CALLOCOBJECT();

    if (not negp(a) && nb_square_root(a,k) == OK)
    {
        make_scalar_cyclo(k,b);
        goto exit_label;
    }
    if (a == b)
    {
        atmp    = CALLOCOBJECT();
        copy(a,atmp);
    }
    else
        atmp    = a;

    FREESELF(b); INIT_CYCLO(b);

    mono_ptr    = CALLOCOBJECT();
    init(MONOPOLY,mono_ptr);
    M_I_I(4L,four);
    integer_factor_1(atmp,cons_zwei,cons_zwei,m,y,NULL);
    /*    a = 4k * 2l * m
     *  l=0 ,m=1(4): return 2k * r(m)
     *    l=0 ,m=3(4): return 2(k-1) * r(4*m)
     *    l=1            return 2(k-1) * r(8*m)
     */
    ptr    = y;
    if (empty_listp(ptr)) /* a > 0 and a is odd */
    {
        myeven    = 0L;
        posi    = 1L;
    }
    else if (EQ(S_PO_S(ptr),cons_zwei)) /* a > 0 and a is even */
    {
        myeven    = 1L;
        posi    = 1L;
    }
    else
    {
        ptr    = S_L_N(ptr);
        if (ptr == NULL) /* a < 0 and a is odd */
        {
            myeven    = 0L;
            posi    = 0L;
        }
        else
        {
            myeven    = 1L;
            posi    = 0L;
        }
    }
    if (!posi)
        addinvers_apply(m);
    if (myeven)
    {
        nb_quores(S_PO_K(ptr),cons_zwei,k,z);
        if (NULLP(z)) /* a = 4k * m */
            last = 0L;
        hoch(cons_zwei,k,w); /* w = 2k */
    }
    else
    {
        copy(cons_eins,w);
        last = 0L;
    }
    if (!last)
    {
        mod(m,four,z);
        if (!EINSP(z))
        {
            div_apply(w,cons_zwei);
            MULT_APPLY(four,m);
        }
    }
    else
    {
        div_apply(w,cons_zwei); /* w := w/2 */
        MULT_APPLY(four,m);
        MULT_APPLY(cons_zwei,m);
    }
    copy(m,mpos);
    if (NEGP(mpos))
        addinvers_apply(mpos);
    make_coprimes(mpos,y);
    ptr    = y;
    while (ptr != NULL)
    {
        if (kronecker(m,S_L_S(ptr),z) == OK)
        {
            new    = CALLOCOBJECT();
            m_sk_mo(S_L_S(ptr),z,new);
            insert(new,mono_ptr,add_koeff,NULL);
        }
        ptr    = S_L_N(ptr);
    }
    remove_zero_terms(mono_ptr);
    make_index_monopoly_cyclo(mpos,mono_ptr,b,0L);
    MULT_APPLY(w,b);

    FREEALL(mono_ptr);
    if (a == b)
        FREEALL(atmp);
exit_label:
    FREEALL(k);
    FREEALL(m);
    FREEALL(mpos);
    FREEALL(x);
    FREEALL(y);
    FREEALL(z);
    FREEALL(w);
    FREEALL(four);
    erg += standardise_cyclo_0(b,basis_type);
    { /* so to get the positive squareroot */
    double realpart=0.0;
    double fac = 6.2830 / ((double) S_N_DCII(b) );
    FORALL(w,S_N_S(b), {
        realpart += (double)(S_MO_KI(w)) * cos( fac* (double)S_I_I(S_MO_S(w)) );
        });

    if (realpart < 0.0 )
    if (ff==0) ADDINVERS_APPLY(b);
    }
# endif
    CTO(ANYTYPE,"convert_radical_cyclo(e2)",b);
    ENDR("convert_radical_cyclo");
}


# ifdef NUMBERTRUE
INT convert_sqrad_cyclo(OP a, OP b)
{
    OP c, ptr;
    INT erg = OK;
    CTO(SQ_RADICAL,"convert_sqrad_cyclo(1)",a);
    CE2(a,b,convert_sqrad_cyclo);

    M_I_I(0,b);

    c    = CALLOCOBJECT();
    ptr    = S_N_S(a);
    while (ptr != NULL)
        {
        convert_radical_cyclo(S_PO_S(ptr),c);
        MULT_APPLY(S_PO_K(ptr),c);
        ADD_APPLY(c,b);
        ptr    = S_L_N(ptr);
        }

    FREEALL(c);
    ENDR("convert_sqrad_cyclo");
}
#endif /* NUMBERTRUE */

/*    CYCLOTOMIC    */

/* a : the index, b : the monopoly, c : the result    */
INT trans_index_monopoly_cyclo(OP a, OP b, OP c)
{
    return make_index_monopoly_cyclo(a,b,c,POWER_REDUCE);
}

static INT make_index_monopoly_cyclo(OP a, OP b, OP c, INT tid)
{
    OP    c_tmp;
    INT    flag = 0L;
    INT erg = OK;
    CYCLO_DATA    *c_ptr = NULL;

    if (S_O_K(b) != MONOPOLY)
        error("make_index_monopoly_cyclo: 2nd parameter is wrong type\n");
    if ((c_ptr = add_cyclo_data(a)) == (CYCLO_DATA *) NULL)
        error("make_index_monopoly_cyclo: unable to create cyclotomic data\n");
    if (c == b)
    {
        flag    = 1L;
        c_tmp    = CALLOCOBJECT();
    }
    else
    {
        FREESELF(c); INIT_CYCLO(c);
        c_tmp    = S_N_S(c);
    }
    init(MONOPOLY, c_tmp);
    if (empty_listp(c_tmp))
        insert_zero_into_monopoly(c_tmp);
    copy(b, c_tmp);
    if (flag)
    {
        init(CYCLOTOMIC,c);
        S_N_S(c)    = c_tmp;
    }
    S_N_DC(c)    = c_ptr;
    if (tid != NO_REDUCE)
        standardise_cyclo_0(c,tid);
    ENDR("make_index_monopoly_cyclo");
}


INT standardise_cyclo(OP a)
{
    return(standardise_cyclo_0(a,basis_type));
}

static INT standardise_cyclo_0(OP a, INT tid)
{
    INT    erg=OK, ret = ERROR;
    CYCLO_DATA    *c_ptr;
    OP    ptr, new, mono, e, poly_eins, poly_zwei;

    if (S_O_K(a) != CYCLOTOMIC || tid == NO_REDUCE)
        return(OK);

    ptr        = S_N_S(a);
    c_ptr    = S_N_DC(a);
    mono    = CALLOCOBJECT();
    init(MONOPOLY,mono);
    e    = CALLOCOBJECT();
    if ( not empty_listp(ptr))
        while (ptr != NULL)
        {
            erg =  mod(S_PO_S(ptr),c_ptr->index,e);
            new     = CALLOCOBJECT();
            m_sk_mo(e,S_PO_K(ptr),new);
            insert(new,mono,add_koeff,NULL);
            ptr = S_L_N(ptr);
        }
    FREEALL(e);

    if (empty_listp(mono))
        insert_zero_into_monopoly(mono);
    switch((int)tid)
    {
    case (int)POWER_REDUCE:
        poly_zwei    = mono;
        break;
    case (int)STD_BASIS:
        poly_eins    = CALLOCOBJECT();
        poly_zwei    = CALLOCOBJECT();
        quores_monopoly(mono,c_ptr->poly,poly_eins,poly_zwei);
        FREEALL(mono);
        FREEALL(poly_eins);
        break;
    default:
        return error("standardise_cyclo_0: unknown cyclotomic basis");
        break;
    }
    FREEALL(S_N_S(a));
    S_N_S(a)    = poly_zwei;
    ret    = OK;
    return(ret);
    ENDR("standardise_cyclo_0");
}

#ifdef    CYCLOTRUE
INT make_scalar_cyclo(OP a, OP b)
{
    OP c = CALLOCOBJECT();
    OP d = CALLOCOBJECT();
    M_I_I(1L,c);
    b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,d);
    copy(a,S_PO_K(d));
    M_I_I(0L,S_PO_S(d));
    make_index_monopoly_cyclo(c,d,b,NO_REDUCE);
    freeall(c);
    freeall(d);
    return(OK);
}


INT make_index_power_cyclo(OP a, OP c, OP d)
{
    return make_index_coeff_power_cyclo(a,cons_eins,c,d);
}

INT make_index_coeff_power_cyclo(OP a, OP b, OP c, OP d)
{
    INT erg = OK;
    erg += init(CYCLOTOMIC,d);
    erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,S_N_S(d));
    erg += mod(c,a,S_PO_S(S_N_S(d)));
    erg += copy(b,S_PO_K(S_N_S(d)));

    if (S_N_DC(d) != NULL)
        error("internal error:MIC1");

    S_N_DC(d)    = add_cyclo_data(a);

    if (space_saving)
        convert_cyclo_scalar(d);

    ENDR("make_index_coeff_power_cyclo");
}


INT scan_cyclo(OP a)
{
    OP b = CALLOCOBJECT();
    OP c = CALLOCOBJECT();
    INT erg = OK;
    erg += printeingabe("degree of cyclotomic field");
    erg += scan(INTEGER,b);
    erg += printeingabe("self of cyclotomic field");
    erg += scan(MONOPOLY,c);
    erg += make_index_monopoly_cyclo(b,c,a,basis_type);
    erg += freeall(b);
    erg += freeall(c);
    return erg;
}
#endif /* CYCLOTRUE */

/* a: the scalar, b: the cyclo, c: the result */
INT add_scalar_cyclo(OP a, OP b, OP c)
{
    OP  ptr;
    INT erg = OK;
#ifdef    CYCLOTRUE
    if (c == a)
        error("First and third arguments equal\n");
    if (c != b)
        copy(b,c);
    ptr    = CALLOCOBJECT();
    erg += init(MONOPOLY,ptr);
    C_L_S(ptr,CALLOCOBJECT());
    erg += m_sk_mo(cons_null,a,S_L_S(ptr));
    erg += add_apply(ptr,S_N_S(c));
    erg += freeall(ptr);
    if (space_saving)
        convert_cyclo_scalar(c);
#endif /* CYCLOTRUE */
    return erg;
}

#ifdef    CYCLOTRUE
/* a: the scalar, b: the cyclo, c: the result */
INT mult_apply_scalar_cyclo(OP a, OP b)
{
    OP c;
    INT erg = OK;
    CTO(CYCLOTOMIC,"mult_apply_scalar_cyclo",b);
    c = CALLOCOBJECT();
    SWAP(c,b);
    erg += mult_scalar_cyclo(a,c,b);
    erg += freeall(c);
    ENDR("mult_apply_scalar_cyclo");
}


INT mult_scalar_cyclo(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(CYCLOTOMIC,"mult_scalar_cyclo(2)",b);
    CTO(EMPTY,"mult_scalar_cyclo(3)",c);

    if (NULLP(a)) {
        M_I_I(0,c);
        }
    else {
        erg += init(CYCLOTOMIC,c);
        FREESELF(S_N_S(c));
        erg += mult_scalar_monopoly(a,S_N_S(b),S_N_S(c));
        S_N_DC(c)    = S_N_DC(b);
        if (space_saving)
            convert_cyclo_scalar(c);
        }
    ENDR("mult_scalar_cyclo");
}

#endif
/* a,b: the cyclos, c: the result */
INT add_cyclo_cyclo(OP a, OP b, OP c)
{
    return( add_cyclo_cyclo_0(a,b,c,basis_type) );
}

static INT add_cyclo_cyclo_0(OP a, OP b, OP c, INT tid)
{
    OP    temp_eins, temp_zwei, temp_drei, temp_vier;
    INT erg = OK;

    if (S_O_K(a) != CYCLOTOMIC || S_O_K(b) != CYCLOTOMIC)
        return( error ("add_cyclo_cyclo_0: argument not CYCLOTOMIC") );
    temp_eins = CALLOCOBJECT();
    temp_zwei = CALLOCOBJECT();
    temp_drei = CALLOCOBJECT();
    temp_vier = CALLOCOBJECT();
    copy(S_N_S(a),temp_eins);
    copy(S_N_S(b),temp_zwei);
    ggt(S_N_DCI(a),S_N_DCI(b),temp_drei);
    ganzdiv(S_N_DCI(a),temp_drei,temp_vier);
    raise_power_monopoly(temp_vier,temp_zwei);
    ganzdiv(S_N_DCI(b),temp_drei,temp_vier);
    raise_power_monopoly(temp_vier,temp_eins);
    MULT_APPLY(S_N_DCI(a),temp_vier);
    init(CYCLOTOMIC, c);
    FREESELF(S_N_S(c));
    add_monopoly_monopoly(temp_eins,temp_zwei,S_N_S(c));
    S_N_DC(c)    = add_cyclo_data(temp_vier);
    if (tid != NO_REDUCE)
        standardise_cyclo_0(c,tid);
    if (space_saving)
        convert_cyclo_scalar(c);
    FREEALL(temp_eins);
    FREEALL(temp_zwei);
    FREEALL(temp_drei);
    FREEALL(temp_vier);
    ENDR("nb.c:add_cyclo_cyclo_0");
}


INT mult_cyclo_cyclo(OP a, OP b, OP c)
{
    INT    erg = OK;
    CTO(CYCLOTOMIC,"mult_cyclo_cyclo(1)",a);
    CTO(CYCLOTOMIC,"mult_cyclo_cyclo(2)",b);
    CTO(EMPTY,"mult_cyclo_cyclo(3)",c);

    erg += mult_cyclo_cyclo_0(a,b,c,basis_type); /* AK return inserted */
    CTO(ANYTYPE,"mult_cyclo_cyclo(i3)",c);
    erg += standardise_cyclo_0(c,basis_type);
    CTO(ANYTYPE,"mult_cyclo_cyclo(e3)",c);
    ENDR("mult_cyclo_cyclo");
}


static INT mult_cyclo_cyclo_0(OP a, OP b, OP c, INT tid)
{
    OP    temp_eins, temp_zwei, temp_drei, temp_vier;
    INT erg = OK;
    CTO(CYCLOTOMIC,"mult_cyclo_cyclo_0(1)",a);
    CTO(CYCLOTOMIC,"mult_cyclo_cyclo_0(2)",b);

    if ( (NULLP(a) || NULLP(b)) && space_saving )
    {
        m_i_i(0L,c);
        return(OK);
    }
    temp_eins = CALLOCOBJECT();
    temp_zwei = CALLOCOBJECT();
    temp_drei = CALLOCOBJECT();
    temp_vier = CALLOCOBJECT();
    COPY(S_N_S(a),temp_eins);
    COPY(S_N_S(b),temp_zwei);
    ggt(S_N_DCI(a),S_N_DCI(b),temp_drei);
    ganzdiv(S_N_DCI(a),temp_drei,temp_vier);
    raise_power_monopoly(temp_vier,temp_zwei);
    ganzdiv(S_N_DCI(b),temp_drei,temp_vier);
    raise_power_monopoly(temp_vier,temp_eins);
    MULT_APPLY(S_N_DCI(a),temp_vier);
    init(CYCLOTOMIC, c);
    FREESELF(S_N_S(c));
    mult_monopoly_monopoly(temp_eins,temp_zwei,S_N_S(c));
    if ((S_N_DC(c) = add_cyclo_data(temp_vier)) == (CYCLO_DATA *) NULL)
        error("Unable to find cyclotomic data\n");
    if (tid != NO_REDUCE)
        standardise_cyclo_0(c,tid);
    if (space_saving)
        convert_cyclo_scalar(c);
    FREEALL(temp_eins);
    FREEALL(temp_zwei);
    FREEALL(temp_drei);
    FREEALL(temp_vier);
    ENDR("mult_cyclo_cyclo_0");
}


INT add_cyclo(OP a, OP b, OP c)
{
    INT erg = OK;
#ifdef    CYCLOTRUE
    switch(S_O_K(b))
    {
    case INTEGER:
    case LONGINT:
    case SQ_RADICAL:
    case BRUCH:
        erg += add_scalar_cyclo(b,a,c);
        break;
    case CYCLOTOMIC:
        erg += add_cyclo_cyclo(a,b,c);
        break;
    case POLYNOM:
        erg += add_scalar_polynom(a,b,c);
        break;
    default:
        printobjectkind(b);
        erg += error("add_cyclo: wrong second type\n");
        break;
    }
    convert_cyclo_scalar(c);
#endif
    return erg;
}


INT mult_cyclo(OP a, OP b, OP c)
{
    INT erg = OK;
    CTO(CYCLOTOMIC,"mult_cyclo(1)",a);
    CTO(EMPTY,"mult_cyclo(3)",c);

    if (NULLP(a)){
        M_I_I(0,c);
        goto ende;
    }
    if (NULLP(b)){
        M_I_I(0,c);
        goto ende;
    }
    switch(S_O_K(b))
    {
    case INTEGER:
    case SQ_RADICAL:
    case LONGINT:
    case BRUCH:
        erg += mult_scalar_cyclo(b,a,c);
        break;
#ifdef MATRIXTRUE
    case MATRIX:
        erg += mult_scalar_matrix(a,b,c);
        break;
#endif /* MATRIXTRUE */
#ifdef POLYTRUE
    case SCHUR:
    case POW_SYM:
    case HOM_SYM:
    case ELM_SYM:
    case MONOMIAL:
    case POLYNOM:
        erg += mult_scalar_polynom(a,b,c);
        break;
#endif /* POLYTRUE */
#ifdef SCHUBERTTRUE
    case SCHUBERT:
        erg +=  mult_scalar_schubert(a,b,c);
        break;
#endif /* SCHUBERTTRUE */
    case VECTOR:
        erg += mult_scalar_vector(a,b,c);
        break;
    case CYCLOTOMIC:
        erg += mult_cyclo_cyclo(a,b,c);
        break;
    default:
        WTO("mult_cyclo(2)",b);
        break;
    }
    convert_cyclo_scalar(c);
ende:
    ENDR("mult_cyclo");
}

INT addinvers_cyclo(OP a, OP b)
{
    INT erg = OK;
    CTO(CYCLOTOMIC,"addinvers_cyclo(1)",a);
    CTO(EMPTY,"addinvers_cyclo(2)",b);
    erg += mult_scalar_cyclo(cons_negeins,a,b);
    CTO(CYCLOTOMIC,"addinvers_cyclo(e2)",b);
    ENDR("addinvers_cyclo");
}

/* a: the cyclo, b: the auto, c: the conjugate */
INT conj_cyclo(OP a, OP b, OP c)
{
# ifdef    CYCLOTRUE
    if (S_O_K(a) != CYCLOTOMIC)
        return(ERROR);
    if (c != a)
        copy(a,c);
    raise_power_monopoly(b,S_N_S(c));
    standardise_cyclo_0(c,basis_type);
# endif
    return(OK);
}

/* a: the cyclo, b: the inverse */
INT invers_cyclo(OP a, OP b)
{
    INT    ret = ERROR;
# ifdef    CYCLOTRUE
    OP    c = CALLOCOBJECT();
    ret    = invers_cyclo_norm(a,b,c);
    freeall(c);
# endif
    return(ret);
}

/* a: the cyclo, b: the inverse, c: the norm */
static INT invers_cyclo_norm(OP a, OP b, OP c)
{
    INT    flag = 0L, saving = space_saving;
# ifdef    CYCLOTRUE
    OP    ptr, tmp, b_tmp;
    if (S_O_K(a) != CYCLOTOMIC)
        return(ERROR);
    if (nullp_cyclo(a))
        return(error("invers_cyclo_norm: cannot invert 0\n"));
    if (c == a || c == b)
        return(error("invers_cyclo_norm: illegal 3rd parameter\n"));
    if (b == a)
    {
        b_tmp    = CALLOCOBJECT();
        flag    = 1L;
    }
    else
    {
        if (not EMPTYP(b))
            freeself(b);
        b_tmp    = b;
    }
    space_saving    = FALSE;
    tmp    = CALLOCOBJECT();
    make_scalar_cyclo(cons_eins,b_tmp);
    ptr    = S_N_DC(a)->autos;
    ptr    = S_L_N(ptr);    /* Skip the trivial automorphism */
    while (ptr != NULL)
    {
        conj_cyclo(a,S_L_S(ptr),tmp);
        mult_cyclo_cyclo_0(tmp,b_tmp,b_tmp,POWER_REDUCE);
        ptr    = S_L_N(ptr);
    }
    mult_cyclo_cyclo_0(a,b_tmp,tmp,basis_type);
    if (convert_cyclo_scalar(tmp) == ERROR)
    {
        freeall(tmp);
        if (flag)
            freeall(b_tmp);
        return(error("invers_cyclo_norm: norm is not scalar\n"));
    }
    copy(tmp,c);
    if (negp(tmp))
    {
        mult_scalar_sqrad(cons_negeins,b_tmp,b_tmp);
        addinvers_apply(tmp);
    }
    invers(tmp,tmp);
    mult_apply_scalar_cyclo(tmp,b_tmp);
    if (flag)
    {
        copy(b_tmp,b);
        freeall(b_tmp);
    }
    freeall(tmp);
    space_saving    = saving;
# endif
    return(OK);
}


INT add_apply_cyclo(OP a, OP b)
{
    INT    erg = OK;
    OP    c;
    CTO(CYCLOTOMIC,"add_apply_cyclo(1)",a);
    c = CALLOCOBJECT();
    SWAP(c,b);
    erg += add_cyclo(a,c,b);
    FREEALL(c);
    ENDR("add_apply_cyclo");
}


INT mult_apply_cyclo(OP a, OP b)
{
    INT    ret;
#ifdef    CYCLOTRUE
    OP    c;
    c = CALLOCOBJECT();
    ret    = mult_cyclo(a,b,c);
    copy(c,b);
    freeall(c);
#endif
    return(ret);
}


INT addinvers_apply_cyclo(OP a)
{
    OP b;
    INT erg = OK;
    CTO(CYCLOTOMIC,"addinvers_apply_cyclo(1)",a);
    b = CALLOCOBJECT();
    SWAP(b,a);
    erg += addinvers_cyclo(b,a);
    FREEALL(b);
    ENDR("addinvers_apply_cyclo");
}


INT nullp_cyclo(OP a)
{
#ifdef    CYCLOTRUE
    if (S_O_K(a) != CYCLOTOMIC)
        return(ERROR);
    if (EMPTYP(S_N_S(a)))
    {
        error("nullp_cyclo: cyclo with empty self\n");
        return(TRUE);
    }
    return(nullp_monopoly(S_N_S(a)));
#else
    return(ERROR);
#endif
}
#ifdef CYCLOTRUE
INT comp_cyclo(OP a, OP b)
{
    return(comp_list(S_N_S(a),S_N_S(b)));
}
#endif /* CYCLOTRUE */


# ifdef    CYCLOTRUE
INT convert_cyclo_scalar(OP a)
{
    INT ret = ERROR;
    OP tmp;

    if (S_O_K(a) != CYCLOTOMIC || S_L_N(S_N_S(a)) != NULL)
        goto exit_label;
    tmp    = S_PO_S(S_N_S(a));
    if (not nullp(tmp))
        goto exit_label;
    tmp    = CALLOCOBJECT();
    copy(S_PO_K(S_N_S(a)),tmp);
    copy(tmp,a);
    freeall(tmp);
    ret    = OK;
exit_label:
    return(ret);
}
#endif /* CYCLOTRUE */

#ifdef    CYCLOTRUE
static INT fprint_cyclo(FILE *f, OP a)
{
    INT myfirst = 1L, flag;
    OP    ptr;

    standardise_cyclo_0(a,basis_type);
    ptr = S_N_S(a);
    zeilenposition    += 2L;
    if (nullp_cyclo(a))
    {
        fprintf(f," 0");
        return(OK);
    }
    while (ptr != NULL)
    {
        flag    = 0L;
        if (zeilenposition > 60L)
        {
            zeilenposition  = 0L;
            fprintf(f,"\n");
        }
        if (!negp(S_PO_K(ptr)) && !myfirst)
            fprintf(f," +");
        if (negeinsp(S_PO_K(ptr)))
        {
            flag    = 1L;
            fprintf(f," -");
        }
        else if (!einsp(S_PO_K(ptr)))
        {
            fprintf(f," ");
            fprint(f,S_PO_K(ptr));
        }
        else
        {
            fprintf(f," ");
            flag    = 1L;
        }

        if (not nullp(S_PO_S(ptr)))
        {
            fprintf(f," E(");
            fprint(f,S_N_DCI(a));
            fprintf(f,")");
            if (!einsp(S_PO_S(ptr)))
            {
                fprintf(f,"^");
                fprint(f,S_PO_S(ptr));
            }
            zeilenposition    += 5L;
        }
        else if (flag)
            fprintf(f," 1");
        ptr    = S_L_N(ptr);
        myfirst = 0L;
    }
    return(OK);
}
#endif /* CYCLOTRUE */

#ifdef    CYCLOTRUE
INT tex_cyclo(OP a)
{
    INT myfirst = 1L;
    OP    ptr = S_N_S(a);

    if (nullp_cyclo(a))
    {
        fprintf(texout," 0\n");
        return(OK);
    }
    fprintf(texout,"\n");
    while (ptr != NULL)
    {
        if (!negp(S_PO_K(ptr)) && !myfirst)
            fprintf(texout," + {");
        else
            fprintf(texout,"{");
        tex(S_PO_K(ptr));

        if (not nullp(S_PO_S(ptr)))
        {
            fprintf(texout,"} \\omega_{");
            tex(S_N_DCI(a));
            fprintf(texout,"} {");
            tex(S_PO_S(ptr));
        }
        fprintf(texout,"}\n");
        ptr    = S_L_N(ptr);
        myfirst = 0L;
    }
    fprintf(texout,"\n");
    return(OK);
}
#endif /* CYCLOTRUE */

# ifdef    CYCLOTRUE
/* ROUTINES RELATING TO THE MAINTENANCE OF CYCLOTOMIC DATA */

/* Reads the table of cyclos from the file CYCLOS.DAT. The first entry
 * should be no_cyclos, then the list of cyclo_data.  Returns OK if the
 * table is set; otherwise, returns ERROR.
 */
static INT setup_cyclotomic_table(char *filename)
{
    INT    i=0;
    FILE    *f;
    CYCLO_DATA    *ptr;
    char    name[50], *char_ptr;

    if (cyclo_table_set || filename == NULL)
        return(OK);
    if ((f = fopen(filename,"r")) == NULL)
    {
        printf("\nFile containing cyclo data: ");
        char_ptr    = name;
        while( (*char_ptr = fgetc(stdin)) != '\n')
        {
            if (isspace(*char_ptr)) continue;
            char_ptr++;
            i++;
            if (i > (INT)48) break;
        }
        *char_ptr = '\0';
        if (strlen(name) == 0)
            return(ERROR);
        if ((f = fopen(name,"r")) == NULL)
        {
            printf("Unable to open %s\n",name);
            return(ERROR);
        }
    }
    if ( fscanf(f, " %" PRIINT ,&zzno_cyclos) == 0 || zzno_cyclos < 1L ||
        (zzcyclo_table
        = (CYCLO_DATA *) SYM_calloc((int)zzno_cyclos,sizeof(CYCLO_DATA))
        ) == NULL
        )
    {
        zzno_cyclos    = 0L;
        printf("\nCyclo data table creation error");
        return(ERROR);
    }
    ptr    = zzcyclo_table - 1;
    for (i=0L;i<zzno_cyclos;i++)
    {
        ptr++;
        ptr->index    = CALLOCOBJECT();
        objectread(f,ptr->index);
        ptr->deg    = CALLOCOBJECT();
        objectread(f,ptr->deg);
        ptr->poly    = CALLOCOBJECT();
        objectread(f,ptr->poly);
        ptr->autos    = CALLOCOBJECT();
        objectread(f,ptr->autos);
    }
    cyclo_table_set    = 1L;
    fclose(f);
    return(OK);
}

static CYCLO_DATA *add_cyclo_data(OP index)
{
    CYCLO_DATA    *ptr = NULL;
    OP    ptr_eins, ptr_zwei=NULL;

    if ((ptr = cyclo_ptr(index)) != NULL)
        return(ptr);
    ptr    = (CYCLO_DATA *) SYM_calloc(1,sizeof(CYCLO_DATA));
    if (ptr == NULL)
        return(NULL);
    ptr->index    = CALLOCOBJECT();
    COPY(index,ptr->index);
    ptr->poly    = CALLOCOBJECT();
    if (make_cyclotomic_monopoly(index,ptr->poly) == ERROR)
    {
        SYM_free(ptr);
        return(NULL);
    }
    ptr_eins    = ptr->poly;
    while(ptr_eins != NULL)
    {
        ptr_zwei    = ptr_eins;
        ptr_eins    = S_L_N(ptr_eins);
    }
    ptr->deg    = CALLOCOBJECT();
    COPY(S_PO_S(ptr_zwei),ptr->deg);
    ptr->autos    = CALLOCOBJECT();
    make_coprimes(ptr->index,ptr->autos);
    ptr_eins    = CALLOCOBJECT();
    init(LIST,ptr_eins);
    C_L_S(ptr_eins,ptr);
    C_L_N(ptr_eins,NULL);
    if (cyclo_list_set)
        S_L_N(zzcyclo_tail)    =    ptr_eins;
    else
    {
        cyclo_list_set    = 1L;
        zzcyclo_list    = ptr_eins;
    }
    zzcyclo_tail    = ptr_eins;
    return(ptr);
}

static CYCLO_DATA* cyclo_ptr(OP index)
{
    CYCLO_DATA    *ptr = NULL;
    OP    list_ptr;
    INT    i;
    if (cyclo_table_set)
    {
        ptr    = zzcyclo_table - 1;
        for (i=0L;i<zzno_cyclos;i++)
        {
            ptr++;
            if (EQ(index,ptr->index) == TRUE)
                return(ptr);
        }
    }
    if (cyclo_list_set)
    {
        list_ptr    = zzcyclo_list;
        while (list_ptr != NULL)
        {
            ptr    = (CYCLO_DATA *) S_L_S(list_ptr);
            if (ptr == NULL)
                error("cyclo_ptr: null pointer\n");
            if (EQ(index,ptr->index) == TRUE)
                return(ptr);
            list_ptr    = S_L_N(list_ptr);
        }
    }
    return(NULL);
}


static INT free_cyclo_list(void)
{
    OP    list_ptr;
    OBJECTSELF list_self;
    CYCLO_DATA *cp;
    list_ptr = zzcyclo_list;
    while (list_ptr != NULL)
    {
        list_self    = S_O_S(list_ptr);
        cp = (CYCLO_DATA *)S_L_S(list_ptr);
        freeall(cp->index);
        freeall(cp->deg);
        freeall(cp->poly);
        freeall(cp->autos);
        SYM_free(cp);
        C_L_S(list_ptr,NULL); /* Wg speicherverwaltung */
        list_ptr    = S_L_N(list_ptr);
    }
    return(OK);
}


INT print_cyclo_data(CYCLO_DATA* ptr)
{
    printf("Index ");
    print(ptr->index);
    printf("\tDegree ");
    println(ptr->deg);
    printf("Polynomial ");
    println(ptr->poly);
    printf("Automorphism exponents ");
    println(ptr->autos);
    return OK;
}


static INT free_cyclo_table(void)
{
    CYCLO_DATA    *ptr;
    INT    i;

    if (!cyclo_table_set)
        return(ERROR);
    ptr    = zzcyclo_table;
    for (i=0L;i<zzno_cyclos;i++)
    {
        freeall(ptr->index);
        freeall(ptr->deg);
        freeall(ptr->poly);
        freeall(ptr->autos);
        ptr++;
    }
    return(OK);
}


INT print_cyclo_table(void)
{
    CYCLO_DATA    *ptr;
    INT    i;

    if (!cyclo_table_set)
        return(ERROR);
    printf( "Number of cyclo data on table: %" PRIINT "\n" ,zzno_cyclos);
    ptr    = zzcyclo_table;
    for (i=0L;i<zzno_cyclos;i++)
    {
        printf( "Table item %" PRIINT ": " ,i);
        print_cyclo_data(ptr);
        ptr++;
    }
    return(OK);
}


INT print_cyclo_list(void)
{
    OP    list_ptr;
    INT    i = 0L;

    if (!cyclo_list_set)
        return(ERROR);
    printf("Cyclo data in list:\n");
    list_ptr    = zzcyclo_list;
    while (list_ptr != NULL)
    {
        printf( "List item %" PRIINT ": " ,i++);
        print_cyclo_data((CYCLO_DATA *) S_L_S(list_ptr));
        list_ptr    = S_L_N(list_ptr);
    }
    return(OK);
}


INT save_cyclo_list(char* filename)
{
    CYCLO_DATA    *ptr;
    OP    list_ptr;
    INT    i = 0L, new = 0L;
    FILE    *f;
    char    name[50], *char_ptr;

    if (filename == NULL || (f = fopen(filename,"r+")) == NULL)
    {
        fflush(stdin);
        printf("\nFile to receive cyclo data: ");
        char_ptr    = name;
        while( (*char_ptr = fgetc(stdin)) != '\n')
        {
            if (isspace(*char_ptr)) continue;
            char_ptr++;
            i++;
            if (i > (INT)48) break;
        }
        *char_ptr    = '\0';
        if (strlen(name) == 0)
            return(ERROR);
        if ((f = fopen(name,"r+")) == NULL)
        {
            if((f = fopen(name,"w")) == NULL)
            {
                printf("Unable to open %s\n",name);
                return(ERROR);
            }
            else
                new    = 1L;
        }
    }
    else
        strcpy(name,filename);
    if (new)
    {
        fprintf(f,"              \n\n");
        printf("Initialising %s\n",name);
        i    = 0L;
    }
    else
    {
        fseek(f,0L,0);
        fscanf(f, "%" SCNINT ,&i);
        fseek(f,0L,2);
        printf("Cyclo data being appended to file %s.\n",name);
    }
    list_ptr    = zzcyclo_list;
    while (list_ptr != NULL)
    {
        ptr    = (CYCLO_DATA *) S_L_S(list_ptr);
        fprintf(f,"\n");
        objectwrite(f,ptr->index);
        objectwrite(f,ptr->deg);
        objectwrite(f,ptr->poly);
        objectwrite(f,ptr->autos);
        list_ptr    = S_L_N(list_ptr);
        i++;
    }
    fseek(f,0L,0);
    fprintf(f, "%8" PRIINT ,i);
    fclose(f);
    return(OK);
}

#endif


INT t_MONOPOLY_POLYNOM(OP a, OP b)
{
    INT erg = OK;
    CTO(MONOPOLY,"t_MONOPOLY_POLYNOM(1)",a);
    CE2(a,b,t_MONOPOLY_POLYNOM);

    {
    OP c;
    init(POLYNOM,b);
    if (S_L_S(a) != NULL) {
	    while (a != NULL)
		{
		c = CALLOCOBJECT();
		m_iindex_iexponent_monom(0,S_I_I(S_PO_S(a)),c);
		copy(S_PO_K(a),S_PO_K(c));
		insert(c,b,NULL,NULL);
		a = S_L_N(a);
		}
	}
    }

    ENDR("t_MONOPOLY_POLYNOM");
}


INT invers_monopoly(OP lau, OP res)
{
        INT erg = OK;
        CTO(MONOPOLY,"invers_monopoly(1)",lau);
        CTO(EMPTY,"invers_monopoly(2)",res);

        erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),res);
        M_I_I((INT)1,S_B_O(res));
        erg += copy(lau,S_B_U(res));
        C_B_I(res,GEKUERZT);

        ENDR("invers_monopoly");
}


/* Puts in dg the degree of the MONOPOLY object mp;
 * -1 if null
 */
INT degree_monopoly(OP mp, OP dg)
{
    OP z,za=NULL;
    INT erg = OK;
    CTO(MONOPOLY,"degree_monopoly(1)",mp);
    FREESELF(dg);

    if(NULLP(mp))
        M_I_I(-1L,dg);
    else {
        z=mp;
        while(z !=NULL) { za=z; z=S_L_N(z); }
        COPY(S_PO_S(za),dg);
        }
    ENDR("degree_monopoly");
}

/* Puts in ld the leading coefficient of the MONOPOLY object mp. */
INT ldcf_monopoly(OP mp, OP ld)
{
	INT erg=OK;
        OP z,za=NULL;
	FREESELF(ld);
	if (NULLP(mp)) error("ldcf_monopoly: null monopoly");
	else {
		z=mp;
		while(z !=NULL) { za=z; z=S_L_N(z); }
		COPY(S_PO_K(za),ld);
		}
        ENDR("ldcf_monopoly");
}


/*
 * Returns TRUE, if a is an MONOPOLY object, or is of type POLYNOM
 * with 0 or 1 variable.
 */
INT has_one_variable(OP a)
{
        OP nb;
	INT erg =OK;
        if(S_O_K(a)==MONOPOLY)
                return TRUE;
        if(S_O_K(a)==POLYNOM)
        {
                nb=CALLOCOBJECT();
                numberofvariables(a,nb);
                if(S_I_I(nb)<=1L)
                {
                        FREEALL(nb);return TRUE;
                }
                FREEALL(nb);
        }
        return FALSE;
	ENDR("has_one_variable");
}
