/*--------------------------------------------------------------------------*/
int intsplin(char *fname,unsigned long fname_len)
{
int minrhs = 2, maxrhs = 4, minlhs = 1, maxlhs = 1;
int mx = 0, nx = 0, lx = 0, my = 0, ny = 0, ly = 0, mc = 0, nc = 0, lc = 0, n = 0, spline_type = 0;
int *str_spline_type = NULL, ns = 0;
int ld = 0, i = 0;
int mwk1 = 0, nwk1 = 0, lwk1 = 0, mwk2 = 0, nwk2 = 0, lwk2 = 0, mwk3 = 0;
int nwk3 = 0, lwk3 = 0, mwk4 = 0, nwk4 = 0, lwk4 = 0;
double *x = NULL, *y = NULL, *d = NULL, *c = NULL;
CheckRhs(minrhs, maxrhs);
CheckLhs(minlhs, maxlhs);
GetRhsVar(1, MATRIX_OF_DOUBLE_DATATYPE, &mx, &nx, &lx);
GetRhsVar(2, MATRIX_OF_DOUBLE_DATATYPE, &my, &ny, &ly);
for (i = 1; i <= minrhs; i++)
{
SciErr sciErr;
int *piAddressVar = NULL;
sciErr = getVarAddressFromPosition(pvApiCtx, i, &piAddressVar);
if(sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Can not read input argument #%d.\n"), fname, i);
return 0;
}
if (isVarComplex(pvApiCtx, piAddressVar))
{
Scierror(202, _("%s: Wrong type for argument %d: Real matrix expected.\n"), fname, i);
return 0;
}
}
if ( mx != my || nx != ny || (mx != 1 && nx != 1) )
{
Scierror(999,_("%s: Wrong size for input arguments #%d and #%d: Vector of same size expected.\n"), fname, 1, 2);
return 0;
}
n = mx * nx; /* number of interpolation points */
if ( n < 2 )
{
Scierror(999,_("%s: Wrong size for input argument #%d: Must be %s.\n"), fname,1,">= 2");
return 0;
}
x = stk(lx);
y = stk(ly);
if (! good_order(x, n)) /* verify strict increasing abscissae */
{
Scierror(999,_("%s: Wrong value for input argument #%d: Not (strictly) increasing or +-inf detected.\n"), fname,1);
return 0;
}
if ( Rhs >= 3 ) /* get the spline type */
{
GetRhsScalarString(3, &ns, &str_spline_type);
spline_type = get_type(SplineTable, NB_SPLINE_TYPE, str_spline_type, ns);
if ( spline_type == UNDEFINED )
{
Scierror(999,_("%s: Wrong values for input argument #%d: Unknown '%s' type.\n"),fname,3,"spline");
return 0;
};
}
else
{
spline_type = NOT_A_KNOT;
}
if ( spline_type == CLAMPED ) /* get arg 4 which contains the end point slopes */
{
if ( Rhs != 4 )
{
Scierror(999,_("%s: For a clamped spline, you must give the endpoint slopes.\n"),fname);
return 0;
}
GetRhsVar(4,MATRIX_OF_DOUBLE_DATATYPE, &mc, &nc, &lc);
if ( mc*nc != 2 )
{
Scierror(999,_("%s: Wrong size for input argument #%d: Endpoint slopes.\n"),fname,4);
return 0;
}
c = stk(lc);
}
else if ( Rhs == 4 )
{
Scierror(999,_("%s: Wrong number of input argument(s).\n"),fname);
return 0;
}
/* verify y(1) = y(n) for periodic splines */
if ( (spline_type == PERIODIC || spline_type == FAST_PERIODIC) && y[0] != y[n-1] )
{
Scierror(999,_("%s: Wrong value for periodic spline %s: Must be equal to %s.\n"),fname,"y(1)","y(n)");
return(0);
};
CreateVar(Rhs+1,MATRIX_OF_DOUBLE_DATATYPE, &mx, &nx, &ld); /* memory for d (only argument returned) */
d = stk(ld);
switch(spline_type)
{
case(FAST) : case(FAST_PERIODIC) :
nwk1 = 1;
C2F(derivd) (x, y, d, &n, &nwk1, &spline_type);
break;
case(MONOTONE) :
nwk1 = 1;
C2F(dpchim) (&n, x, y, d, &nwk1);
break;
case(NOT_A_KNOT) : case(NATURAL) : case(CLAMPED) : case(PERIODIC) :
/* (the wk4 work array is used only in the periodic case) */
mwk1 = n; nwk1 = 1; mwk2 = n-1; nwk2 = 1; mwk3 = n-1; nwk3 = 1; mwk4 = n-1; nwk4 = 1;
CreateVar(Rhs+2,MATRIX_OF_DOUBLE_DATATYPE, &mwk1, &nwk1, &lwk1);
CreateVar(Rhs+3,MATRIX_OF_DOUBLE_DATATYPE, &mwk2, &nwk2, &lwk2);
CreateVar(Rhs+4,MATRIX_OF_DOUBLE_DATATYPE, &mwk3, &nwk3, &lwk3);
lwk4 = lwk1;
if (spline_type == CLAMPED)
{ d[0] = c[0]; d[n-1] = c[1]; };
if (spline_type == PERIODIC)
{
CreateVar(Rhs+5,MATRIX_OF_DOUBLE_DATATYPE, &mwk4, &nwk4, &lwk4);
}
C2F(splinecub) (x, y, d, &n, &spline_type, stk(lwk1), stk(lwk2), stk(lwk3), stk(lwk4));
break;
}
LhsVar(1) = Rhs+1;
PutLhsVar();
return 0;
}
types::Function::ReturnValue sci_splin(types::typed_list &in, int _iRetCount, types::typed_list &out)
{
// input
types::Double* pDblX = NULL;
types::Double* pDblY = NULL;
types::Double* pDblDer = NULL;
// output
types::Double* pDblOut = NULL;
int iType = 0; // default value = not_a_knot
int one = 1;
int iSize = 0;
double* rwork1 = NULL;
double* rwork2 = NULL;
double* rwork3 = NULL;
double* rwork4 = NULL;
// *** check the minimal number of input args. ***
if (in.size() < 2 || in.size() > 4)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), "splin", 2, 4);
return types::Function::Error;
}
// *** check number of output args according the methode. ***
if (_iRetCount > 1)
{
Scierror(78, _("%s: Wrong number of output argument(s): %d expected.\n"), "splin", 1);
return types::Function::Error;
}
// *** check type of input args and get it. ***
// x
if (in[0]->isDouble() == false)
{
Scierror(999, _("%s: Wrong type for input argument #%d : A matrix expected.\n"), "splin", 1);
return types::Function::Error;
}
pDblX = in[0]->getAs<types::Double>();
iSize = pDblX->getSize();
if (pDblX->isComplex())
{
Scierror(999, _("%s: Wrong type for argument #%d: Real matrix expected.\n"), "splin", 1);
return types::Function::Error;
}
if (iSize < 2)
{
Scierror(999, _("%s: Wrong size for input argument #%d : At least a size of 2 expected.\n"), "splin", 1);
return types::Function::Error;
}
if (good_order(pDblX->get(), iSize) == false) /* verify strict increasing abscissae */
{
Scierror(999, _("%s: Wrong value for input argument #%d: Not (strictly) increasing or +-inf detected.\n"), "splin", 1);
return types::Function::Error;
}
// y
if (in[1]->isDouble() == false)
{
Scierror(999, _("%s: Wrong type for input argument #%d : A matrix expected.\n"), "splin", 2);
return types::Function::Error;
}
pDblY = in[1]->getAs<types::Double>();
if (pDblY->isComplex())
{
Scierror(999, _("%s: Wrong type for argument #%d: Real matrix expected.\n"), "splin", 2);
return types::Function::Error;
}
if ( pDblX->getCols() != pDblY->getCols() ||
pDblX->getRows() != pDblY->getRows() ||
(pDblX->getCols() != 1 && pDblX->getRows() != 1))
{
Scierror(999, _("%s: Wrong size for input arguments #%d and #%d: Vector of same size expected.\n"), "splin", 1, 2);
return types::Function::Error;
}
if (in.size() > 2)
{
if (in[2]->isString() == false)
{
Scierror(999, _("%s: Wrong type for input argument #%d : string expected.\n"), "splin", 3);
return types::Function::Error;
}
wchar_t* wcsType = in[2]->getAs<types::String>()->get(0);
if (wcscmp(wcsType, L"not_a_knot") == 0)
{
iType = 0;
}
else if (wcscmp(wcsType, L"natural") == 0)
{
iType = 1;
}
else if (wcscmp(wcsType, L"clamped") == 0)
{
iType = 2;
}
else if (wcscmp(wcsType, L"periodic") == 0)
{
iType = 3;
}
else if (wcscmp(wcsType, L"fast") == 0)
{
iType = 4;
}
else if (wcscmp(wcsType, L"fast_periodic") == 0)
{
iType = 5;
}
else if (wcscmp(wcsType, L"monotone") == 0)
{
iType = 6;
}
else // undefined
{
char* pstType = wide_string_to_UTF8(wcsType);
Scierror(999, _("%s: Wrong values for input argument #%d : '%s' is an unknown '%s' type.\n"), "splin", 3, pstType, "spline");
FREE(pstType);
return types::Function::Error;
}
if (iType == 2)
{
if (in.size() != 4)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "splin", 4);
return types::Function::Error;
}
if (in[3]->isDouble() == false)
{
Scierror(999, _("%s: Wrong type for input argument #%d : A matrix expected.\n"), "splin", 4);
return types::Function::Error;
}
pDblDer = in[3]->getAs<types::Double>();
if (pDblDer->getSize() != 2)
{
Scierror(999, _("%s: Wrong size for input argument #%d : A matrix of size 2 expected.\n"), "splin", 4);
return types::Function::Error;
}
}
else if (in.size() == 4)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "splin", 3);
return types::Function::Error;
}
}
// verify y(1) = y(n) for periodic splines
if ((iType == 3 || iType == 5) && pDblY->get(0) != pDblY->get(pDblY->getSize() - 1))
{
Scierror(999, _("%s: Wrong value for periodic spline %s: Must be equal to %s.\n"), "spline", "y(1)", "y(n)");
return types::Function::Error;
}
// *** Perform operation. ***
pDblOut = new types::Double(pDblX->getRows(), pDblX->getCols());
switch (iType)
{
case 6:
C2F(dpchim)(&iSize, pDblX->get(), pDblY->get(), pDblOut->get(), &one);
case 5:
case 4:
C2F(derivd)(pDblX->get(), pDblY->get(), pDblOut->get(), &iSize, &one, &iType);
break;
break;
case 3:
case 2:
case 1:
case 0:
{
rwork1 = new double[iSize];
rwork2 = new double[iSize - 1];
rwork3 = new double[iSize - 1];
rwork4 = rwork1;
if (iType == 2)
{
pDblOut->set(0, pDblDer->get(0));
pDblOut->set(iSize - 1, pDblDer->get(1));
}
if (iType == 3)
{
rwork4 = new double[iSize - 1];
}
C2F(splinecub)(pDblX->get(), pDblY->get(), pDblOut->get(), &iSize, &iType, rwork1, rwork2, rwork3, rwork4);
delete[] rwork1;
delete[] rwork2;
delete[] rwork3;
if (iType == 3)
{
delete[] rwork4;
}
break;
}
}
// *** Return result in Scilab. ***
out.push_back(pDblOut);
return types::Function::OK;
}
