/* -------------------------------------------------------------------------- */
int intzgemm(char* fname)
{
int lalfa = 0, m1 = 0, n1 = 0, m = 0, n = 0, k = 0;
int mA = 0, nA = 0, lA = 0, mB = 0, nB = 0, lB = 0;
int m4 = 0, n4 = 0, lbeta = 0, mC = 0, nC = 0, lC = 0;
int minlhs = 1, minrhs = 5, maxlhs = 1, maxrhs = 5;
CheckRhs(minrhs, maxrhs) ;
CheckLhs(minlhs, maxlhs) ;
GetRhsVar(1, MATRIX_OF_COMPLEX_DATATYPE, &m1, &n1, &lalfa); /* alpha */
CheckScalar(1, m1, n1);
GetRhsVar(2, MATRIX_OF_COMPLEX_DATATYPE, &mA, &nA, &lA); /* A */
GetRhsVar(3, MATRIX_OF_COMPLEX_DATATYPE, &mB, &nB, &lB); /* B */
GetRhsVar(4, MATRIX_OF_COMPLEX_DATATYPE, &m4, &n4, &lbeta); /* betha */
CheckScalar(4, m4, n4);
GetRhsVar(5, MATRIX_OF_COMPLEX_DATATYPE, &mC, &nC, &lC); /* C */
m = mA;
n = nB;
if (nA != mB || mA != mC || nB != nC )
{
Scierror(999, "%f: invalid matrix dims\n", fname);
}
k = nA;
C2F(zgemm)("n", "n", &m , &n , &k, zstk(lalfa),
zstk(lA), &mA , zstk(lB), &mB , zstk(lbeta) , zstk(lC), &mC);
/* Return C (#5) */
LhsVar(1) = 5;
return(0);
}
/*--------------------------------------------------------------------------*/
int sci_xpause(char *fname, unsigned long fname_len)
{
int m1 = 0, n1 = 0, l1 = 0, sec = 0;
CheckLhs(0, 1);
CheckRhs(1, 1);
if (Rhs == 1)
{
GetRhsVar(1, MATRIX_OF_DOUBLE_DATATYPE, &m1, &n1, &l1);
CheckScalar(1, m1, n1);
sec = (int) * stk(l1);
if (sec <= 0)
{
Scierror(999, _("%s: Wrong values for input argument #%d: Non-negative integers expected.\n"), fname, 1);
return 0;
}
#ifdef _MSC_VER
{
int ms = (sec) / 1000; /** time is specified in milliseconds in scilab**/
if (ms > 0)
{
Sleep(ms); /* Number of milliseconds to sleep. */
}
}
#else
{
unsigned useconds;
useconds = (unsigned) sec;
if (useconds != 0)
#ifdef HAVE_USLEEP
{
usleep(useconds);
}
#else
#ifdef HAVE_SLEEP
{
sleep(useconds);
}
#endif
#endif
}
#endif
}
LhsVar(1) = 0;
PutLhsVar();
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_xarc(char *fname,unsigned long fname_len)
{
char* psubwinUID = NULL;
int m1,n1,l1,l2,l3,l4,l5,l6;
long hdl;
int curcolor = 0;
int *piCurColor = &curcolor;
double angle1 = 0.0;
double angle2 = 0.0;
CheckRhs(6,6);
GetRhsVar(1,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l1);CheckScalar(1,m1,n1);
GetRhsVar(2,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l2);CheckScalar(2,m1,n1);
GetRhsVar(3,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l3);CheckScalar(3,m1,n1);
GetRhsVar(4,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l4);CheckScalar(4,m1,n1);
GetRhsVar(5,MATRIX_OF_INTEGER_DATATYPE,&m1,&n1,&l5);CheckScalar(5,m1,n1);
GetRhsVar(6,MATRIX_OF_INTEGER_DATATYPE,&m1,&n1,&l6);CheckScalar(6,m1,n1);
angle1 = DEG2RAD(*istk(l5) / 64.0); /* convert to radian */
angle2 = DEG2RAD(*istk(l6) / 64.0);
psubwinUID = getOrCreateDefaultSubwin();
getGraphicObjectProperty(psubwinUID, __GO_LINE_COLOR__, jni_int, &piCurColor);
if ( strcmp(fname,"xarc") == 0 )
{
Objarc (&angle1,&angle2,stk(l1),stk(l2),stk(l3),stk(l4),&curcolor,NULL,FALSE,TRUE,&hdl);
}
else /* xfarc case */
{
Objarc (&angle1,&angle2,stk(l1),stk(l2),stk(l3),stk(l4),NULL,&curcolor,TRUE,FALSE,&hdl);
}
LhsVar(1)=0;
PutLhsVar();
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 sci_xtitle( char * fname, unsigned long fname_len )
{
int narg;
int nbLabels; /* number of modified labels */
int box = 0;
BOOL isBoxSpecified = FALSE;
char * psubwinUID = NULL;
static rhs_opts opts[] = { {-1,"boxed","i" ,0,0,0},
{-1,NULL ,NULL,0,0,0} };
if (Rhs <= 0)
{
sci_demo(fname, fname_len);
return 0;
}
CheckRhs(1,5);
nbLabels = Rhs;
/* get the given options from the name in opts */
if ( !get_optionals(fname,opts) )
{
/* error */
return 0;
}
/* compatibility with previous version in which box was put */
/* at the fourth position */
if ( Rhs == 4 )
{
int type = GetType(4);
if ( type == 1 || type == 8 )/* double or int */
{
int n,m;
int boxPtr = -1 ; /* pointer of box on the stack */
GetRhsVar(4,MATRIX_OF_INTEGER_DATATYPE,&m,&n,&boxPtr);
CheckScalar(4,m,n);
box = *istk( boxPtr );
nbLabels--; /* it is not a label text */
isBoxSpecified = TRUE;
}
}
if ( opts[0].position != -1 && !isBoxSpecified )
{
/* check if "box" is in the options */
box = *istk(opts[0].l) ;
if ( opts[0].m * opts[0].n != 1 )
{
/* check size */
Scierror( 999, _("%s: Wrong type for input argument: Scalar expected.\n"), fname );
return 1;
}
nbLabels--; /* it is not a label text */
}
psubwinUID = getOrCreateDefaultSubwin();
for ( narg = 1 ; narg <= nbLabels ; narg++)
{
int m,n;
char **Str;
char * modifiedLabel = NULL;
GetRhsVar(narg,MATRIX_OF_STRING_DATATYPE,&m,&n,&Str);
if ( m*n == 0 )
{
continue;
}
switch(narg)
{
case 1:
getGraphicObjectProperty(psubwinUID, __GO_TITLE__, jni_string, &modifiedLabel);
break;
case 2:
getGraphicObjectProperty(psubwinUID, __GO_X_AXIS_LABEL__, jni_string, &modifiedLabel);
break;
case 3:
getGraphicObjectProperty(psubwinUID, __GO_Y_AXIS_LABEL__, jni_string, &modifiedLabel);
break;
case 4:
getGraphicObjectProperty(psubwinUID, __GO_Z_AXIS_LABEL__, jni_string, &modifiedLabel);
break;
default:
break;
}
#if 0
startFigureDataWriting(pFigure);
#endif
sciSetText(modifiedLabel, Str, m, n);
setGraphicObjectProperty(modifiedLabel, __GO_FILL_MODE__, &box, jni_bool, 1);
#if 0
endFigureDataWriting(pFigure);
#endif
freeArrayOfString(Str,m*n);
}
setCurrentObject(psubwinUID);
#if 0
sciDrawObj(pFigure);
#endif
LhsVar(1)=0;
C2F(putlhsvar)();
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_qp_solve(char *fname, unsigned long fname_len)
{
static int un = 1, deux = 2;
// n : first dimension of Q
// nbis : second dimension of Q (nbis is expected to be equal to n)
static int Q = 0, n = 0, nbis = 0;
static int p = 0, unbis = 0;
static int C = 0, m = 0;
static int b = 0, mbis = 0;
static int me = 0, pipo = 0;
static int x = 0, iter = 0, iact = 0, nact = 0, crval = 0, ierr = 0;
int r = 0;
static int lw = 0, k = 0;
static SciSparse Sp;
static int issparse = 0;
double *work = NULL;
/* Check rhs and lhs */
CheckRhs(5, 5) ;
CheckLhs(1, 4) ;
/*Warning this interface does not support arguments passed by reference */
/* RhsVar: qp_solve(Q,p,C,b,me) */
/* 1,2,3,4,5 */
/* Variable 1 (Q) */
GetRhsVar(1, MATRIX_OF_DOUBLE_DATATYPE, &n, &nbis, &Q);
CheckSquare(1, n, nbis);
/* Variable 2 (p) */
GetRhsVar(2, MATRIX_OF_DOUBLE_DATATYPE, &nbis, &unbis, &p);
CheckLength(2, nbis * unbis, n);
/* Variable 3 (C) */
issparse = (GetType(3) == 5);
if (!issparse)
{
GetRhsVar(3, MATRIX_OF_DOUBLE_DATATYPE, &nbis, &m, &C);
}
else
{
GetRhsVar(3, SPARSE_MATRIX_DATATYPE, &nbis, &m, &Sp);
}
if ( nbis != n ) // car C est passee en transposee dans la macro qpsolve
{
Scierror(999, _("%s: Wrong size for input argument #%d: %d column(s) expected for matrix %s.\n"), fname, 3, n, "C");
return 0;
}
/* Variable 4 (b) */
GetRhsVar(4, MATRIX_OF_DOUBLE_DATATYPE, &mbis, &unbis, &b);
CheckLength(4, mbis * unbis, m);
/* Variable 5 (me) */
GetRhsVar(5, MATRIX_OF_INTEGER_DATATYPE, &pipo, &unbis, &me);
CheckScalar(5, pipo, unbis);
if ((*istk(me) < 0) || (*istk(me) > n))
{
Scierror(999, _("%s: Wrong value for input argument #%d: %s must be an integer in the range 0 to %d.\n"), fname, 5, "me", n);
return 0;
}
/* Lhs variables: x, iact, iter, crval */
CreateVar(Rhs + 1, MATRIX_OF_DOUBLE_DATATYPE, &n, &un, &x);
CreateVar(Rhs + 2, MATRIX_OF_INTEGER_DATATYPE, &m, &un, &iact);
CreateVar(Rhs + 3, MATRIX_OF_INTEGER_DATATYPE, &deux, &un, &iter);
CreateVar(Rhs + 4, MATRIX_OF_DOUBLE_DATATYPE, &un, &un, &crval);
r = Min(n, m);
lw = 2 * n + r * (r + 5) / 2 + 2 * m + 1;
if ((work = (double *)MALLOC(lw * sizeof(double))) == NULL)
{
Scierror(999, _("%s: Cannot allocate more memory.\n"), fname);
}
/* change the sign of C and b.*/
ierr = 0;
if (!issparse)
{
/* linear constraints matrix is stored full */
C2F(qpgen2)(stk(Q), stk(p), &n, &n, stk(x), stk(crval), stk(C),
stk(b), &n, &m, istk(me), istk(iact), &nact, istk(iter), work,
&ierr);
}
else
{
/* linear constraints matrix is a sparse matrix */
/* Change the linear constraints matrix representation:
qpgen1sci requires column-compressed sparse matrix internal
representation while Scilab sparse matrices are row-compressed */
double *R = NULL, *I = NULL;
int *ind = NULL;
if ((R = (double *)MALLOC(Sp.nel * sizeof(double))) == NULL)
{
FREE(work);
work = NULL;
Scierror(999, _("%s: Cannot allocate more memory.\n"), fname);
}
if ((ind = (int *)MALLOC((m + Sp.nel) * sizeof(int))) == NULL)
{
FREE(work);
work = NULL;
FREE(R);
R = NULL;
Scierror(999, _("%s: Cannot allocate more memory.\n"), fname);
}
// Transpose the sparse matrix A
C2F(spt)(&n, &m, &(Sp.nel) , &(Sp.it), (int *)work,
Sp.R, Sp.I, Sp.mnel, Sp.icol, R, I, ind, ind + m);
C2F(qpgen1sci)(stk(Q), stk(p), &n, &n, stk(x), stk(crval),
ind, ind + m, R,
stk(b), &m, istk(me), istk(iact), &nact, istk(iter),
work, &ierr);
FREE(work);
work = NULL;
FREE(R);
R = NULL;
FREE(ind);
ind = NULL;
}
for (k = nact; k < m; k++) istk(iact)[k] = 0;
/* LhsVar: [x, iact, iter, f] = qp_solve(...) */
if (ierr == 0)
{
for (k = 0; k < Lhs; k++) LhsVar(1 + k) = Rhs + 1 + k;
PutLhsVar();
}
else if (ierr == 1)
{
Scierror(999, _("%s: The minimization problem has no solution.\n"), fname);
}
else if (ierr == 2)
{
Scierror(999, _("%s: Q is not symmetric positive definite.\n"), fname);
}
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_xrect( char *fname, unsigned long fname_len )
{
long hdl = 0;
int m1 = 0,n1 = 0,l1 = 0,m2 = 0,n2 = 0,l2 = 0,m3 = 0,n3 = 0,l3 = 0,m4 = 0,n4 = 0,l4 = 0;
char* psubwinUID = NULL;
int foreground = 0;
int *piForeground = &foreground;
CheckRhs(1,4);
psubwinUID = (char*)getOrCreateDefaultSubwin();
switch( Rhs )
{
case 1 :
GetRhsVar(1,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l1);
CheckLength(1,m1*n1,4);
getGraphicObjectProperty(psubwinUID, __GO_LINE_COLOR__, jni_int, (void**)&piForeground);
if (strcmp(fname,"xrect")==0)
{
Objrect (stk(l1),stk(l1+1),stk(l1+2),stk(l1+3),
&foreground,NULL,FALSE,TRUE,&hdl);
}
else
{ /* xfrect case */
Objrect (stk(l1),stk(l1+1),stk(l1+2),stk(l1+3),
NULL,&foreground,TRUE,FALSE,&hdl);
}
if ( hdl < 0 )
{
break;
}
break;
case 4 :
getGraphicObjectProperty(psubwinUID, __GO_LINE_COLOR__, jni_int, (void**)&piForeground);
GetRhsVar(1,MATRIX_OF_DOUBLE_DATATYPE,&m1,&n1,&l1); CheckScalar(1,m1,n1);
GetRhsVar(2,MATRIX_OF_DOUBLE_DATATYPE,&m2,&n2,&l2); CheckScalar(2,m2,n2);
GetRhsVar(3,MATRIX_OF_DOUBLE_DATATYPE,&m3,&n3,&l3); CheckScalar(3,m3,n3);
GetRhsVar(4,MATRIX_OF_DOUBLE_DATATYPE,&m4,&n4,&l4); CheckScalar(4,m4,n4);
if (strcmp(fname,"xrect")==0)
{
Objrect (stk(l1),stk(l2),stk(l3),stk(l4),
&foreground,NULL,FALSE,TRUE,&hdl);
}
else
{
Objrect (stk(l1),stk(l2),stk(l3),stk(l4),
NULL,&foreground,TRUE,FALSE,&hdl);
}
if ( hdl < 0 )
{
break;
}
break;
default :
Scierror(999,_("%s: Wrong number of input argument(s): %d or %d expected.\n"),fname, 1,4);
break ;
}
if ( hdl > 0 )
{
setGraphicObjectRelationship(psubwinUID, getObjectFromHandle(hdl));
LhsVar(1)=0;
PutLhsVar();
}
return 0;
}