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