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