/*--------------------------------------------------------------------------*/
int C2F(intbdiagr)(char *fname, long unsigned int fname_len)
{
int ix1, ix2;
double dx1;
int fail;
double rMax;
int ix, j, k, m, n;
double t;
int nbloc, lrMax;
int m1, n1, la, le, lj, it;
int lw, lx ;
int lai, lib, lbs, lxi, lxr;
CheckRhs(1, 2);
CheckLhs(1, 3);
GetRhsCVar(1, MATRIX_OF_DOUBLE_DATATYPE, &it, &m, &n, &la, &lai);
CheckSquare(1, m, n);
if (n == 0)
{
CreateVar(2, MATRIX_OF_DOUBLE_DATATYPE, &cx0, &cx0, &lx);
CreateVar(3, MATRIX_OF_DOUBLE_DATATYPE, &cx0, &cx0, &lbs);
LhsVar(1) = 1;
LhsVar(2) = 2;
LhsVar(3) = 3;
return 0;
}
ix1 = (it + 1) * m * n;
if (C2F(vfinite)(&ix1, stk(la )) == 0)
{
Err = 1;
SciError(264);
return 0;
}
if (Rhs == 2)
{
GetRhsVar(2, MATRIX_OF_DOUBLE_DATATYPE, &n1, &m1, &lrMax);
CheckScalar(2, n1, m1);
rMax = *stk(lrMax );
}
else
{
rMax = 1.;
lj = la - 1;
ix1 = n;
for (j = 1; j <= ix1; ++j)
{
t = 0.;
ix2 = n;
for (ix = 1; ix <= ix2; ++ix)
{
t += (dx1 = *stk(lj + ix ), Abs(dx1));
}
if (t > rMax)
{
rMax = t;
}
lj += n;
}
}
CreateCVar(2, MATRIX_OF_DOUBLE_DATATYPE, &it, &n, &n, &lxr, &lxi);
ix1 = n << 1;
CreateVar(3, MATRIX_OF_DOUBLE_DATATYPE, &cx1, &ix1, &le);
CreateVar(4, MATRIX_OF_INTEGER_DATATYPE, &cx1, &n, &lib);
CreateVar(5, MATRIX_OF_DOUBLE_DATATYPE, &cx1, &n, &lw);
if (it == 0)
{
/* subroutine bdiag(lda,n,a,epsshr,rMax,er,ei,bs,x,xi,scale,job,fail) */
C2F(bdiag)(&n, &n, stk(la ), &c_b40, &rMax, stk(le ), stk(le + n ),
istk(lib ), stk(lxr ), stk(lxi ), stk(lw ), &cx0, &fail);
}
else
{
C2F(wbdiag)(&n, &n, stk(la ), stk(la + n * n ), &rMax, stk(le ),
stk(le + n ), istk(lib ), stk(lxr ), stk(lxi ), &t, &t, stk(lw ), &cx0, &fail);
}
if (fail)
{
Scierror(24, _("%s: Non convergence in QR steps.\n"), fname);
return 0;
}
if (Lhs == 3)
{
nbloc = 0;
for (k = 1; k <= n; ++k)
if (*istk(lib + k - 2 + 1) >= 0)
{
++nbloc;
}
CreateVar(6, MATRIX_OF_DOUBLE_DATATYPE, &nbloc, &cx1, &lbs);
ix = 0;
for (k = 1; k <= n; ++k)
{
if (*istk(lib + k - 2 + 1) >= 0)
{
*stk(lbs + ix ) = (double) * istk(lib + k - 2 + 1);
++ix;
}
}
}
LhsVar(1) = 1;
LhsVar(2) = 2;
LhsVar(3) = 6;
return 0;
} /* intbdiagr_ */
int sci_set_if(char *fname)
{
static int l1, m1, n1;
void *p_sci;
static int l2, m2, n2;
static int lr3, lc3, it3, m3, n3;
static int minrhs=3, maxrhs=3;
static int err;
struct sci_var s_v;
SciIntMat M1;
sci_types sci_var_type;
debug_3 ("[if_sci_set] ..................... \r\n");
CheckRhs(minrhs,maxrhs);
// example: pfir1
/* see C:\Program Files\scicoslab-44b7\examples\interface-tour-so\ex10intc.c */
m1=1;
n1=1;
GetRhsVar(1,"p",&m1,&n1,&l1);
// example: SCI_TAPS
GetRhsVar(2, "i", &m2, &n2, &l2); // this is an enum
// example: c0
sci_var_type=GetType(3);
switch(sci_var_type)
{
case sci_matrix: // "1 - A matrix of doubles\n"
GetRhsCVar(3, "d", &it3, &m3, &n3, &lr3, &lc3);
s_v.is_complex=it3;
s_v.is_double=1;
s_v.is_boolean=0;
s_v.p_re=stk(lr3);
s_v.p_im=stk(lc3);
s_v.m=m3;
s_v.n=n3;
s_v.p_var=NULL;
break;
case sci_boolean: // "4 - A matrix of booleans\n";
GetRhsVar(3, "b", &m3, &n3, &lr3);
s_v.is_complex=0;
s_v.is_double=0;
s_v.is_boolean=1;
s_v.p_re=istk(lr3);
s_v.p_im=NULL;
s_v.m=m3;
s_v.n=n3;
s_v.p_var=NULL;
break;
case sci_ints: // "8 - A matrix of integers\n - 32bit nothing else";
// This is coded as in an example: modnum_422\ intmodnum_lib.c\ int intspread_c(char *fname)
GetRhsVar(3, "I", &m3, &n3, &M1);
// check the type of int (M1.it==I_INT32 | M1.it==I_UINT32) - only INT32 is supported by ivec
s_v.is_complex=0;
s_v.is_double=0;
s_v.is_boolean=0;
s_v.p_re=M1.D;
s_v.p_im=NULL;
s_v.m=m3;
s_v.n=n3;
s_v.p_var=NULL;
break;
default:
Scierror(999,"Unsupported argument type %s failed err=", fname, -1);
break;
}
/* see C:\Program Files\scicoslab-44b7\examples\interface-tour-so\ex10intc.c */
p_sci = (void *) ((unsigned long int) *stk(l1));
sci_set_ifcpp(p_sci,*istk(l2), &s_v); //
if (sci_err) {
sciprint("\n%s:\n info:%d\n",sci_err_msg,sci_info);
Scierror(999,"%s failed err=%d", fname, sci_err);
return 0;
}
debug_3 ("[if_sci_set] +++++++++++++++++++++ \r\n");
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_legendre(char *fname,unsigned long fname_len)
{
/*
* Interface onto the (Slatec) dxleg.f code.
* Scilab calling sequence :
*
* p = legendre(n, m, x [, norm_flag] )
*
* x is a vector with mnx elements (it is better to
* have a row vector but this is not forced)
*
* n : a non negative int scalar (or a vector of such
* int regularly speced with an increment of 1)
* m : same constraints than for n
*
* n and m may not be both vectors
*
* norm_flag : optionnal. When it is present and equal to "norm"
* it is a normalised version which is computed
* AUTHOR
* Bruno Pincon <*****@*****.**>
*/
int it = 0, lc = 0, mM = 0, nM = 0, lM = 0, m1 = 0, m2 = 0, mN = 0, nN = 0;
int lN = 0, n1 = 0, n2 = 0, mx = 0, nx = 0, lx = 0, mnx = 0, ms = 0, ns = 0, ls = 0;
int M_is_scalar = 0, N_is_scalar = 0, normalised = 0, MNp1 = 0, lpqa = 0, lipqa = 0, *ipqa = NULL;
double *x = NULL, xx = 0., dnu1 = 0., *pqa = NULL;
int id = 0, ierror = 0, i = 0, j = 0, nudiff = 0;
CheckLhs(1, 1);
CheckRhs(3, 4);
GetRhsVar(1, MATRIX_OF_DOUBLE_DATATYPE, &mN, &nN, &lN);
if ( ! verify_cstr(stk(lN), mN*nN, &n1, &n2) )
{
Scierror(999,_("%s: Wrong type for first input argument.\n"), fname);
return 0;
};
if ( mN == 1 && nN == 1) N_is_scalar = 1;
GetRhsVar(2,MATRIX_OF_DOUBLE_DATATYPE, &mM, &nM, &lM);
if ( ! verify_cstr(stk(lM), mM*nM, &m1, &m2) )
{
Scierror(999,_("%s: Wrong type for input argument #%d.\n"), fname,2);
return 0;
}
if ( mM == 1 && nM == 1) M_is_scalar = 1;
if ( ! M_is_scalar && ! N_is_scalar )
{
Scierror(999,_("%s: Only one of arg1 and arg2 may be a vector.\n"), fname);
return 0;
};
GetRhsCVar(3,MATRIX_OF_DOUBLE_DATATYPE, &it, &mx, &nx, &lx, &lc);
if ( it != 0 )
{
Scierror(999,_("%s: Wrong type for input argument #%d: Real matrix expected.\n"), fname, 3);
return 0;
};
mnx = mx*nx;
x = stk(lx);
for ( i = 0 ; i < mnx ; i++ )
if ( ! (fabs(x[i]) < 1.0) )
{
Scierror(999,_("%s: Wrong value for input argument #%d: Matrix with elements in (%d,%d) expected.\n"), fname,3,-1,1);
return 0;
};
if ( Rhs == 4 )
{
GetRhsVar(4,STRING_DATATYPE, &ms, &ns, &ls);
if ( strcmp(cstk(ls),"norm") == 0)
{
normalised = 1;
}
else
{
normalised = 0;
}
}
else
{
normalised = 0;
}
MNp1 = Max (n2 - n1, m2 - m1) + 1;
CreateVar(Rhs+1, MATRIX_OF_DOUBLE_DATATYPE, &MNp1, &mnx, &lpqa);
pqa = stk(lpqa);
CreateVar(Rhs+2, MATRIX_OF_INTEGER_DATATYPE, &MNp1, &mnx, &lipqa);
ipqa = istk(lipqa);
if ( normalised )
{
id = 4;
}
else
{
id = 3;
}
nudiff = n2 - n1;
dnu1 = (double) n1;
for ( i = 0 ; i < mnx ; i++ )
{
xx = fabs(x[i]); /* dxleg computes only for x in [0,1) */
F2C(dxlegf) (&dnu1, &nudiff, &m1, &m2, &xx, &id,
stk(lpqa+i*MNp1), istk(lipqa+i*MNp1), &ierror);
if ( ierror != 0 )
{
if ( ierror == 207 ) /* @TODO what is 207 ? */
{
Scierror(999,_("%s: overflow or underflow of an extended range number\n"), fname);
}
else
{
Scierror(999,_("%s: error number %d\n"), fname, ierror);
}
return 0;
};
}
/* dxlegf returns the result under a form (pqa,ipqa) (to
* compute internaly with an extended exponent range)
* When the "exponent" part (ipqa) is 0 then the number is exactly
* given by pqa else it leads to an overflow or an underflow.
*/
for ( i = 0 ; i < mnx*MNp1 ; i++ )
{
if ( ipqa[i] < 0 )
{
pqa[i] = 0.0;
}
if ( ipqa[i] > 0 )
{
pqa[i] = pqa[i] * return_an_inf(); /* pqa[i] * Inf to have the sign */
}
}
/* complete the result by odd/even symmetry for negative x */
for ( i = 0 ; i < mnx ; i++ )
{
if ( x[i] < 0.0 )
{
if ( (n1+m1) % 2 == 1 )
{
for ( j = 0 ; j < MNp1 ; j+=2 )
{
pqa[i*MNp1 + j] = -pqa[i*MNp1 + j];
}
}
else
{
for ( j = 1 ; j < MNp1 ; j+=2 )
{
pqa[i*MNp1 + j] = -pqa[i*MNp1 + j];
}
}
}
}
LhsVar(1) = Rhs + 1;
PutLhsVar();
return 0;
}
int sci_proc_if(char *fname)
{
static int l1, m1, n1;
void *p_sci;
static int l2, m2, n2;
static int lr3, lc3, it3, m3, n3;
static int lr4, lc4;
static int minrhs=3, maxrhs=3;
static int minlhs=1, maxlhs=1;
static int err=0;
struct sci_var s_ce;
struct sci_var s_x;
struct sci_var s_y;
SciIntMat M1;
sci_types sci_var_type;
debug_3 ("[sci_proc_if] ..................... \r\n");
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
// Example:pfir1
m1=1;
n1=1;
GetRhsVar(1,"p",&m1,&n1,&l1);
// Example:ce - boolean
GetRhsVar(2, "b", &m2, &n2, &l2);
s_ce.is_complex=0;
s_ce.is_double=0;
s_ce.is_boolean=1;
s_ce.p_re=istk(l2);
s_ce.p_im=NULL;
s_ce.m=m2;
s_ce.n=n2;
s_ce.p_var=NULL;
// Example:x
sci_var_type=GetType(3);
switch(sci_var_type)
{
case sci_matrix: // "1 - A matrix of doubles\n"
GetRhsCVar(3, "d", &it3, &m3, &n3, &lr3, &lc3);
s_x.is_complex=it3;
s_x.is_double=1;
s_x.is_boolean=0;
s_x.p_re=stk(lr3);
s_x.p_im=stk(lc3);
s_x.m=m3;
s_x.n=n3;
s_x.p_var=NULL;
break;
case sci_boolean: // "4 - A matrix of booleans\n";
GetRhsVar(3, "b", &m3, &n3, &lr3);
s_x.is_complex=0;
s_x.is_double=0;
s_x.is_boolean=1;
s_x.p_re=istk(lr3);
s_x.p_im=NULL;
s_x.m=m3;
s_x.n=n3;
s_x.p_var=NULL;
break;
case sci_ints: // "8 - A matrix of integers\n - 32bit nothing else";
// This is coded as in an example: modnum_422\ intmodnum_lib.c\ int intspread_c(char *fname)
GetRhsVar(3, "I", &m3, &n3, &M1);
// check the type of int (M1.it==I_INT32 | M1.it==I_UINT32)
s_x.is_complex = 0;
s_x.is_double = 0;
s_x.is_boolean = 0;
s_x.p_re = M1.D;
s_x.p_im = NULL;
s_x.m = m3;
s_x.n = n3;
s_x.p_var = NULL;
break;
default:
Scierror(999,"Unsupported argument type %s failed err=", fname, -1);
break;
}
p_sci = (void *) ((unsigned long int) *stk(l1));
s_y = sci_proc_ifcpp(p_sci, &s_ce, &s_x );
if (sci_err) {
sciprint("\n%s:\n info:%d\n",sci_err_msg,sci_info);
Scierror(999,"%s failed err=%d", fname, sci_err);
return 0;
}
// now when m3,n3 are set - create [mxn] sci variable on stack (it=is_complex)
if (s_y.is_double)
{ CreateCVar(4,"d", &s_y.is_complex, &s_y.m, &s_y.n, &lr4, &lc4);
// alocated mem on scilab stack for [mxn] of (complex) double
s_y.p_re = stk(lr4);
s_y.p_im = stk(lc4);
}
else if (s_y.is_boolean)
{ CreateVar(4,"b", &s_y.m, &s_y.n, &lr4);
// alocated mem on scilab stack for [mxn] boolean
s_y.p_re = istk(lr4);
s_y.p_im = NULL;
}
else
{ lr4 = I_INT32;
CreateVar(4,"I", &s_y.m, &s_y.n, &lr4);
// alocated mem on scilab stack for [mxn] I_INT32;
s_y.p_re = istk(lr4);
s_y.p_im = NULL;
}
// copy values
sci_pop_var(&s_y);
// remove data from heap
sci_delete_var(&s_y);
LhsVar(1) = 4; /* return var */
debug_3 ("[sci_proc_if] +++++++++++++++++++++ \r\n");
return 0;
}