1 /*
2 * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3 * Copyright (C) 2014 - Scilab Enterprises - Cedric DELAMARRE
4 *
5 * Copyright (C) 2012 - 2016 - Scilab Enterprises
6 *
7 * This file is hereby licensed under the terms of the GNU GPL v2.0,
8 * pursuant to article 5.3.4 of the CeCILL v.2.1.
9 * This file was originally licensed under the terms of the CeCILL v2.1,
10 * and continues to be available under such terms.
11 * For more information, see the COPYING file which you should have received
12 * along with this program.
13 *
14 */
15 /*--------------------------------------------------------------------------*/
16 #include "cacsd_gw.hxx"
17 #include "function.hxx"
18 #include "overload.hxx"
19 #include "double.hxx"
20
21 extern "C"
22 {
23 #include "Scierror.h"
24 #include "localization.h"
25
26 extern void C2F(ereduc)(double*, int*, int*, double*, double*, int*, int*, double*);
27 }
28
29 /*--------------------------------------------------------------------------*/
sci_ereduc(types::typed_list & in,int _iRetCount,types::typed_list & out)30 types::Function::ReturnValue sci_ereduc(types::typed_list &in, int _iRetCount, types::typed_list &out)
31 {
32 double* pdblX = NULL;
33 int iRowsX = 0;
34 int iColsX = 0;
35 double dTol = 0;
36
37 if (in.size() != 2)
38 {
39 Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "ereduc", 2);
40 return types::Function::Error;
41 }
42
43 if (_iRetCount > 5)
44 {
45 Scierror(78, _("%s: Wrong number of output argument(s): %d to %d expected.\n"), "ereduc", 1, 5);
46 return types::Function::Error;
47 }
48
49 /*** get inputs arguments ***/
50 // get X
51 if (in[0]->isDouble() == false)
52 {
53 std::wstring wstFuncName = L"%" + in[0]->getShortTypeStr() + L"_ereduc";
54 return Overload::call(wstFuncName, in, _iRetCount, out);
55 }
56
57 types::Double* pDblX = in[0]->clone()->getAs<types::Double>();
58 pdblX = pDblX->get();
59 iColsX = pDblX->getCols();
60 iRowsX = pDblX->getRows();
61
62 // get Tol
63 if (in[1]->isDouble() == false)
64 {
65 Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "ereduc", 2);
66 return types::Function::Error;
67 }
68
69 types::Double* pDblTol = in[1]->getAs<types::Double>();
70
71 if (pDblTol->isScalar() == false)
72 {
73 Scierror(999, _("%s: Wrong type for input argument #%d: A scalar expected.\n"), "ereduc", 2);
74 return types::Function::Error;
75 }
76
77 dTol = pDblTol->get(0);
78
79 /*** perform operations ***/
80 types::Double* pDblQ = new types::Double(iRowsX, iRowsX);
81 double* pdblQ = pDblQ->get();
82 types::Double* pDblZ = new types::Double(iColsX, iColsX);
83 double* pdblZ = pDblZ->get();
84
85 int* piStair = new int[iRowsX];
86 int iRk = 0;
87
88 C2F(ereduc)(pdblX, &iRowsX, &iColsX, pdblQ, pdblZ, piStair, &iRk, &dTol);
89
90 /*** retrun output arguments ***/
91 // return E
92 out.push_back(pDblX);
93
94 // return Q
95 if (_iRetCount > 1)
96 {
97 out.push_back(pDblQ);
98 }
99 else
100 {
101 delete pDblQ;
102 }
103
104 // return Z
105 if (_iRetCount > 2)
106 {
107 out.push_back(pDblZ);
108 }
109 else
110 {
111 delete pDblZ;
112 }
113
114 // return Stair
115 if (_iRetCount > 3)
116 {
117 types::Double* pDblStair = new types::Double(1, iRowsX);
118 double* pdblStair = pDblStair->get();
119 for (int i = 0; i < iRowsX; i++)
120 {
121 pdblStair[i] = (double)(piStair[i]);
122 }
123
124 out.push_back(pDblStair);
125 }
126
127 delete[] piStair;
128
129 // return rk
130 if (_iRetCount > 4)
131 {
132 out.push_back(new types::Double((double)iRk));
133 }
134
135 return types::Function::OK;
136 }
137 /*--------------------------------------------------------------------------*/
138