int sci_get_if(char *fname)
{
static int l1, m1, n1;
void *p_sci;
static int l2, m2, n2;
static int lr3, lc3;
static int minrhs=2, maxrhs=2;
static int minlhs=0, maxlhs=1;
static int err;
struct sci_var s_v;
debug_3 ("[if_sci_get] ..................... \r\n");
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
// example: pfir1
m1=1;
n1=1;
GetRhsVar(1,"p",&m1,&n1,&l1);
// example: SCI_TAPS
GetRhsVar(2, "i", &m2, &n2, &l2);
p_sci = (void *) ((unsigned long int) *stk(l1));
s_v = sci_get_ifcpp(p_sci, *istk(l2));
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_v.is_double)
{ CreateCVar(3,"d", &s_v.is_complex, &s_v.m, &s_v.n, &lr3, &lc3);
// alocated mem on scilab stack for [mxn] of (complex) double
s_v.p_re=stk(lr3);
s_v.p_im=stk(lc3);
}
else if (s_v.is_boolean)
{ CreateVar(3,"b", &s_v.m, &s_v.n, &lr3);
// alocated mem on scilab stack for [mxn] boolean
s_v.p_re=istk(lr3);
s_v.p_im=NULL;
}
else
{ lr3 = I_INT32;;
CreateVar(3,"I", &s_v.m, &s_v.n, &lr3);
// alocated mem on scilab stack for [mxn] of U_INT32
s_v.p_re=istk(lr3);
s_v.p_im=NULL;
}
// copy values
sci_pop_var(&s_v);
// remove data from heap
sci_delete_var(&s_v);
LhsVar(1) = 3; /* return var */
debug_3 ("[if_sci_get] +++++++++++++++++++++ \r\n");
return 0;
}
/*--------------------------------------------------------------------------*/
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 C2F(intehm)()
{
/*
* Extraction routine for an hypermatrix of type REAL_OR_COMPLEX, BOOLEAN
* and INTEGER (the 6 types of scilab ints)
*
* He = ehm ( v_1, v_2, ..., v_nb_iv, H )
*
*/
HyperMat H, He;
int dec, i, k, l, m, n, mn, ntot, ind_max;
int *j, ier, one = 1, zero = 0, ltot, nb_index_vectors, final_dimsize, lr, lc;
int *P, *Pe;
short int *siP, *siPe;
char *cP, *cPe;
/* CheckLhs(minlhs,maxlhs); */
if ( Rhs < 2 )
{
Scierror(999, _("%s: Wrong number of input arguments: at least %d expected.\n"), "hmops", 2);
return(0);
};
if ( ! get_hmat(Rhs, &H) )
{
Scierror(999, _("%s: Wrong type for input argument(s): An hypermatrix expected.\n"), "hmops");
return 0;
}
else if ( H.type == NOT_REAL_or_CMPLX_or_BOOL_or_INT || H.type == OLD_HYPERMAT )
{
/* do the extraction with the macro %hm_e */
Fin = -Fin;
return 0;
}
nb_index_vectors = Rhs - 1;
if ( H.dimsize < nb_index_vectors )
{
Scierror(999, _("%s: Wrong number of input arguments: at most %d expected.\n"), "hmops", H.dimsize);
return 0;
}
else if ( H.dimsize > nb_index_vectors ) /* reshape H */
{
ReshapeHMat(Rhs + 1, &H, nb_index_vectors );
dec = Rhs + 1;
}
else
{
dec = Rhs;
}
if ( H.size == 0 ) /* the hypermat is empty => return an empty matrix ? */
{
CreateVar(dec + 1, MATRIX_OF_DOUBLE_DATATYPE, &zero, &zero, &l);
LhsVar(1) = dec + 1;
PutLhsVar();
return 0;
}
ntot = 1; /* will be the nb of elts of the extracted hmat or mat */
for ( i = 1 ; i <= nb_index_vectors ; i++ )
{
ier = create_index_vector(i, dec + i, &mn, H.dims[i - 1], &ind_max);
if ( ier == 0 || ind_max > H.dims[i - 1] )
{
Scierror(999, _("%s: Bad index #%d in hypermatrix extraction. "), "hmops", i);
return 0;
}
if ( mn == 0 ) /* the vector index is [] => we return an empty matrix */
{
CreateVar(dec + i + 1, MATRIX_OF_DOUBLE_DATATYPE, &zero, &zero, &l);
LhsVar(1) = dec + i + 1;
PutLhsVar();
return 0;
}
ntot *= mn;
}
/* For the Matlab compatibility : an hypermatrix of profil n1 x ... x nj x ... x nk
* with nj > 1 and nj+1 = ... = nk = 1 becomes an hypermatrix of profil n1 x ... x nj
* Moreover, in scilab, if nj <= 2, we get in fact a matrix.
*/
final_dimsize = nb_index_vectors;
while (final_dimsize > 1 && get_length(dec + final_dimsize) == 1)
{
final_dimsize--;
}
if ( final_dimsize > 2 ) /* we create an hypermatrix for the extraction result */
{
He.dimsize = final_dimsize;
He.size = ntot;
He.it = H.it;
He.type = H.type;
CreateHMat(dec + Rhs, &He);
for ( k = 0 ; k < final_dimsize ; k++ )
{
He.dims[k] = get_length(dec + k + 1);
}
}
else /* we create a matrix for the extraction result */
{
m = get_length(dec + 1);
if (final_dimsize > 1)
{
n = get_length(dec + 2);
}
else
{
n = 1;
}
switch (H.type)
{
case (sci_matrix):
CreateCVar(dec + Rhs, MATRIX_OF_DOUBLE_DATATYPE, &(H.it), &m, &n, &lr, &lc);
He.R = stk(lr);
if ( H.it == 1 )
{
He.I = stk(lc);
}
break;
case (sci_boolean):
CreateVar(dec + Rhs, MATRIX_OF_BOOLEAN_DATATYPE, &m, &n, &lr);
He.P = (void *) istk(lr);
break;
case (sci_ints):
lr = H.it;
CreateVar(dec + Rhs, MATRIX_OF_VARIABLE_SIZE_INTEGER_DATATYPE, &m, &n, &lr);
He.P = (void *) istk(lr);
break;
}
}
/* indices computing */
ltot = 4;
CreateVar(dec + Rhs + 1, MATRIX_OF_VARIABLE_SIZE_INTEGER_DATATYPE, &ntot, &one, <ot);
j = istk(ltot);
compute_indices(dec, nb_index_vectors, H.dims, j);
/* fill the resulting hypermatrix or matrix */
switch ( H.type )
{
case (sci_matrix) :
for ( k = 0 ; k < ntot ; k++ )
{
He.R[k] = H.R[j[k]];
}
if (H.it == 1)
for ( k = 0 ; k < ntot ; k++ )
{
He.I[k] = H.I[j[k]];
}
break;
case (sci_boolean) : /* (sci_boolean stored with 4 bytes) */
Pe = (int *) He.P ;
P = (int *) H.P;
for ( k = 0 ; k < ntot ; k++ )
{
Pe[k] = P[j[k]];
}
break;
case (sci_ints) :
if ( H.it == I_INT32 || H.it == I_UINT32 )
{
Pe = (int *) He.P;
P = (int *) H.P;
for ( k = 0 ; k < ntot ; k++ )
{
Pe[k] = P[j[k]];
}
}
else if ( H.it == I_INT16 || H.it == I_UINT16 )
{
siPe = (short int *) He.P;
siP = (short int *) H.P;
for ( k = 0 ; k < ntot ; k++ )
{
siPe[k] = siP[j[k]];
}
}
else /* SCI_INT8 and SCI_UINT8 : 1 Byte int */
{
cPe = (char *) He.P;
cP = (char *) H.P;
for ( k = 0 ; k < ntot ; k++ )
{
cPe[k] = cP[j[k]];
}
}
break;
}
LhsVar(1) = dec + Rhs;
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;
}
