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