1 /*
2 * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3 * Copyright (C) 2011 - DIGITEO - 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 <vector>
17 #include "string.hxx"
18 #include "double.hxx"
19 #include "optimizationfunctions.hxx"
20 #include "configvariable.hxx"
21 #include "commentexp.hxx"
22
23 extern "C"
24 {
25 #include "elem_common.h"
26 #include "scioptimfunctions.h"
27 #include "localization.h"
28 }
29
30 /*
31 ** optimization functions
32 ** \{
33 */
34
35 std::vector<OptimizationFunctions*> Optimization::m_OptimizationFunctions;
36
37 using namespace types;
addOptimizationFunctions(OptimizationFunctions * _opFunction)38 void Optimization::addOptimizationFunctions(OptimizationFunctions* _opFunction)
39 {
40 m_OptimizationFunctions.push_back(_opFunction);
41 }
42
removeOptimizationFunctions()43 void Optimization::removeOptimizationFunctions()
44 {
45 m_OptimizationFunctions.pop_back();
46 }
47
getOptimizationFunctions()48 OptimizationFunctions* Optimization::getOptimizationFunctions()
49 {
50 return m_OptimizationFunctions.back();
51 }
52
53 /*
54 ** \}
55 */
56
57
58 /*--------------------------------------------------------------------------*/
OptimizationFunctions(const std::wstring & callerName)59 OptimizationFunctions::OptimizationFunctions(const std::wstring& callerName)
60 {
61 m_iXRows = 0;
62 m_iXCols = 0;
63
64 m_wstrCaller = callerName;
65
66 // optim
67 m_pCallOptimCostfFunction = NULL;
68 m_pStringOptimCostfFunctionDyn = NULL;
69 m_pStringOptimCostfFunctionStatic = NULL;
70
71 // fsolve
72 m_pCallFsolveFctFunction = NULL;
73 m_pStringFsolveFctFunctionDyn = NULL;
74 m_pStringFsolveFctFunctionStatic = NULL;
75
76 m_pCallFsolveJacFunction = NULL;
77 m_pStringFsolveJacFunctionDyn = NULL;
78 m_pStringFsolveJacFunctionStatic = NULL;
79
80 // init static functions
81 if (callerName == L"optim")
82 {
83 m_staticFunctionMap[L"genros"] = (void*) C2F(genros);
84 m_staticFunctionMap[L"topt2"] = (void*) C2F(topt2);
85 m_staticFunctionMap[L"icsemc"] = (void*) C2F(icsemc);
86 m_staticFunctionMap[L"mcsec"] = (void*) C2F(mcsec);
87 }
88 else if (callerName == L"fsolve")
89 {
90 m_staticFunctionMap[L"fsol1"] = (void*) C2F(fsol1);
91 m_staticFunctionMap[L"fsolj1"] = (void*) C2F(fsolj1);
92 }
93 else if (callerName == L"lsqrsolve")
94 {
95 m_staticFunctionMap[L"lsqrsol1"] = (void*) C2F(lsqrsol1);
96 m_staticFunctionMap[L"lsqrsolj1"] = (void*) C2F(lsqrsolj1);
97 }
98 }
99
~OptimizationFunctions()100 OptimizationFunctions::~OptimizationFunctions()
101 {
102 m_staticFunctionMap.clear();
103 }
104
105 /*------------------------------- public -------------------------------------------*/
106 // optim
execCostf(int * ind,int * n,double * x,double * f,double * g,int * ti,float * tr,double * td)107 void OptimizationFunctions::execCostf(int *ind, int *n, double *x, double *f, double *g, int *ti, float *tr, double *td)
108 {
109 char errorMsg[256];
110 if (m_pCallOptimCostfFunction)
111 {
112 callCostfMacro(ind, n, x, f, g, ti, tr, td);
113 }
114 else if (m_pStringOptimCostfFunctionDyn)
115 {
116 ConfigVariable::EntryPointStr* func = ConfigVariable::getEntryPoint(m_pStringOptimCostfFunctionDyn->get(0));
117 if (func == NULL)
118 {
119 sprintf(errorMsg, _("Undefined function '%ls'.\n"), m_pStringOptimCostfFunctionDyn->get(0));
120 throw ast::InternalError(errorMsg);
121 }
122 ((costf_t)(func->functionPtr))(ind, n, x, f, g, ti, tr, td);
123 }
124 else if (m_pStringOptimCostfFunctionStatic)
125 {
126 ((costf_t)m_staticFunctionMap[m_pStringOptimCostfFunctionStatic->get(0)])(ind, n, x, f, g, ti, tr, td);
127 }
128 else
129 {
130 sprintf(errorMsg, _("User function '%s' have not been set.\n"), "costf");
131 throw ast::InternalError(errorMsg);
132 }
133 }
134
135 // fsolve
execFsolveFct(int * n,double * x,double * v,int * iflag)136 void OptimizationFunctions::execFsolveFct(int* n, double* x, double* v, int* iflag)
137 {
138 char errorMsg[256];
139 if (m_pCallFsolveFctFunction)
140 {
141 callFsolveFctMacro(n, x, v, iflag);
142 }
143 else if (m_pStringFsolveFctFunctionDyn)
144 {
145 ConfigVariable::EntryPointStr* func = ConfigVariable::getEntryPoint(m_pStringFsolveFctFunctionDyn->get(0));
146 if (func == NULL)
147 {
148 sprintf(errorMsg, _("Undefined function '%ls'.\n"), m_pStringFsolveFctFunctionDyn->get(0));
149 throw ast::InternalError(errorMsg);
150 }
151 ((fct_t)(func->functionPtr))(n, x, v, iflag);
152 }
153 else if (m_pStringFsolveFctFunctionStatic)
154 {
155 ((fct_t)m_staticFunctionMap[m_pStringFsolveFctFunctionStatic->get(0)])(n, x, v, iflag);
156 }
157 else
158 {
159 sprintf(errorMsg, _("User function '%s' have not been set.\n"), "costf");
160 throw ast::InternalError(errorMsg);
161 }
162 }
execFsolveJac(int * n,double * x,double * v,double * jac,int * ldjac,int * iflag)163 void OptimizationFunctions::execFsolveJac(int* n, double* x, double* v, double* jac, int* ldjac, int* iflag)
164 {
165 char errorMsg[256];
166 if (m_pCallFsolveJacFunction)
167 {
168 callFsolveJacMacro(n, x, v, jac, ldjac, iflag);
169 }
170 else if (m_pStringFsolveJacFunctionDyn)
171 {
172 ConfigVariable::EntryPointStr* func = ConfigVariable::getEntryPoint(m_pStringFsolveJacFunctionDyn->get(0));
173 if (func == NULL)
174 {
175 sprintf(errorMsg, _("Undefined function '%ls'.\n"), m_pStringFsolveJacFunctionDyn->get(0));
176 throw ast::InternalError(errorMsg);
177 }
178 // c or fortran jac fuction are the same proto as fct
179 ((fct_t)(func->functionPtr))(n, x, jac, iflag);
180 }
181 else if (m_pStringFsolveJacFunctionStatic)
182 {
183 // c or fortran jac fuction are the same proto as fct
184 ((fct_t)m_staticFunctionMap[m_pStringFsolveJacFunctionStatic->get(0)])(n, x, jac, iflag);
185 }
186 else
187 {
188 sprintf(errorMsg, _("User function '%s' have not been set.\n"), "costf");
189 throw ast::InternalError(errorMsg);
190 }
191 }
192
193 // lsqrsolve
execLsqrsolveFct(int * m,int * n,double * x,double * v,int * iflag)194 void OptimizationFunctions::execLsqrsolveFct(int* m, int* n, double* x, double* v, int* iflag)
195 {
196 char errorMsg[256];
197 if (m_pCallFsolveFctFunction)
198 {
199 callLsqrsolveFctMacro(m, n, x, v, iflag);
200 }
201 else if (m_pStringFsolveFctFunctionDyn)
202 {
203 ConfigVariable::EntryPointStr* func = ConfigVariable::getEntryPoint(m_pStringFsolveFctFunctionDyn->get(0));
204 if (func == NULL)
205 {
206 sprintf(errorMsg, _("Undefined function '%ls'.\n"), m_pStringFsolveFctFunctionDyn->get(0));
207 throw ast::InternalError(errorMsg);
208 }
209 ((lsqrfct_t)(func->functionPtr))(m, n, x, v, iflag);
210 }
211 else if (m_pStringFsolveFctFunctionStatic)
212 {
213 ((lsqrfct_t)m_staticFunctionMap[m_pStringFsolveFctFunctionStatic->get(0)])(m, n, x, v, iflag);
214 }
215 else
216 {
217 sprintf(errorMsg, _("User function '%s' have not been set.\n"), "costf");
218 throw ast::InternalError(errorMsg);
219 }
220 }
execLsqrsolveJac(int * m,int * n,double * x,double * v,double * jac,int * ldjac,int * iflag)221 void OptimizationFunctions::execLsqrsolveJac(int* m, int* n, double* x, double* v, double* jac, int* ldjac, int* iflag)
222 {
223 char errorMsg[256];
224 if (m_pCallFsolveJacFunction)
225 {
226 callLsqrsolveJacMacro(m, n, x, v, jac, ldjac, iflag);
227 }
228 else if (m_pStringFsolveJacFunctionDyn)
229 {
230 ConfigVariable::EntryPointStr* func = ConfigVariable::getEntryPoint(m_pStringFsolveJacFunctionDyn->get(0));
231 if (func == NULL)
232 {
233 sprintf(errorMsg, _("Undefined function '%ls'.\n"), m_pStringFsolveJacFunctionDyn->get(0));
234 throw ast::InternalError(errorMsg);
235 }
236 // c or fortran jac fuction are the same proto as fct
237 ((lsqrjac_ext_t)(func->functionPtr))(m, n, x, jac, ldjac, iflag);
238 }
239 else if (m_pStringFsolveJacFunctionStatic)
240 {
241 // c or fortran jac fuction are the same proto as fct
242 ((lsqrjac_ext_t)m_staticFunctionMap[m_pStringFsolveJacFunctionStatic->get(0)])(m, n, x, jac, ldjac, iflag);
243 }
244 else
245 {
246 sprintf(errorMsg, _("User function '%s' have not been set.\n"), "costf");
247 throw ast::InternalError(errorMsg);
248 }
249 }
250
251 //*** setter ***
setXRows(int _iRows)252 void OptimizationFunctions::setXRows(int _iRows)
253 {
254 m_iXRows = _iRows;
255 }
setXCols(int _iCols)256 void OptimizationFunctions::setXCols(int _iCols)
257 {
258 m_iXCols = _iCols;
259 }
260
261 // optim
setCostfArgs(types::InternalType * _Args)262 void OptimizationFunctions::setCostfArgs(types::InternalType* _Args)
263 {
264 m_OptimArgs.push_back(_Args);
265 }
266
setOptimCostfFunction(types::Callable * _func)267 void OptimizationFunctions::setOptimCostfFunction(types::Callable* _func)
268 {
269 m_pCallOptimCostfFunction = _func;
270 }
271
setOptimCostfFunction(types::String * _func)272 bool OptimizationFunctions::setOptimCostfFunction(types::String* _func)
273 {
274 if (ConfigVariable::getEntryPoint(_func->get(0)))
275 {
276 m_pStringOptimCostfFunctionDyn = _func;
277 return true;
278 }
279 else
280 {
281 if (m_staticFunctionMap.find(_func->get(0)) != m_staticFunctionMap.end())
282 {
283 m_pStringOptimCostfFunctionStatic = _func;
284 return true;
285 }
286 return false;
287 }
288 }
289
290 // fsolve
setFsolveFctArgs(types::InternalType * _Args)291 void OptimizationFunctions::setFsolveFctArgs(types::InternalType* _Args)
292 {
293 m_fsolveFctArgs.push_back(_Args);
294 }
295
setFsolveFctFunction(types::Callable * _func)296 void OptimizationFunctions::setFsolveFctFunction(types::Callable* _func)
297 {
298 m_pCallFsolveFctFunction = _func;
299 }
300
setFsolveFctFunction(types::String * _func)301 bool OptimizationFunctions::setFsolveFctFunction(types::String* _func)
302 {
303 if (ConfigVariable::getEntryPoint(_func->get(0)))
304 {
305 m_pStringFsolveFctFunctionDyn = _func;
306 return true;
307 }
308 else
309 {
310 if (m_staticFunctionMap.find(_func->get(0)) != m_staticFunctionMap.end())
311 {
312 m_pStringFsolveFctFunctionStatic = _func;
313 return true;
314 }
315 return false;
316 }
317 }
318
setFsolveJacArgs(types::InternalType * _Args)319 void OptimizationFunctions::setFsolveJacArgs(types::InternalType* _Args)
320 {
321 m_fsolveJacArgs.push_back(_Args);
322 }
323
setFsolveJacFunction(types::Callable * _func)324 void OptimizationFunctions::setFsolveJacFunction(types::Callable* _func)
325 {
326 m_pCallFsolveJacFunction = _func;
327 }
328
setFsolveJacFunction(types::String * _func)329 bool OptimizationFunctions::setFsolveJacFunction(types::String* _func)
330 {
331 if (ConfigVariable::getEntryPoint(_func->get(0)))
332 {
333 m_pStringFsolveJacFunctionDyn = _func;
334 return true;
335 }
336 else
337 {
338 if (m_staticFunctionMap.find(_func->get(0)) != m_staticFunctionMap.end())
339 {
340 m_pStringFsolveJacFunctionStatic = _func;
341 return true;
342 }
343 return false;
344 }
345 }
346
347 //*** getter ***
getXRows()348 int OptimizationFunctions::getXRows()
349 {
350 return m_iXRows;
351 }
getXCols()352 int OptimizationFunctions::getXCols()
353 {
354 return m_iXCols;
355 }
356
357 /*------------------------------- private -------------------------------------------*/
358 // optim
callCostfMacro(int * ind,int * n,double * x,double * f,double * g,int * ti,float * tr,double * td)359 void OptimizationFunctions::callCostfMacro(int *ind, int *n, double *x, double *f, double *g, int *ti, float *tr, double *td)
360 {
361 char errorMsg[256];
362 int iRetCount = 3;
363 int one = 1;
364
365 types::typed_list in;
366 types::typed_list out;
367 types::optional_list opt;
368
369 // create input args
370 types::Double* pDblX = new types::Double(m_iXRows, m_iXCols);
371 C2F(dcopy)(n, x, &one, pDblX->get(), &one);
372 pDblX->IncreaseRef();
373
374 types::Double* pDblInd = new types::Double((double)(*ind));
375 pDblInd->IncreaseRef();
376
377 // push_back
378 in.push_back(pDblX);
379 in.push_back(pDblInd);
380
381 for (int i = 0; i < (int)m_OptimArgs.size(); i++)
382 {
383 m_OptimArgs[i]->IncreaseRef();
384 in.push_back(m_OptimArgs[i]);
385 }
386
387 try
388 {
389 // new std::wstring(L"") is delete in destructor of ast::CommentExp
390 m_pCallOptimCostfFunction->invoke(in, opt, iRetCount, out, ast::CommentExp(Location(), new std::wstring(L"")));
391 }
392 catch (const ast::InternalError& ie)
393 {
394 for (int i = 0; i < (int)m_OptimArgs.size(); i++)
395 {
396 m_OptimArgs[i]->DecreaseRef();
397 }
398 pDblX->DecreaseRef();
399 pDblX->killMe();
400 pDblInd->DecreaseRef();
401 pDblInd->killMe();
402 throw ie;
403 }
404
405 for (int i = 0; i < (int)m_OptimArgs.size(); i++)
406 {
407 m_OptimArgs[i]->DecreaseRef();
408 }
409
410 if (out.size() != iRetCount)
411 {
412 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
413 sprintf(errorMsg, _("%s: Wrong number of input argument(s): %d expected.\n"), pstrName, iRetCount);
414 FREE(pstrName);
415 pDblX->DecreaseRef();
416 pDblX->killMe();
417 pDblInd->DecreaseRef();
418 pDblInd->killMe();
419 throw ast::InternalError(errorMsg);
420 }
421
422 out[0]->IncreaseRef();
423 out[1]->IncreaseRef();
424 out[2]->IncreaseRef();
425
426 pDblX->DecreaseRef();
427 if (pDblX->isDeletable())
428 {
429 delete pDblX;
430 }
431
432 pDblInd->DecreaseRef();
433 if (pDblInd->isDeletable())
434 {
435 delete pDblInd;
436 }
437
438 types::Double* pDblOut = NULL;
439
440 // get f
441 if (out[0]->isDouble() == false)
442 {
443 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
444 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
445 FREE(pstrName);
446 throw ast::InternalError(errorMsg);
447 }
448
449 pDblOut = out[0]->getAs<types::Double>();
450 if (pDblOut->isComplex() || pDblOut->isScalar() == false)
451 {
452 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
453 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
454 FREE(pstrName);
455 throw ast::InternalError(errorMsg);
456 }
457
458 *f = pDblOut->get(0);
459
460 out[0]->DecreaseRef();
461 if (out[0]->isDeletable())
462 {
463 delete out[0];
464 }
465
466 // get g
467 if (out[1]->isDouble() == false)
468 {
469 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
470 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real matrix expected.\n"), pstrName, 2);
471 FREE(pstrName);
472 throw ast::InternalError(errorMsg);
473 }
474
475 pDblOut = out[1]->getAs<types::Double>();
476 if (pDblOut->isComplex())
477 {
478 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
479 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real matrix expected.\n"), pstrName, 2);
480 FREE(pstrName);
481 throw ast::InternalError(errorMsg);
482 }
483
484 if (pDblOut->getSize() != *n)
485 {
486 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
487 sprintf(errorMsg, _("%s: Wrong size for output argument #%d: %d element(s) expected.\n"), pstrName, 2, *n);
488 FREE(pstrName);
489 throw ast::InternalError(errorMsg);
490 }
491
492 C2F(dcopy)(n, pDblOut->get(), &one, g, &one);
493
494 out[1]->DecreaseRef();
495 if (out[1]->isDeletable())
496 {
497 delete out[1];
498 }
499
500 // get ind
501 if (out[2]->isDouble() == false)
502 {
503 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
504 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 3);
505 FREE(pstrName);
506 throw ast::InternalError(errorMsg);
507 }
508
509 pDblOut = out[2]->getAs<types::Double>();
510 if (pDblOut->isComplex() || pDblOut->isScalar() == false)
511 {
512 char* pstrName = wide_string_to_UTF8(m_pCallOptimCostfFunction->getName().c_str());
513 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 3);
514 FREE(pstrName);
515 throw ast::InternalError(errorMsg);
516 }
517
518 *ind = (int)pDblOut->get(0);
519
520 out[2]->DecreaseRef();
521 if (out[2]->isDeletable())
522 {
523 delete out[2];
524 }
525 }
526
527 // fsolve
callFsolveFctMacro(int * n,double * x,double * v,int * iflag)528 void OptimizationFunctions::callFsolveFctMacro(int *n, double *x, double *v, int *iflag)
529 {
530 char errorMsg[256];
531 int iRetCount = 1;
532 int one = 1;
533
534 types::typed_list in;
535 types::typed_list out;
536 types::optional_list opt;
537
538 // create input args
539 types::Double* pDblX = new types::Double(m_iXRows, m_iXCols);
540 C2F(dcopy)(n, x, &one, pDblX->get(), &one);
541 pDblX->IncreaseRef();
542
543 // push_back
544 in.push_back(pDblX);
545
546 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
547 {
548 m_fsolveFctArgs[i]->IncreaseRef();
549 in.push_back(m_fsolveFctArgs[i]);
550 }
551
552 try
553 {
554 // new std::wstring(L"") is delete in destructor of ast::CommentExp
555 m_pCallFsolveFctFunction->invoke(in, opt, iRetCount, out, ast::CommentExp(Location(), new std::wstring(L"")));
556 }
557 catch (const ast::InternalError& ie)
558 {
559 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
560 {
561 m_fsolveFctArgs[i]->DecreaseRef();
562 }
563 pDblX->DecreaseRef();
564 pDblX->killMe();
565 throw ie;
566 }
567
568 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
569 {
570 m_fsolveFctArgs[i]->DecreaseRef();
571 }
572
573 if (out.size() != iRetCount)
574 {
575 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
576 sprintf(errorMsg, _("%s: Wrong number of input argument(s): %d expected.\n"), pstrName, iRetCount);
577 FREE(pstrName);
578 pDblX->DecreaseRef();
579 pDblX->killMe();
580 throw ast::InternalError(errorMsg);
581 }
582
583 out[0]->IncreaseRef();
584
585 pDblX->DecreaseRef();
586 if (pDblX->isDeletable())
587 {
588 delete pDblX;
589 }
590
591 types::Double* pDblOut = NULL;
592
593 // get v
594 if (out[0]->isDouble() == false)
595 {
596 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
597 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
598 FREE(pstrName);
599 throw ast::InternalError(errorMsg);
600 }
601
602 pDblOut = out[0]->getAs<types::Double>();
603 if (pDblOut->getRows() != m_iXRows || pDblOut->getCols() != m_iXCols)
604 {
605 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
606 sprintf(errorMsg, _("%s: Wrong size for output argument #%d: A matrix of size %d x %d expected.\n"), pstrName, 1, m_iXRows, m_iXCols);
607 FREE(pstrName);
608 throw ast::InternalError(errorMsg);
609 }
610
611 C2F(dcopy)(n, pDblOut->get(), &one, v, &one);
612
613 out[0]->DecreaseRef();
614 if (out[0]->isDeletable())
615 {
616 delete out[0];
617 }
618 }
619
callFsolveJacMacro(int * n,double * x,double * v,double * jac,int * ldjac,int * iflag)620 void OptimizationFunctions::callFsolveJacMacro(int *n, double *x, double *v, double* jac, int* ldjac, int *iflag)
621 {
622 char errorMsg[256];
623 int iRetCount = 1;
624 int one = 1;
625
626 types::typed_list in;
627 types::typed_list out;
628 types::optional_list opt;
629
630 // create input args
631 types::Double* pDblX = new types::Double(m_iXRows, m_iXCols);
632 C2F(dcopy)(n, x, &one, pDblX->get(), &one);
633 pDblX->IncreaseRef();
634
635 // push_back
636 in.push_back(pDblX);
637
638 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
639 {
640 m_fsolveJacArgs[i]->IncreaseRef();
641 in.push_back(m_fsolveJacArgs[i]);
642 }
643
644 try
645 {
646 // new std::wstring(L"") is delete in destructor of ast::CommentExp
647 m_pCallFsolveJacFunction->invoke(in, opt, iRetCount, out, ast::CommentExp(Location(), new std::wstring(L"")));
648 }
649 catch (const ast::InternalError& ie)
650 {
651 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
652 {
653 m_fsolveJacArgs[i]->DecreaseRef();
654 }
655 pDblX->DecreaseRef();
656 pDblX->killMe();
657 throw ie;
658 }
659
660 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
661 {
662 m_fsolveJacArgs[i]->DecreaseRef();
663 }
664
665 if (out.size() != iRetCount)
666 {
667 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
668 sprintf(errorMsg, _("%s: Wrong number of input argument(s): %d expected.\n"), pstrName, iRetCount);
669 FREE(pstrName);
670 pDblX->DecreaseRef();
671 pDblX->killMe();
672 throw ast::InternalError(errorMsg);
673 }
674
675 out[0]->IncreaseRef();
676
677 pDblX->DecreaseRef();
678 if (pDblX->isDeletable())
679 {
680 delete pDblX;
681 }
682
683 types::Double* pDblOut = NULL;
684
685 // get jac
686 if (out[0]->isDouble() == false)
687 {
688 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
689 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
690 FREE(pstrName);
691 throw ast::InternalError(errorMsg);
692 }
693
694 pDblOut = out[0]->getAs<types::Double>();
695 if (pDblOut->getRows() != *ldjac || pDblOut->getCols() != *n)
696 {
697 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
698 sprintf(errorMsg, _("%s: Wrong size for output argument #%d: A matrix of size %d x %d expected.\n"), pstrName, 1, *ldjac, *n);
699 FREE(pstrName);
700 throw ast::InternalError(errorMsg);
701 }
702
703 int iSize = (*ldjac) * (*n);
704 C2F(dcopy)(&iSize, pDblOut->get(), &one, jac, &one);
705
706 out[0]->DecreaseRef();
707 if (out[0]->isDeletable())
708 {
709 delete out[0];
710 }
711 }
712
713 // lsqrsolve
callLsqrsolveFctMacro(int * m,int * n,double * x,double * v,int * iflag)714 void OptimizationFunctions::callLsqrsolveFctMacro(int *m, int *n, double *x, double *v, int *iflag)
715 {
716 char errorMsg[256];
717 int iRetCount = 1;
718 int one = 1;
719
720 types::typed_list in;
721 types::typed_list out;
722 types::optional_list opt;
723
724 // create input args
725 types::Double* pDblX = new types::Double(m_iXRows, m_iXCols);
726 C2F(dcopy)(n, x, &one, pDblX->get(), &one);
727 pDblX->IncreaseRef();
728 types::Double* pDblM = new types::Double((double)*m);
729 pDblM->IncreaseRef();
730
731 // push_back
732 in.push_back(pDblX);
733 in.push_back(pDblM);
734
735 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
736 {
737 m_fsolveFctArgs[i]->IncreaseRef();
738 in.push_back(m_fsolveFctArgs[i]);
739 }
740
741 try
742 {
743 // new std::wstring(L"") is delete in destructor of ast::CommentExp
744 m_pCallFsolveFctFunction->invoke(in, opt, iRetCount, out, ast::CommentExp(Location(), new std::wstring(L"")));
745 }
746 catch (const ast::InternalError& ie)
747 {
748 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
749 {
750 m_fsolveFctArgs[i]->DecreaseRef();
751 }
752 pDblX->DecreaseRef();
753 pDblX->killMe();
754 pDblM->DecreaseRef();
755 pDblM->killMe();
756 throw ie;
757 }
758
759 for (int i = 0; i < (int)m_fsolveFctArgs.size(); i++)
760 {
761 m_fsolveFctArgs[i]->DecreaseRef();
762 }
763
764 if (out.size() != iRetCount)
765 {
766 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
767 sprintf(errorMsg, _("%s: Wrong number of input argument(s): %d expected.\n"), pstrName, iRetCount);
768 FREE(pstrName);
769 pDblX->DecreaseRef();
770 pDblX->killMe();
771 pDblM->DecreaseRef();
772 pDblM->killMe();
773 throw ast::InternalError(errorMsg);
774 }
775
776 out[0]->IncreaseRef();
777
778 pDblX->DecreaseRef();
779 if (pDblX->isDeletable())
780 {
781 delete pDblX;
782 }
783
784 pDblM->DecreaseRef();
785 if (pDblM->isDeletable())
786 {
787 delete pDblM;
788 }
789
790 types::Double* pDblOut = NULL;
791
792 // get v
793 if (out[0]->isDouble() == false)
794 {
795 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
796 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
797 FREE(pstrName);
798 throw ast::InternalError(errorMsg);
799 }
800
801 pDblOut = out[0]->getAs<types::Double>();
802 if (pDblOut->getSize() != *m)
803 {
804 char* pstrName = wide_string_to_UTF8(m_pCallFsolveFctFunction->getName().c_str());
805 sprintf(errorMsg, _("%s: Wrong size for output argument #%d: A vector of %d expected.\n"), pstrName, 1, *m);
806 FREE(pstrName);
807 throw ast::InternalError(errorMsg);
808 }
809
810 C2F(dcopy)(m, pDblOut->get(), &one, v, &one);
811
812 out[0]->DecreaseRef();
813 if (out[0]->isDeletable())
814 {
815 delete out[0];
816 }
817 }
callLsqrsolveJacMacro(int * m,int * n,double * x,double * v,double * jac,int * ldjac,int * iflag)818 void OptimizationFunctions::callLsqrsolveJacMacro(int *m, int *n, double *x, double *v, double *jac, int *ldjac, int *iflag)
819 {
820 char errorMsg[256];
821 int iRetCount = 1;
822 int one = 1;
823
824 types::typed_list in;
825 types::typed_list out;
826 types::optional_list opt;
827
828 // create input args
829 types::Double* pDblX = new types::Double(m_iXRows, m_iXCols);
830 C2F(dcopy)(n, x, &one, pDblX->get(), &one);
831 pDblX->IncreaseRef();
832 types::Double* pDblM = new types::Double((double)*m);
833 pDblM->IncreaseRef();
834
835 // push_back
836 in.push_back(pDblX);
837 in.push_back(pDblM);
838
839 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
840 {
841 m_fsolveJacArgs[i]->IncreaseRef();
842 in.push_back(m_fsolveJacArgs[i]);
843 }
844
845 try
846 {
847 // new std::wstring(L"") is delete in destructor of ast::CommentExp
848 m_pCallFsolveJacFunction->invoke(in, opt, iRetCount, out, ast::CommentExp(Location(), new std::wstring(L"")));
849 }
850 catch (const ast::InternalError& ie)
851 {
852 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
853 {
854 m_fsolveJacArgs[i]->DecreaseRef();
855 }
856 pDblX->DecreaseRef();
857 pDblX->killMe();
858 pDblM->DecreaseRef();
859 pDblM->killMe();
860 throw ie;
861 }
862
863 for (int i = 0; i < (int)m_fsolveJacArgs.size(); i++)
864 {
865 m_fsolveJacArgs[i]->DecreaseRef();
866 }
867
868 if (out.size() != iRetCount)
869 {
870 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
871 sprintf(errorMsg, _("%s: Wrong number of input argument(s): %d expected.\n"), pstrName, iRetCount);
872 FREE(pstrName);
873 pDblX->DecreaseRef();
874 pDblX->killMe();
875 pDblM->DecreaseRef();
876 pDblM->killMe();
877 throw ast::InternalError(errorMsg);
878 }
879
880 out[0]->IncreaseRef();
881
882 pDblX->DecreaseRef();
883 if (pDblX->isDeletable())
884 {
885 delete pDblX;
886 }
887
888 pDblM->DecreaseRef();
889 if (pDblM->isDeletable())
890 {
891 delete pDblM;
892 }
893
894 types::Double* pDblOut = NULL;
895
896 // get jac
897 if (out[0]->isDouble() == false)
898 {
899 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
900 sprintf(errorMsg, _("%s: Wrong type for output argument #%d: Real scalar expected.\n"), pstrName, 1);
901 FREE(pstrName);
902 throw ast::InternalError(errorMsg);
903 }
904
905 pDblOut = out[0]->getAs<types::Double>();
906 if (pDblOut->getSize() != *m **n)
907 {
908 char* pstrName = wide_string_to_UTF8(m_pCallFsolveJacFunction->getName().c_str());
909 sprintf(errorMsg, _("%s: Wrong size for output argument #%d: A vector of %d expected.\n"), pstrName, 1, *m);
910 FREE(pstrName);
911 throw ast::InternalError(errorMsg);
912 }
913
914 int iSize = *m **n;
915 C2F(dcopy)(&iSize, pDblOut->get(), &one, jac, &one);
916
917 out[0]->DecreaseRef();
918 if (out[0]->isDeletable())
919 {
920 delete out[0];
921 }
922 }
923