void GetMATRIX(FILE *f, VARPTR var, int flag)
{
GetCom(f, var, flag);
/** str1 was set by GetCom */
CheckSquare(f, var, str1, str2);
Check(f, var, 0);
Check(f, var, 1);
}
void GetIMATRIX(FILE *f, VARPTR var, int flag)
{
static char C[] = "GetRhsCVar(%s,\"%s\",&it%d,&m%d,&n%d,&lr%d,&lc%d);\n";
static char LC[] = "GetListRhsCVar(%s,%d,\"%s\",&it%s,&m%s,&n%s,&lr%s,&lc%s,&lar%s,&lac%s);\n";
int i1 = var->stack_position;
if ( flag == 1 )
{
sprintf(str2, "k");
}
else
{
sprintf(str2, "%d", i1);
}
if (var->list_el == 0 )
{
/** A scilab matrix argument **/
sprintf(str1, "%d", i1);
Fprintf(f, indent, C, str2, SGetForTypeAbrev(var),
i1, i1, i1, i1, i1);
/* Adding the calling sequence in the for_names */
ChangeForName2(var, "%s(lr%s),%s(lc%s),&it%s",
SGetForTypeStack(var), str1,
SGetForTypeStack(var), str1, str1);
}
else
{
/** A scilab matrix argument inside a list **/
sprintf(str1, "%de%d", i1, var->list_el);
AddDeclare1(DEC_INT, "lar%s", str1);
AddDeclare1(DEC_INT, "lac%s", str1);
Fprintf(f, indent, LC, str2, var->list_el, SGetForTypeAbrev(var),
str1, str1, str1, str1, str1, str1, str1);
/* Adding the calling sequence in the for_names */
ChangeForName2(var, "%s(lr%s),%s(lc%s),&it%s",
SGetForTypeStack(var), str1,
SGetForTypeStack(var), str1, str1);
}
AddDeclare1(DEC_INT, "m%s", str1);
AddDeclare1(DEC_INT, "n%s", str1);
AddDeclare1(DEC_INT, "lr%s", str1);
AddDeclare1(DEC_INT, "lc%s", str1);
AddDeclare1(DEC_INT, "it%s", str1);
/** str1 was set by GetCom */
CheckSquare(f, var, str1, str2);
Check(f, var, 0);
Check(f, var, 1);
}
void GetBMATRIX(FILE *f, VARPTR var, int flag)
{
if (var->for_type != INT && var->for_type != BOOLEAN)
{
printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
SGetSciType(var->type), SGetForType(var->for_type), var->name);
exit(1);
}
var->for_type = BOOLEAN;
GetCom(f, var, flag);
/** str1 was set by GetCom */
CheckSquare(f, var, str1, str2);
Check(f, var, 0);
Check(f, var, 1);
}
void GetSTRINGMAT(FILE *f, VARPTR var, int flag)
{
int i1 = var->stack_position;
if ( flag == 1 )
{
sprintf(str2, "k");
}
else
{
sprintf(str2, "%d", i1);
}
if (var->list_el == 0 )
{
AddDeclare1(DEC_SMAT, "Str%d", i1);
AddDeclare1(DEC_INT, "m%d", i1);
AddDeclare1(DEC_INT, "n%d", i1);
Fprintf(f, indent, "GetRhsVar(%s,\"S\",&m%d,&n%d,&Str%d);\n", str2, i1, i1, i1);
sprintf(str, "&Str%d", i1);
ChangeForName1(var, str);
}
else
{
sprintf(str1, "%de%d", i1, var->list_el);
AddDeclare1(DEC_SMAT, "Str%s", str1);
AddDeclare1(DEC_INT, "m%s", str1);
AddDeclare1(DEC_INT, "n%s", str1);
Fprintf(f, indent, "GetListRhsVar(%s,%d,\"S\",&m%s,&n%s,&Str%s);\n", str2, var->list_el,
str1, str1, str1);
sprintf(str, "&Str%s", str1);
ChangeForName1(var, str);
}
/* square matrix */
CheckSquare(f, var, str1, str2);
Check(f, var, 0);
Check(f, var, 1);
if (var->for_type != CSTRINGV)
{
printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
SGetSciType(STRINGMAT), SGetForType(var->for_type), var->name);
exit(1);
}
}
void GetSPARSE(FILE *f, VARPTR var, int flag)
{
static char C[] = "GetRhsVar(%s,\"s\",&m%d,&n%d,&S%d);\n";
static char LC[] = "GetListRhsVar(%s,%d,\"s\",&m%s,&n%s,&S%s);\n";
int i1 = var->stack_position;
if ( flag == 1 )
{
sprintf(str2, "k");
}
else
{
sprintf(str2, "%d", i1);
}
if (var->list_el == 0 )
{
/** A scilab matrix argument **/
sprintf(str1, "%d", i1);
Fprintf(f, indent, C, str2, i1, i1, i1);
/* Adding the calling sequence in the for_names */
ChangeForName2(var, "&S%d", i1);
}
else
{
/** A scilab matrix argument inside a list **/
sprintf(str1, "%de%d", i1, var->list_el);
Fprintf(f, indent, LC, str2, var->list_el, str1, str1, str1);
/* Adding the calling sequence in the for_names */
ChangeForName2(var, "&S%s", str1);
}
AddDeclare1(DEC_INT, "m%s", str1);
AddDeclare1(DEC_INT, "n%s", str1);
AddDeclare1(DEC_SPARSE, "S%s", str1);
/** str1 was set by GetCom */
CheckSquare(f, var, str1, str2);
Check(f, var, 0);
Check(f, var, 1);
}
/*--------------------------------------------------------------------------*/
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_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;
}
