Line data Source code
1 : /*************************************************************************
2 : ALGLIB 3.17.0 (source code generated 2020-12-27)
3 : Copyright (c) Sergey Bochkanov (ALGLIB project).
4 :
5 : >>> SOURCE LICENSE >>>
6 : This program is free software; you can redistribute it and/or modify
7 : it under the terms of the GNU General Public License as published by
8 : the Free Software Foundation (www.fsf.org); either version 2 of the
9 : License, or (at your option) any later version.
10 :
11 : This program is distributed in the hope that it will be useful,
12 : but WITHOUT ANY WARRANTY; without even the implied warranty of
13 : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 : GNU General Public License for more details.
15 :
16 : A copy of the GNU General Public License is available at
17 : http://www.fsf.org/licensing/licenses
18 : >>> END OF LICENSE >>>
19 : *************************************************************************/
20 : #ifdef _MSC_VER
21 : #define _CRT_SECURE_NO_WARNINGS
22 : #endif
23 : #include "stdafx.h"
24 : #include "alglibinternal.h"
25 :
26 : // disable some irrelevant warnings
27 : #if (AE_COMPILER==AE_MSVC) && !defined(AE_ALL_WARNINGS)
28 : #pragma warning(disable:4100)
29 : #pragma warning(disable:4127)
30 : #pragma warning(disable:4611)
31 : #pragma warning(disable:4702)
32 : #pragma warning(disable:4996)
33 : #endif
34 :
35 : /////////////////////////////////////////////////////////////////////////
36 : //
37 : // THIS SECTION CONTAINS IMPLEMENTATION OF C++ INTERFACE
38 : //
39 : /////////////////////////////////////////////////////////////////////////
40 : namespace alglib
41 : {
42 :
43 :
44 : }
45 :
46 : /////////////////////////////////////////////////////////////////////////
47 : //
48 : // THIS SECTION CONTAINS IMPLEMENTATION OF COMPUTATIONAL CORE
49 : //
50 : /////////////////////////////////////////////////////////////////////////
51 : namespace alglib_impl
52 : {
53 : #if defined(AE_COMPILE_SCODES) || !defined(AE_PARTIAL_BUILD)
54 :
55 :
56 : #endif
57 : #if defined(AE_COMPILE_APSERV) || !defined(AE_PARTIAL_BUILD)
58 :
59 :
60 : #endif
61 : #if defined(AE_COMPILE_TSORT) || !defined(AE_PARTIAL_BUILD)
62 : static void tsort_tagsortfastirec(/* Real */ ae_vector* a,
63 : /* Integer */ ae_vector* b,
64 : /* Real */ ae_vector* bufa,
65 : /* Integer */ ae_vector* bufb,
66 : ae_int_t i1,
67 : ae_int_t i2,
68 : ae_state *_state);
69 : static void tsort_tagsortfastrrec(/* Real */ ae_vector* a,
70 : /* Real */ ae_vector* b,
71 : /* Real */ ae_vector* bufa,
72 : /* Real */ ae_vector* bufb,
73 : ae_int_t i1,
74 : ae_int_t i2,
75 : ae_state *_state);
76 : static void tsort_tagsortfastrec(/* Real */ ae_vector* a,
77 : /* Real */ ae_vector* bufa,
78 : ae_int_t i1,
79 : ae_int_t i2,
80 : ae_state *_state);
81 :
82 :
83 : #endif
84 : #if defined(AE_COMPILE_ABLASF) || !defined(AE_PARTIAL_BUILD)
85 :
86 :
87 : #endif
88 : #if defined(AE_COMPILE_ABLASMKL) || !defined(AE_PARTIAL_BUILD)
89 :
90 :
91 : #endif
92 : #if defined(AE_COMPILE_CREFLECTIONS) || !defined(AE_PARTIAL_BUILD)
93 :
94 :
95 : #endif
96 : #if defined(AE_COMPILE_ROTATIONS) || !defined(AE_PARTIAL_BUILD)
97 :
98 :
99 : #endif
100 : #if defined(AE_COMPILE_TRLINSOLVE) || !defined(AE_PARTIAL_BUILD)
101 :
102 :
103 : #endif
104 : #if defined(AE_COMPILE_SAFESOLVE) || !defined(AE_PARTIAL_BUILD)
105 : static ae_bool safesolve_cbasicsolveandupdate(ae_complex alpha,
106 : ae_complex beta,
107 : double lnmax,
108 : double bnorm,
109 : double maxgrowth,
110 : double* xnorm,
111 : ae_complex* x,
112 : ae_state *_state);
113 :
114 :
115 : #endif
116 : #if defined(AE_COMPILE_HBLAS) || !defined(AE_PARTIAL_BUILD)
117 :
118 :
119 : #endif
120 : #if defined(AE_COMPILE_SBLAS) || !defined(AE_PARTIAL_BUILD)
121 :
122 :
123 : #endif
124 : #if defined(AE_COMPILE_BLAS) || !defined(AE_PARTIAL_BUILD)
125 :
126 :
127 : #endif
128 : #if defined(AE_COMPILE_LINMIN) || !defined(AE_PARTIAL_BUILD)
129 : static double linmin_ftol = 0.001;
130 : static double linmin_xtol = 100*ae_machineepsilon;
131 : static ae_int_t linmin_maxfev = 20;
132 : static double linmin_stpmin = 1.0E-50;
133 : static double linmin_defstpmax = 1.0E+50;
134 : static double linmin_armijofactor = 1.3;
135 : static void linmin_mcstep(double* stx,
136 : double* fx,
137 : double* dx,
138 : double* sty,
139 : double* fy,
140 : double* dy,
141 : double* stp,
142 : double fp,
143 : double dp,
144 : ae_bool* brackt,
145 : double stmin,
146 : double stmax,
147 : ae_int_t* info,
148 : ae_state *_state);
149 :
150 :
151 : #endif
152 : #if defined(AE_COMPILE_XBLAS) || !defined(AE_PARTIAL_BUILD)
153 : static void xblas_xsum(/* Real */ ae_vector* w,
154 : double mx,
155 : ae_int_t n,
156 : double* r,
157 : double* rerr,
158 : ae_state *_state);
159 : static double xblas_xfastpow(double r, ae_int_t n, ae_state *_state);
160 :
161 :
162 : #endif
163 : #if defined(AE_COMPILE_BASICSTATOPS) || !defined(AE_PARTIAL_BUILD)
164 :
165 :
166 : #endif
167 : #if defined(AE_COMPILE_HPCCORES) || !defined(AE_PARTIAL_BUILD)
168 : static ae_bool hpccores_hpcpreparechunkedgradientx(/* Real */ ae_vector* weights,
169 : ae_int_t wcount,
170 : /* Real */ ae_vector* hpcbuf,
171 : ae_state *_state);
172 : static ae_bool hpccores_hpcfinalizechunkedgradientx(/* Real */ ae_vector* buf,
173 : ae_int_t wcount,
174 : /* Real */ ae_vector* grad,
175 : ae_state *_state);
176 :
177 :
178 : #endif
179 : #if defined(AE_COMPILE_NTHEORY) || !defined(AE_PARTIAL_BUILD)
180 : static ae_bool ntheory_isprime(ae_int_t n, ae_state *_state);
181 : static ae_int_t ntheory_modmul(ae_int_t a,
182 : ae_int_t b,
183 : ae_int_t n,
184 : ae_state *_state);
185 : static ae_int_t ntheory_modexp(ae_int_t a,
186 : ae_int_t b,
187 : ae_int_t n,
188 : ae_state *_state);
189 :
190 :
191 : #endif
192 : #if defined(AE_COMPILE_FTBASE) || !defined(AE_PARTIAL_BUILD)
193 : static ae_int_t ftbase_coltype = 0;
194 : static ae_int_t ftbase_coloperandscnt = 1;
195 : static ae_int_t ftbase_coloperandsize = 2;
196 : static ae_int_t ftbase_colmicrovectorsize = 3;
197 : static ae_int_t ftbase_colparam0 = 4;
198 : static ae_int_t ftbase_colparam1 = 5;
199 : static ae_int_t ftbase_colparam2 = 6;
200 : static ae_int_t ftbase_colparam3 = 7;
201 : static ae_int_t ftbase_colscnt = 8;
202 : static ae_int_t ftbase_opend = 0;
203 : static ae_int_t ftbase_opcomplexreffft = 1;
204 : static ae_int_t ftbase_opbluesteinsfft = 2;
205 : static ae_int_t ftbase_opcomplexcodeletfft = 3;
206 : static ae_int_t ftbase_opcomplexcodelettwfft = 4;
207 : static ae_int_t ftbase_opradersfft = 5;
208 : static ae_int_t ftbase_opcomplextranspose = -1;
209 : static ae_int_t ftbase_opcomplexfftfactors = -2;
210 : static ae_int_t ftbase_opstart = -3;
211 : static ae_int_t ftbase_opjmp = -4;
212 : static ae_int_t ftbase_opparallelcall = -5;
213 : static ae_int_t ftbase_maxradix = 6;
214 : static ae_int_t ftbase_updatetw = 16;
215 : static ae_int_t ftbase_recursivethreshold = 1024;
216 : static ae_int_t ftbase_raderthreshold = 19;
217 : static ae_int_t ftbase_ftbasecodeletrecommended = 5;
218 : static double ftbase_ftbaseinefficiencyfactor = 1.3;
219 : static ae_int_t ftbase_ftbasemaxsmoothfactor = 5;
220 : static void ftbase_ftdeterminespacerequirements(ae_int_t n,
221 : ae_int_t* precrsize,
222 : ae_int_t* precisize,
223 : ae_state *_state);
224 : static void ftbase_ftcomplexfftplanrec(ae_int_t n,
225 : ae_int_t k,
226 : ae_bool childplan,
227 : ae_bool topmostplan,
228 : ae_int_t* rowptr,
229 : ae_int_t* bluesteinsize,
230 : ae_int_t* precrptr,
231 : ae_int_t* preciptr,
232 : fasttransformplan* plan,
233 : ae_state *_state);
234 : static void ftbase_ftpushentry(fasttransformplan* plan,
235 : ae_int_t* rowptr,
236 : ae_int_t etype,
237 : ae_int_t eopcnt,
238 : ae_int_t eopsize,
239 : ae_int_t emcvsize,
240 : ae_int_t eparam0,
241 : ae_state *_state);
242 : static void ftbase_ftpushentry2(fasttransformplan* plan,
243 : ae_int_t* rowptr,
244 : ae_int_t etype,
245 : ae_int_t eopcnt,
246 : ae_int_t eopsize,
247 : ae_int_t emcvsize,
248 : ae_int_t eparam0,
249 : ae_int_t eparam1,
250 : ae_state *_state);
251 : static void ftbase_ftpushentry4(fasttransformplan* plan,
252 : ae_int_t* rowptr,
253 : ae_int_t etype,
254 : ae_int_t eopcnt,
255 : ae_int_t eopsize,
256 : ae_int_t emcvsize,
257 : ae_int_t eparam0,
258 : ae_int_t eparam1,
259 : ae_int_t eparam2,
260 : ae_int_t eparam3,
261 : ae_state *_state);
262 : static void ftbase_ftapplysubplan(fasttransformplan* plan,
263 : ae_int_t subplan,
264 : /* Real */ ae_vector* a,
265 : ae_int_t abase,
266 : ae_int_t aoffset,
267 : /* Real */ ae_vector* buf,
268 : ae_int_t repcnt,
269 : ae_state *_state);
270 : static void ftbase_ftapplycomplexreffft(/* Real */ ae_vector* a,
271 : ae_int_t offs,
272 : ae_int_t operandscnt,
273 : ae_int_t operandsize,
274 : ae_int_t microvectorsize,
275 : /* Real */ ae_vector* buf,
276 : ae_state *_state);
277 : static void ftbase_ftapplycomplexcodeletfft(/* Real */ ae_vector* a,
278 : ae_int_t offs,
279 : ae_int_t operandscnt,
280 : ae_int_t operandsize,
281 : ae_int_t microvectorsize,
282 : ae_state *_state);
283 : static void ftbase_ftapplycomplexcodelettwfft(/* Real */ ae_vector* a,
284 : ae_int_t offs,
285 : ae_int_t operandscnt,
286 : ae_int_t operandsize,
287 : ae_int_t microvectorsize,
288 : ae_state *_state);
289 : static void ftbase_ftprecomputebluesteinsfft(ae_int_t n,
290 : ae_int_t m,
291 : /* Real */ ae_vector* precr,
292 : ae_int_t offs,
293 : ae_state *_state);
294 : static void ftbase_ftbluesteinsfft(fasttransformplan* plan,
295 : /* Real */ ae_vector* a,
296 : ae_int_t abase,
297 : ae_int_t aoffset,
298 : ae_int_t operandscnt,
299 : ae_int_t n,
300 : ae_int_t m,
301 : ae_int_t precoffs,
302 : ae_int_t subplan,
303 : /* Real */ ae_vector* bufa,
304 : /* Real */ ae_vector* bufb,
305 : /* Real */ ae_vector* bufc,
306 : /* Real */ ae_vector* bufd,
307 : ae_state *_state);
308 : static void ftbase_ftprecomputeradersfft(ae_int_t n,
309 : ae_int_t rq,
310 : ae_int_t riq,
311 : /* Real */ ae_vector* precr,
312 : ae_int_t offs,
313 : ae_state *_state);
314 : static void ftbase_ftradersfft(fasttransformplan* plan,
315 : /* Real */ ae_vector* a,
316 : ae_int_t abase,
317 : ae_int_t aoffset,
318 : ae_int_t operandscnt,
319 : ae_int_t n,
320 : ae_int_t subplan,
321 : ae_int_t rq,
322 : ae_int_t riq,
323 : ae_int_t precoffs,
324 : /* Real */ ae_vector* buf,
325 : ae_state *_state);
326 : static void ftbase_ftfactorize(ae_int_t n,
327 : ae_bool isroot,
328 : ae_int_t* n1,
329 : ae_int_t* n2,
330 : ae_state *_state);
331 : static ae_int_t ftbase_ftoptimisticestimate(ae_int_t n, ae_state *_state);
332 : static void ftbase_ffttwcalc(/* Real */ ae_vector* a,
333 : ae_int_t aoffset,
334 : ae_int_t n1,
335 : ae_int_t n2,
336 : ae_state *_state);
337 : static void ftbase_internalcomplexlintranspose(/* Real */ ae_vector* a,
338 : ae_int_t m,
339 : ae_int_t n,
340 : ae_int_t astart,
341 : /* Real */ ae_vector* buf,
342 : ae_state *_state);
343 : static void ftbase_ffticltrec(/* Real */ ae_vector* a,
344 : ae_int_t astart,
345 : ae_int_t astride,
346 : /* Real */ ae_vector* b,
347 : ae_int_t bstart,
348 : ae_int_t bstride,
349 : ae_int_t m,
350 : ae_int_t n,
351 : ae_state *_state);
352 : static void ftbase_fftirltrec(/* Real */ ae_vector* a,
353 : ae_int_t astart,
354 : ae_int_t astride,
355 : /* Real */ ae_vector* b,
356 : ae_int_t bstart,
357 : ae_int_t bstride,
358 : ae_int_t m,
359 : ae_int_t n,
360 : ae_state *_state);
361 : static void ftbase_ftbasefindsmoothrec(ae_int_t n,
362 : ae_int_t seed,
363 : ae_int_t leastfactor,
364 : ae_int_t* best,
365 : ae_state *_state);
366 :
367 :
368 : #endif
369 : #if defined(AE_COMPILE_NEARUNITYUNIT) || !defined(AE_PARTIAL_BUILD)
370 :
371 :
372 : #endif
373 : #if defined(AE_COMPILE_ALGLIBBASICS) || !defined(AE_PARTIAL_BUILD)
374 :
375 :
376 : #endif
377 :
378 : #if defined(AE_COMPILE_SCODES) || !defined(AE_PARTIAL_BUILD)
379 :
380 :
381 0 : ae_int_t getrdfserializationcode(ae_state *_state)
382 : {
383 : ae_int_t result;
384 :
385 :
386 0 : result = 1;
387 0 : return result;
388 : }
389 :
390 :
391 0 : ae_int_t getkdtreeserializationcode(ae_state *_state)
392 : {
393 : ae_int_t result;
394 :
395 :
396 0 : result = 2;
397 0 : return result;
398 : }
399 :
400 :
401 0 : ae_int_t getmlpserializationcode(ae_state *_state)
402 : {
403 : ae_int_t result;
404 :
405 :
406 0 : result = 3;
407 0 : return result;
408 : }
409 :
410 :
411 0 : ae_int_t getmlpeserializationcode(ae_state *_state)
412 : {
413 : ae_int_t result;
414 :
415 :
416 0 : result = 4;
417 0 : return result;
418 : }
419 :
420 :
421 0 : ae_int_t getrbfserializationcode(ae_state *_state)
422 : {
423 : ae_int_t result;
424 :
425 :
426 0 : result = 5;
427 0 : return result;
428 : }
429 :
430 :
431 0 : ae_int_t getspline2dserializationcode(ae_state *_state)
432 : {
433 : ae_int_t result;
434 :
435 :
436 0 : result = 6;
437 0 : return result;
438 : }
439 :
440 :
441 0 : ae_int_t getidwserializationcode(ae_state *_state)
442 : {
443 : ae_int_t result;
444 :
445 :
446 0 : result = 7;
447 0 : return result;
448 : }
449 :
450 :
451 0 : ae_int_t getknnserializationcode(ae_state *_state)
452 : {
453 : ae_int_t result;
454 :
455 :
456 0 : result = 108;
457 0 : return result;
458 : }
459 :
460 :
461 : #endif
462 : #if defined(AE_COMPILE_APSERV) || !defined(AE_PARTIAL_BUILD)
463 :
464 :
465 : /*************************************************************************
466 : Internally calls SetErrorFlag() with condition:
467 :
468 : Abs(Val-RefVal)>Tol*Max(Abs(RefVal),S)
469 :
470 : This function is used to test relative error in Val against RefVal, with
471 : relative error being replaced by absolute when scale of RefVal is less
472 : than S.
473 :
474 : This function returns value of COND.
475 : *************************************************************************/
476 0 : void seterrorflagdiff(ae_bool* flag,
477 : double val,
478 : double refval,
479 : double tol,
480 : double s,
481 : ae_state *_state)
482 : {
483 :
484 :
485 0 : ae_set_error_flag(flag, ae_fp_greater(ae_fabs(val-refval, _state),tol*ae_maxreal(ae_fabs(refval, _state), s, _state)), __FILE__, __LINE__, "apserv.ap:162");
486 0 : }
487 :
488 :
489 : /*************************************************************************
490 : The function always returns False.
491 : It may be used sometimes to prevent spurious warnings.
492 :
493 : -- ALGLIB --
494 : Copyright 17.09.2012 by Bochkanov Sergey
495 : *************************************************************************/
496 0 : ae_bool alwaysfalse(ae_state *_state)
497 : {
498 : ae_bool result;
499 :
500 :
501 0 : result = ae_false;
502 0 : return result;
503 : }
504 :
505 :
506 : /*************************************************************************
507 : The function "touches" integer - it is used to avoid compiler messages
508 : about unused variables (in rare cases when we do NOT want to remove these
509 : variables).
510 :
511 : -- ALGLIB --
512 : Copyright 17.09.2012 by Bochkanov Sergey
513 : *************************************************************************/
514 0 : void touchint(ae_int_t* a, ae_state *_state)
515 : {
516 :
517 :
518 0 : }
519 :
520 :
521 : /*************************************************************************
522 : The function "touches" real - it is used to avoid compiler messages
523 : about unused variables (in rare cases when we do NOT want to remove these
524 : variables).
525 :
526 : -- ALGLIB --
527 : Copyright 17.09.2012 by Bochkanov Sergey
528 : *************************************************************************/
529 0 : void touchreal(double* a, ae_state *_state)
530 : {
531 :
532 :
533 0 : }
534 :
535 :
536 : /*************************************************************************
537 : The function performs zero-coalescing on real value.
538 :
539 : NOTE: no check is performed for B<>0
540 :
541 : -- ALGLIB --
542 : Copyright 18.05.2015 by Bochkanov Sergey
543 : *************************************************************************/
544 0 : double coalesce(double a, double b, ae_state *_state)
545 : {
546 : double result;
547 :
548 :
549 0 : result = a;
550 0 : if( ae_fp_eq(a,0.0) )
551 : {
552 0 : result = b;
553 : }
554 0 : return result;
555 : }
556 :
557 :
558 : /*************************************************************************
559 : The function performs zero-coalescing on integer value.
560 :
561 : NOTE: no check is performed for B<>0
562 :
563 : -- ALGLIB --
564 : Copyright 18.05.2015 by Bochkanov Sergey
565 : *************************************************************************/
566 0 : ae_int_t coalescei(ae_int_t a, ae_int_t b, ae_state *_state)
567 : {
568 : ae_int_t result;
569 :
570 :
571 0 : result = a;
572 0 : if( a==0 )
573 : {
574 0 : result = b;
575 : }
576 0 : return result;
577 : }
578 :
579 :
580 : /*************************************************************************
581 : The function convert integer value to real value.
582 :
583 : -- ALGLIB --
584 : Copyright 17.09.2012 by Bochkanov Sergey
585 : *************************************************************************/
586 0 : double inttoreal(ae_int_t a, ae_state *_state)
587 : {
588 : double result;
589 :
590 :
591 0 : result = (double)(a);
592 0 : return result;
593 : }
594 :
595 :
596 : /*************************************************************************
597 : The function calculates binary logarithm.
598 :
599 : NOTE: it costs twice as much as Ln(x)
600 :
601 : -- ALGLIB --
602 : Copyright 17.09.2012 by Bochkanov Sergey
603 : *************************************************************************/
604 0 : double logbase2(double x, ae_state *_state)
605 : {
606 : double result;
607 :
608 :
609 0 : result = ae_log(x, _state)/ae_log((double)(2), _state);
610 0 : return result;
611 : }
612 :
613 :
614 : /*************************************************************************
615 : This function compares two numbers for approximate equality, with tolerance
616 : to errors as large as tol.
617 :
618 :
619 : -- ALGLIB --
620 : Copyright 02.12.2009 by Bochkanov Sergey
621 : *************************************************************************/
622 0 : ae_bool approxequal(double a, double b, double tol, ae_state *_state)
623 : {
624 : ae_bool result;
625 :
626 :
627 0 : result = ae_fp_less_eq(ae_fabs(a-b, _state),tol);
628 0 : return result;
629 : }
630 :
631 :
632 : /*************************************************************************
633 : This function compares two numbers for approximate equality, with tolerance
634 : to errors as large as max(|a|,|b|)*tol.
635 :
636 :
637 : -- ALGLIB --
638 : Copyright 02.12.2009 by Bochkanov Sergey
639 : *************************************************************************/
640 0 : ae_bool approxequalrel(double a, double b, double tol, ae_state *_state)
641 : {
642 : ae_bool result;
643 :
644 :
645 0 : result = ae_fp_less_eq(ae_fabs(a-b, _state),ae_maxreal(ae_fabs(a, _state), ae_fabs(b, _state), _state)*tol);
646 0 : return result;
647 : }
648 :
649 :
650 : /*************************************************************************
651 : This function generates 1-dimensional general interpolation task with
652 : moderate Lipshitz constant (close to 1.0)
653 :
654 : If N=1 then suborutine generates only one point at the middle of [A,B]
655 :
656 : -- ALGLIB --
657 : Copyright 02.12.2009 by Bochkanov Sergey
658 : *************************************************************************/
659 0 : void taskgenint1d(double a,
660 : double b,
661 : ae_int_t n,
662 : /* Real */ ae_vector* x,
663 : /* Real */ ae_vector* y,
664 : ae_state *_state)
665 : {
666 : ae_int_t i;
667 : double h;
668 :
669 0 : ae_vector_clear(x);
670 0 : ae_vector_clear(y);
671 :
672 0 : ae_assert(n>=1, "TaskGenInterpolationEqdist1D: N<1!", _state);
673 0 : ae_vector_set_length(x, n, _state);
674 0 : ae_vector_set_length(y, n, _state);
675 0 : if( n>1 )
676 : {
677 0 : x->ptr.p_double[0] = a;
678 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
679 0 : h = (b-a)/(n-1);
680 0 : for(i=1; i<=n-1; i++)
681 : {
682 0 : if( i!=n-1 )
683 : {
684 0 : x->ptr.p_double[i] = a+(i+0.2*(2*ae_randomreal(_state)-1))*h;
685 : }
686 : else
687 : {
688 0 : x->ptr.p_double[i] = b;
689 : }
690 0 : y->ptr.p_double[i] = y->ptr.p_double[i-1]+(2*ae_randomreal(_state)-1)*(x->ptr.p_double[i]-x->ptr.p_double[i-1]);
691 : }
692 : }
693 : else
694 : {
695 0 : x->ptr.p_double[0] = 0.5*(a+b);
696 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
697 : }
698 0 : }
699 :
700 :
701 : /*************************************************************************
702 : This function generates 1-dimensional equidistant interpolation task with
703 : moderate Lipshitz constant (close to 1.0)
704 :
705 : If N=1 then suborutine generates only one point at the middle of [A,B]
706 :
707 : -- ALGLIB --
708 : Copyright 02.12.2009 by Bochkanov Sergey
709 : *************************************************************************/
710 0 : void taskgenint1dequidist(double a,
711 : double b,
712 : ae_int_t n,
713 : /* Real */ ae_vector* x,
714 : /* Real */ ae_vector* y,
715 : ae_state *_state)
716 : {
717 : ae_int_t i;
718 : double h;
719 :
720 0 : ae_vector_clear(x);
721 0 : ae_vector_clear(y);
722 :
723 0 : ae_assert(n>=1, "TaskGenInterpolationEqdist1D: N<1!", _state);
724 0 : ae_vector_set_length(x, n, _state);
725 0 : ae_vector_set_length(y, n, _state);
726 0 : if( n>1 )
727 : {
728 0 : x->ptr.p_double[0] = a;
729 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
730 0 : h = (b-a)/(n-1);
731 0 : for(i=1; i<=n-1; i++)
732 : {
733 0 : x->ptr.p_double[i] = a+i*h;
734 0 : y->ptr.p_double[i] = y->ptr.p_double[i-1]+(2*ae_randomreal(_state)-1)*h;
735 : }
736 : }
737 : else
738 : {
739 0 : x->ptr.p_double[0] = 0.5*(a+b);
740 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
741 : }
742 0 : }
743 :
744 :
745 : /*************************************************************************
746 : This function generates 1-dimensional Chebyshev-1 interpolation task with
747 : moderate Lipshitz constant (close to 1.0)
748 :
749 : If N=1 then suborutine generates only one point at the middle of [A,B]
750 :
751 : -- ALGLIB --
752 : Copyright 02.12.2009 by Bochkanov Sergey
753 : *************************************************************************/
754 0 : void taskgenint1dcheb1(double a,
755 : double b,
756 : ae_int_t n,
757 : /* Real */ ae_vector* x,
758 : /* Real */ ae_vector* y,
759 : ae_state *_state)
760 : {
761 : ae_int_t i;
762 :
763 0 : ae_vector_clear(x);
764 0 : ae_vector_clear(y);
765 :
766 0 : ae_assert(n>=1, "TaskGenInterpolation1DCheb1: N<1!", _state);
767 0 : ae_vector_set_length(x, n, _state);
768 0 : ae_vector_set_length(y, n, _state);
769 0 : if( n>1 )
770 : {
771 0 : for(i=0; i<=n-1; i++)
772 : {
773 0 : x->ptr.p_double[i] = 0.5*(b+a)+0.5*(b-a)*ae_cos(ae_pi*(2*i+1)/(2*n), _state);
774 0 : if( i==0 )
775 : {
776 0 : y->ptr.p_double[i] = 2*ae_randomreal(_state)-1;
777 : }
778 : else
779 : {
780 0 : y->ptr.p_double[i] = y->ptr.p_double[i-1]+(2*ae_randomreal(_state)-1)*(x->ptr.p_double[i]-x->ptr.p_double[i-1]);
781 : }
782 : }
783 : }
784 : else
785 : {
786 0 : x->ptr.p_double[0] = 0.5*(a+b);
787 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
788 : }
789 0 : }
790 :
791 :
792 : /*************************************************************************
793 : This function generates 1-dimensional Chebyshev-2 interpolation task with
794 : moderate Lipshitz constant (close to 1.0)
795 :
796 : If N=1 then suborutine generates only one point at the middle of [A,B]
797 :
798 : -- ALGLIB --
799 : Copyright 02.12.2009 by Bochkanov Sergey
800 : *************************************************************************/
801 0 : void taskgenint1dcheb2(double a,
802 : double b,
803 : ae_int_t n,
804 : /* Real */ ae_vector* x,
805 : /* Real */ ae_vector* y,
806 : ae_state *_state)
807 : {
808 : ae_int_t i;
809 :
810 0 : ae_vector_clear(x);
811 0 : ae_vector_clear(y);
812 :
813 0 : ae_assert(n>=1, "TaskGenInterpolation1DCheb2: N<1!", _state);
814 0 : ae_vector_set_length(x, n, _state);
815 0 : ae_vector_set_length(y, n, _state);
816 0 : if( n>1 )
817 : {
818 0 : for(i=0; i<=n-1; i++)
819 : {
820 0 : x->ptr.p_double[i] = 0.5*(b+a)+0.5*(b-a)*ae_cos(ae_pi*i/(n-1), _state);
821 0 : if( i==0 )
822 : {
823 0 : y->ptr.p_double[i] = 2*ae_randomreal(_state)-1;
824 : }
825 : else
826 : {
827 0 : y->ptr.p_double[i] = y->ptr.p_double[i-1]+(2*ae_randomreal(_state)-1)*(x->ptr.p_double[i]-x->ptr.p_double[i-1]);
828 : }
829 : }
830 : }
831 : else
832 : {
833 0 : x->ptr.p_double[0] = 0.5*(a+b);
834 0 : y->ptr.p_double[0] = 2*ae_randomreal(_state)-1;
835 : }
836 0 : }
837 :
838 :
839 : /*************************************************************************
840 : This function checks that all values from X[] are distinct. It does more
841 : than just usual floating point comparison:
842 : * first, it calculates max(X) and min(X)
843 : * second, it maps X[] from [min,max] to [1,2]
844 : * only at this stage actual comparison is done
845 :
846 : The meaning of such check is to ensure that all values are "distinct enough"
847 : and will not cause interpolation subroutine to fail.
848 :
849 : NOTE:
850 : X[] must be sorted by ascending (subroutine ASSERT's it)
851 :
852 : -- ALGLIB --
853 : Copyright 02.12.2009 by Bochkanov Sergey
854 : *************************************************************************/
855 0 : ae_bool aredistinct(/* Real */ ae_vector* x,
856 : ae_int_t n,
857 : ae_state *_state)
858 : {
859 : double a;
860 : double b;
861 : ae_int_t i;
862 : ae_bool nonsorted;
863 : ae_bool result;
864 :
865 :
866 0 : ae_assert(n>=1, "APSERVAreDistinct: internal error (N<1)", _state);
867 0 : if( n==1 )
868 : {
869 :
870 : /*
871 : * everything is alright, it is up to caller to decide whether it
872 : * can interpolate something with just one point
873 : */
874 0 : result = ae_true;
875 0 : return result;
876 : }
877 0 : a = x->ptr.p_double[0];
878 0 : b = x->ptr.p_double[0];
879 0 : nonsorted = ae_false;
880 0 : for(i=1; i<=n-1; i++)
881 : {
882 0 : a = ae_minreal(a, x->ptr.p_double[i], _state);
883 0 : b = ae_maxreal(b, x->ptr.p_double[i], _state);
884 0 : nonsorted = nonsorted||ae_fp_greater_eq(x->ptr.p_double[i-1],x->ptr.p_double[i]);
885 : }
886 0 : ae_assert(!nonsorted, "APSERVAreDistinct: internal error (not sorted)", _state);
887 0 : for(i=1; i<=n-1; i++)
888 : {
889 0 : if( ae_fp_eq((x->ptr.p_double[i]-a)/(b-a)+1,(x->ptr.p_double[i-1]-a)/(b-a)+1) )
890 : {
891 0 : result = ae_false;
892 0 : return result;
893 : }
894 : }
895 0 : result = ae_true;
896 0 : return result;
897 : }
898 :
899 :
900 : /*************************************************************************
901 : This function checks that two boolean values are the same (both are True
902 : or both are False).
903 :
904 : -- ALGLIB --
905 : Copyright 02.12.2009 by Bochkanov Sergey
906 : *************************************************************************/
907 0 : ae_bool aresameboolean(ae_bool v1, ae_bool v2, ae_state *_state)
908 : {
909 : ae_bool result;
910 :
911 :
912 0 : result = (v1&&v2)||(!v1&&!v2);
913 0 : return result;
914 : }
915 :
916 :
917 : /*************************************************************************
918 : Resizes X and fills by zeros
919 :
920 : -- ALGLIB --
921 : Copyright 20.03.2009 by Bochkanov Sergey
922 : *************************************************************************/
923 0 : void setlengthzero(/* Real */ ae_vector* x,
924 : ae_int_t n,
925 : ae_state *_state)
926 : {
927 : ae_int_t i;
928 :
929 :
930 0 : ae_assert(n>=0, "SetLengthZero: N<0", _state);
931 0 : ae_vector_set_length(x, n, _state);
932 0 : for(i=0; i<=n-1; i++)
933 : {
934 0 : x->ptr.p_double[i] = (double)(0);
935 : }
936 0 : }
937 :
938 :
939 : /*************************************************************************
940 : If Length(X)<N, resizes X
941 :
942 : -- ALGLIB --
943 : Copyright 20.03.2009 by Bochkanov Sergey
944 : *************************************************************************/
945 0 : void bvectorsetlengthatleast(/* Boolean */ ae_vector* x,
946 : ae_int_t n,
947 : ae_state *_state)
948 : {
949 :
950 :
951 0 : if( x->cnt<n )
952 : {
953 0 : ae_vector_set_length(x, n, _state);
954 : }
955 0 : }
956 :
957 :
958 : /*************************************************************************
959 : If Length(X)<N, resizes X
960 :
961 : -- ALGLIB --
962 : Copyright 20.03.2009 by Bochkanov Sergey
963 : *************************************************************************/
964 0 : void ivectorsetlengthatleast(/* Integer */ ae_vector* x,
965 : ae_int_t n,
966 : ae_state *_state)
967 : {
968 :
969 :
970 0 : if( x->cnt<n )
971 : {
972 0 : ae_vector_set_length(x, n, _state);
973 : }
974 0 : }
975 :
976 :
977 : /*************************************************************************
978 : If Length(X)<N, resizes X
979 :
980 : -- ALGLIB --
981 : Copyright 20.03.2009 by Bochkanov Sergey
982 : *************************************************************************/
983 0 : void rvectorsetlengthatleast(/* Real */ ae_vector* x,
984 : ae_int_t n,
985 : ae_state *_state)
986 : {
987 :
988 :
989 0 : if( x->cnt<n )
990 : {
991 0 : ae_vector_set_length(x, n, _state);
992 : }
993 0 : }
994 :
995 :
996 : /*************************************************************************
997 : If Cols(X)<N or Rows(X)<M, resizes X
998 :
999 : -- ALGLIB --
1000 : Copyright 20.03.2009 by Bochkanov Sergey
1001 : *************************************************************************/
1002 0 : void rmatrixsetlengthatleast(/* Real */ ae_matrix* x,
1003 : ae_int_t m,
1004 : ae_int_t n,
1005 : ae_state *_state)
1006 : {
1007 :
1008 :
1009 0 : if( m>0&&n>0 )
1010 : {
1011 0 : if( x->rows<m||x->cols<n )
1012 : {
1013 0 : ae_matrix_set_length(x, m, n, _state);
1014 : }
1015 : }
1016 0 : }
1017 :
1018 :
1019 : /*************************************************************************
1020 : If Cols(X)<N or Rows(X)<M, resizes X
1021 :
1022 : -- ALGLIB --
1023 : Copyright 20.03.2009 by Bochkanov Sergey
1024 : *************************************************************************/
1025 0 : void bmatrixsetlengthatleast(/* Boolean */ ae_matrix* x,
1026 : ae_int_t m,
1027 : ae_int_t n,
1028 : ae_state *_state)
1029 : {
1030 :
1031 :
1032 0 : if( m>0&&n>0 )
1033 : {
1034 0 : if( x->rows<m||x->cols<n )
1035 : {
1036 0 : ae_matrix_set_length(x, m, n, _state);
1037 : }
1038 : }
1039 0 : }
1040 :
1041 :
1042 : /*************************************************************************
1043 : Grows X, i.e. changes its size in such a way that:
1044 : a) contents is preserved
1045 : b) new size is at least N
1046 : c) new size can be larger than N, so subsequent grow() calls can return
1047 : without reallocation
1048 :
1049 : -- ALGLIB --
1050 : Copyright 20.03.2009 by Bochkanov Sergey
1051 : *************************************************************************/
1052 0 : void bvectorgrowto(/* Boolean */ ae_vector* x,
1053 : ae_int_t n,
1054 : ae_state *_state)
1055 : {
1056 : ae_frame _frame_block;
1057 : ae_vector oldx;
1058 : ae_int_t i;
1059 : ae_int_t n2;
1060 :
1061 0 : ae_frame_make(_state, &_frame_block);
1062 0 : memset(&oldx, 0, sizeof(oldx));
1063 0 : ae_vector_init(&oldx, 0, DT_BOOL, _state, ae_true);
1064 :
1065 :
1066 : /*
1067 : * Enough place
1068 : */
1069 0 : if( x->cnt>=n )
1070 : {
1071 0 : ae_frame_leave(_state);
1072 0 : return;
1073 : }
1074 :
1075 : /*
1076 : * Choose new size
1077 : */
1078 0 : n = ae_maxint(n, ae_round(1.8*x->cnt+1, _state), _state);
1079 :
1080 : /*
1081 : * Grow
1082 : */
1083 0 : n2 = x->cnt;
1084 0 : ae_swap_vectors(x, &oldx);
1085 0 : ae_vector_set_length(x, n, _state);
1086 0 : for(i=0; i<=n-1; i++)
1087 : {
1088 0 : if( i<n2 )
1089 : {
1090 0 : x->ptr.p_bool[i] = oldx.ptr.p_bool[i];
1091 : }
1092 : else
1093 : {
1094 0 : x->ptr.p_bool[i] = ae_false;
1095 : }
1096 : }
1097 0 : ae_frame_leave(_state);
1098 : }
1099 :
1100 :
1101 : /*************************************************************************
1102 : Grows X, i.e. changes its size in such a way that:
1103 : a) contents is preserved
1104 : b) new size is at least N
1105 : c) new size can be larger than N, so subsequent grow() calls can return
1106 : without reallocation
1107 :
1108 : -- ALGLIB --
1109 : Copyright 20.03.2009 by Bochkanov Sergey
1110 : *************************************************************************/
1111 0 : void ivectorgrowto(/* Integer */ ae_vector* x,
1112 : ae_int_t n,
1113 : ae_state *_state)
1114 : {
1115 : ae_frame _frame_block;
1116 : ae_vector oldx;
1117 : ae_int_t i;
1118 : ae_int_t n2;
1119 :
1120 0 : ae_frame_make(_state, &_frame_block);
1121 0 : memset(&oldx, 0, sizeof(oldx));
1122 0 : ae_vector_init(&oldx, 0, DT_INT, _state, ae_true);
1123 :
1124 :
1125 : /*
1126 : * Enough place
1127 : */
1128 0 : if( x->cnt>=n )
1129 : {
1130 0 : ae_frame_leave(_state);
1131 0 : return;
1132 : }
1133 :
1134 : /*
1135 : * Choose new size
1136 : */
1137 0 : n = ae_maxint(n, ae_round(1.8*x->cnt+1, _state), _state);
1138 :
1139 : /*
1140 : * Grow
1141 : */
1142 0 : n2 = x->cnt;
1143 0 : ae_swap_vectors(x, &oldx);
1144 0 : ae_vector_set_length(x, n, _state);
1145 0 : for(i=0; i<=n-1; i++)
1146 : {
1147 0 : if( i<n2 )
1148 : {
1149 0 : x->ptr.p_int[i] = oldx.ptr.p_int[i];
1150 : }
1151 : else
1152 : {
1153 0 : x->ptr.p_int[i] = 0;
1154 : }
1155 : }
1156 0 : ae_frame_leave(_state);
1157 : }
1158 :
1159 :
1160 : /*************************************************************************
1161 : Grows X, i.e. appends rows in such a way that:
1162 : a) contents is preserved
1163 : b) new row count is at least N
1164 : c) new row count can be larger than N, so subsequent grow() calls can return
1165 : without reallocation
1166 : d) new matrix has at least MinCols columns (if less than specified amount
1167 : of columns is present, new columns are added with undefined contents);
1168 : MinCols can be 0 or negative value = ignored
1169 :
1170 : -- ALGLIB --
1171 : Copyright 20.03.2009 by Bochkanov Sergey
1172 : *************************************************************************/
1173 0 : void rmatrixgrowrowsto(/* Real */ ae_matrix* a,
1174 : ae_int_t n,
1175 : ae_int_t mincols,
1176 : ae_state *_state)
1177 : {
1178 : ae_frame _frame_block;
1179 : ae_matrix olda;
1180 : ae_int_t i;
1181 : ae_int_t j;
1182 : ae_int_t n2;
1183 : ae_int_t m;
1184 :
1185 0 : ae_frame_make(_state, &_frame_block);
1186 0 : memset(&olda, 0, sizeof(olda));
1187 0 : ae_matrix_init(&olda, 0, 0, DT_REAL, _state, ae_true);
1188 :
1189 :
1190 : /*
1191 : * Enough place?
1192 : */
1193 0 : if( a->rows>=n&&a->cols>=mincols )
1194 : {
1195 0 : ae_frame_leave(_state);
1196 0 : return;
1197 : }
1198 :
1199 : /*
1200 : * Sizes and metrics
1201 : */
1202 0 : if( a->rows<n )
1203 : {
1204 0 : n = ae_maxint(n, ae_round(1.8*a->rows+1, _state), _state);
1205 : }
1206 0 : n2 = ae_minint(a->rows, n, _state);
1207 0 : m = a->cols;
1208 :
1209 : /*
1210 : * Grow
1211 : */
1212 0 : ae_swap_matrices(a, &olda);
1213 0 : ae_matrix_set_length(a, n, ae_maxint(m, mincols, _state), _state);
1214 0 : for(i=0; i<=n2-1; i++)
1215 : {
1216 0 : for(j=0; j<=m-1; j++)
1217 : {
1218 0 : a->ptr.pp_double[i][j] = olda.ptr.pp_double[i][j];
1219 : }
1220 : }
1221 0 : ae_frame_leave(_state);
1222 : }
1223 :
1224 :
1225 : /*************************************************************************
1226 : Grows X, i.e. appends cols in such a way that:
1227 : a) contents is preserved
1228 : b) new col count is at least N
1229 : c) new col count can be larger than N, so subsequent grow() calls can return
1230 : without reallocation
1231 : d) new matrix has at least MinRows row (if less than specified amount
1232 : of rows is present, new rows are added with undefined contents);
1233 : MinRows can be 0 or negative value = ignored
1234 :
1235 : -- ALGLIB --
1236 : Copyright 20.03.2009 by Bochkanov Sergey
1237 : *************************************************************************/
1238 0 : void rmatrixgrowcolsto(/* Real */ ae_matrix* a,
1239 : ae_int_t n,
1240 : ae_int_t minrows,
1241 : ae_state *_state)
1242 : {
1243 : ae_frame _frame_block;
1244 : ae_matrix olda;
1245 : ae_int_t i;
1246 : ae_int_t j;
1247 : ae_int_t n2;
1248 : ae_int_t m;
1249 :
1250 0 : ae_frame_make(_state, &_frame_block);
1251 0 : memset(&olda, 0, sizeof(olda));
1252 0 : ae_matrix_init(&olda, 0, 0, DT_REAL, _state, ae_true);
1253 :
1254 :
1255 : /*
1256 : * Enough place?
1257 : */
1258 0 : if( a->cols>=n&&a->rows>=minrows )
1259 : {
1260 0 : ae_frame_leave(_state);
1261 0 : return;
1262 : }
1263 :
1264 : /*
1265 : * Sizes and metrics
1266 : */
1267 0 : if( a->cols<n )
1268 : {
1269 0 : n = ae_maxint(n, ae_round(1.8*a->cols+1, _state), _state);
1270 : }
1271 0 : n2 = ae_minint(a->cols, n, _state);
1272 0 : m = a->rows;
1273 :
1274 : /*
1275 : * Grow
1276 : */
1277 0 : ae_swap_matrices(a, &olda);
1278 0 : ae_matrix_set_length(a, ae_maxint(m, minrows, _state), n, _state);
1279 0 : for(i=0; i<=m-1; i++)
1280 : {
1281 0 : for(j=0; j<=n2-1; j++)
1282 : {
1283 0 : a->ptr.pp_double[i][j] = olda.ptr.pp_double[i][j];
1284 : }
1285 : }
1286 0 : ae_frame_leave(_state);
1287 : }
1288 :
1289 :
1290 : /*************************************************************************
1291 : Grows X, i.e. changes its size in such a way that:
1292 : a) contents is preserved
1293 : b) new size is at least N
1294 : c) new size can be larger than N, so subsequent grow() calls can return
1295 : without reallocation
1296 :
1297 : -- ALGLIB --
1298 : Copyright 20.03.2009 by Bochkanov Sergey
1299 : *************************************************************************/
1300 0 : void rvectorgrowto(/* Real */ ae_vector* x,
1301 : ae_int_t n,
1302 : ae_state *_state)
1303 : {
1304 : ae_frame _frame_block;
1305 : ae_vector oldx;
1306 : ae_int_t i;
1307 : ae_int_t n2;
1308 :
1309 0 : ae_frame_make(_state, &_frame_block);
1310 0 : memset(&oldx, 0, sizeof(oldx));
1311 0 : ae_vector_init(&oldx, 0, DT_REAL, _state, ae_true);
1312 :
1313 :
1314 : /*
1315 : * Enough place
1316 : */
1317 0 : if( x->cnt>=n )
1318 : {
1319 0 : ae_frame_leave(_state);
1320 0 : return;
1321 : }
1322 :
1323 : /*
1324 : * Choose new size
1325 : */
1326 0 : n = ae_maxint(n, ae_round(1.8*x->cnt+1, _state), _state);
1327 :
1328 : /*
1329 : * Grow
1330 : */
1331 0 : n2 = x->cnt;
1332 0 : ae_swap_vectors(x, &oldx);
1333 0 : ae_vector_set_length(x, n, _state);
1334 0 : for(i=0; i<=n-1; i++)
1335 : {
1336 0 : if( i<n2 )
1337 : {
1338 0 : x->ptr.p_double[i] = oldx.ptr.p_double[i];
1339 : }
1340 : else
1341 : {
1342 0 : x->ptr.p_double[i] = (double)(0);
1343 : }
1344 : }
1345 0 : ae_frame_leave(_state);
1346 : }
1347 :
1348 :
1349 : /*************************************************************************
1350 : Resizes X and:
1351 : * preserves old contents of X
1352 : * fills new elements by zeros
1353 :
1354 : -- ALGLIB --
1355 : Copyright 20.03.2009 by Bochkanov Sergey
1356 : *************************************************************************/
1357 0 : void ivectorresize(/* Integer */ ae_vector* x,
1358 : ae_int_t n,
1359 : ae_state *_state)
1360 : {
1361 : ae_frame _frame_block;
1362 : ae_vector oldx;
1363 : ae_int_t i;
1364 : ae_int_t n2;
1365 :
1366 0 : ae_frame_make(_state, &_frame_block);
1367 0 : memset(&oldx, 0, sizeof(oldx));
1368 0 : ae_vector_init(&oldx, 0, DT_INT, _state, ae_true);
1369 :
1370 0 : n2 = x->cnt;
1371 0 : ae_swap_vectors(x, &oldx);
1372 0 : ae_vector_set_length(x, n, _state);
1373 0 : for(i=0; i<=n-1; i++)
1374 : {
1375 0 : if( i<n2 )
1376 : {
1377 0 : x->ptr.p_int[i] = oldx.ptr.p_int[i];
1378 : }
1379 : else
1380 : {
1381 0 : x->ptr.p_int[i] = 0;
1382 : }
1383 : }
1384 0 : ae_frame_leave(_state);
1385 0 : }
1386 :
1387 :
1388 : /*************************************************************************
1389 : Resizes X and:
1390 : * preserves old contents of X
1391 : * fills new elements by zeros
1392 :
1393 : -- ALGLIB --
1394 : Copyright 20.03.2009 by Bochkanov Sergey
1395 : *************************************************************************/
1396 0 : void rvectorresize(/* Real */ ae_vector* x,
1397 : ae_int_t n,
1398 : ae_state *_state)
1399 : {
1400 : ae_frame _frame_block;
1401 : ae_vector oldx;
1402 : ae_int_t i;
1403 : ae_int_t n2;
1404 :
1405 0 : ae_frame_make(_state, &_frame_block);
1406 0 : memset(&oldx, 0, sizeof(oldx));
1407 0 : ae_vector_init(&oldx, 0, DT_REAL, _state, ae_true);
1408 :
1409 0 : n2 = x->cnt;
1410 0 : ae_swap_vectors(x, &oldx);
1411 0 : ae_vector_set_length(x, n, _state);
1412 0 : for(i=0; i<=n-1; i++)
1413 : {
1414 0 : if( i<n2 )
1415 : {
1416 0 : x->ptr.p_double[i] = oldx.ptr.p_double[i];
1417 : }
1418 : else
1419 : {
1420 0 : x->ptr.p_double[i] = (double)(0);
1421 : }
1422 : }
1423 0 : ae_frame_leave(_state);
1424 0 : }
1425 :
1426 :
1427 : /*************************************************************************
1428 : Resizes X and:
1429 : * preserves old contents of X
1430 : * fills new elements by zeros
1431 :
1432 : -- ALGLIB --
1433 : Copyright 20.03.2009 by Bochkanov Sergey
1434 : *************************************************************************/
1435 0 : void rmatrixresize(/* Real */ ae_matrix* x,
1436 : ae_int_t m,
1437 : ae_int_t n,
1438 : ae_state *_state)
1439 : {
1440 : ae_frame _frame_block;
1441 : ae_matrix oldx;
1442 : ae_int_t i;
1443 : ae_int_t j;
1444 : ae_int_t m2;
1445 : ae_int_t n2;
1446 :
1447 0 : ae_frame_make(_state, &_frame_block);
1448 0 : memset(&oldx, 0, sizeof(oldx));
1449 0 : ae_matrix_init(&oldx, 0, 0, DT_REAL, _state, ae_true);
1450 :
1451 0 : m2 = x->rows;
1452 0 : n2 = x->cols;
1453 0 : ae_swap_matrices(x, &oldx);
1454 0 : ae_matrix_set_length(x, m, n, _state);
1455 0 : for(i=0; i<=m-1; i++)
1456 : {
1457 0 : for(j=0; j<=n-1; j++)
1458 : {
1459 0 : if( i<m2&&j<n2 )
1460 : {
1461 0 : x->ptr.pp_double[i][j] = oldx.ptr.pp_double[i][j];
1462 : }
1463 : else
1464 : {
1465 0 : x->ptr.pp_double[i][j] = 0.0;
1466 : }
1467 : }
1468 : }
1469 0 : ae_frame_leave(_state);
1470 0 : }
1471 :
1472 :
1473 : /*************************************************************************
1474 : Resizes X and:
1475 : * preserves old contents of X
1476 : * fills new elements by zeros
1477 :
1478 : -- ALGLIB --
1479 : Copyright 20.03.2009 by Bochkanov Sergey
1480 : *************************************************************************/
1481 0 : void imatrixresize(/* Integer */ ae_matrix* x,
1482 : ae_int_t m,
1483 : ae_int_t n,
1484 : ae_state *_state)
1485 : {
1486 : ae_frame _frame_block;
1487 : ae_matrix oldx;
1488 : ae_int_t i;
1489 : ae_int_t j;
1490 : ae_int_t m2;
1491 : ae_int_t n2;
1492 :
1493 0 : ae_frame_make(_state, &_frame_block);
1494 0 : memset(&oldx, 0, sizeof(oldx));
1495 0 : ae_matrix_init(&oldx, 0, 0, DT_INT, _state, ae_true);
1496 :
1497 0 : m2 = x->rows;
1498 0 : n2 = x->cols;
1499 0 : ae_swap_matrices(x, &oldx);
1500 0 : ae_matrix_set_length(x, m, n, _state);
1501 0 : for(i=0; i<=m-1; i++)
1502 : {
1503 0 : for(j=0; j<=n-1; j++)
1504 : {
1505 0 : if( i<m2&&j<n2 )
1506 : {
1507 0 : x->ptr.pp_int[i][j] = oldx.ptr.pp_int[i][j];
1508 : }
1509 : else
1510 : {
1511 0 : x->ptr.pp_int[i][j] = 0;
1512 : }
1513 : }
1514 : }
1515 0 : ae_frame_leave(_state);
1516 0 : }
1517 :
1518 :
1519 : /*************************************************************************
1520 : appends element to X
1521 :
1522 : -- ALGLIB --
1523 : Copyright 20.03.2009 by Bochkanov Sergey
1524 : *************************************************************************/
1525 0 : void ivectorappend(/* Integer */ ae_vector* x,
1526 : ae_int_t v,
1527 : ae_state *_state)
1528 : {
1529 : ae_frame _frame_block;
1530 : ae_vector oldx;
1531 : ae_int_t i;
1532 : ae_int_t n;
1533 :
1534 0 : ae_frame_make(_state, &_frame_block);
1535 0 : memset(&oldx, 0, sizeof(oldx));
1536 0 : ae_vector_init(&oldx, 0, DT_INT, _state, ae_true);
1537 :
1538 0 : n = x->cnt;
1539 0 : ae_swap_vectors(x, &oldx);
1540 0 : ae_vector_set_length(x, n+1, _state);
1541 0 : for(i=0; i<=n-1; i++)
1542 : {
1543 0 : x->ptr.p_int[i] = oldx.ptr.p_int[i];
1544 : }
1545 0 : x->ptr.p_int[n] = v;
1546 0 : ae_frame_leave(_state);
1547 0 : }
1548 :
1549 :
1550 : /*************************************************************************
1551 : This function checks that length(X) is at least N and first N values from
1552 : X[] are finite
1553 :
1554 : -- ALGLIB --
1555 : Copyright 18.06.2010 by Bochkanov Sergey
1556 : *************************************************************************/
1557 0 : ae_bool isfinitevector(/* Real */ ae_vector* x,
1558 : ae_int_t n,
1559 : ae_state *_state)
1560 : {
1561 : ae_int_t i;
1562 : double v;
1563 : ae_bool result;
1564 :
1565 :
1566 0 : ae_assert(n>=0, "APSERVIsFiniteVector: internal error (N<0)", _state);
1567 0 : if( n==0 )
1568 : {
1569 0 : result = ae_true;
1570 0 : return result;
1571 : }
1572 0 : if( x->cnt<n )
1573 : {
1574 0 : result = ae_false;
1575 0 : return result;
1576 : }
1577 0 : v = (double)(0);
1578 0 : for(i=0; i<=n-1; i++)
1579 : {
1580 0 : v = 0.01*v+x->ptr.p_double[i];
1581 : }
1582 0 : result = ae_isfinite(v, _state);
1583 0 : return result;
1584 : }
1585 :
1586 :
1587 : /*************************************************************************
1588 : This function checks that first N values from X[] are finite
1589 :
1590 : -- ALGLIB --
1591 : Copyright 18.06.2010 by Bochkanov Sergey
1592 : *************************************************************************/
1593 0 : ae_bool isfinitecvector(/* Complex */ ae_vector* z,
1594 : ae_int_t n,
1595 : ae_state *_state)
1596 : {
1597 : ae_int_t i;
1598 : ae_bool result;
1599 :
1600 :
1601 0 : ae_assert(n>=0, "APSERVIsFiniteCVector: internal error (N<0)", _state);
1602 0 : for(i=0; i<=n-1; i++)
1603 : {
1604 0 : if( !ae_isfinite(z->ptr.p_complex[i].x, _state)||!ae_isfinite(z->ptr.p_complex[i].y, _state) )
1605 : {
1606 0 : result = ae_false;
1607 0 : return result;
1608 : }
1609 : }
1610 0 : result = ae_true;
1611 0 : return result;
1612 : }
1613 :
1614 :
1615 : /*************************************************************************
1616 : This function checks that size of X is at least MxN and values from
1617 : X[0..M-1,0..N-1] are finite.
1618 :
1619 : -- ALGLIB --
1620 : Copyright 18.06.2010 by Bochkanov Sergey
1621 : *************************************************************************/
1622 0 : ae_bool apservisfinitematrix(/* Real */ ae_matrix* x,
1623 : ae_int_t m,
1624 : ae_int_t n,
1625 : ae_state *_state)
1626 : {
1627 : ae_int_t i;
1628 : ae_int_t j;
1629 : ae_bool result;
1630 :
1631 :
1632 0 : ae_assert(n>=0, "APSERVIsFiniteMatrix: internal error (N<0)", _state);
1633 0 : ae_assert(m>=0, "APSERVIsFiniteMatrix: internal error (M<0)", _state);
1634 0 : if( m==0||n==0 )
1635 : {
1636 0 : result = ae_true;
1637 0 : return result;
1638 : }
1639 0 : if( x->rows<m||x->cols<n )
1640 : {
1641 0 : result = ae_false;
1642 0 : return result;
1643 : }
1644 0 : for(i=0; i<=m-1; i++)
1645 : {
1646 0 : for(j=0; j<=n-1; j++)
1647 : {
1648 0 : if( !ae_isfinite(x->ptr.pp_double[i][j], _state) )
1649 : {
1650 0 : result = ae_false;
1651 0 : return result;
1652 : }
1653 : }
1654 : }
1655 0 : result = ae_true;
1656 0 : return result;
1657 : }
1658 :
1659 :
1660 : /*************************************************************************
1661 : This function checks that all values from X[0..M-1,0..N-1] are finite
1662 :
1663 : -- ALGLIB --
1664 : Copyright 18.06.2010 by Bochkanov Sergey
1665 : *************************************************************************/
1666 0 : ae_bool apservisfinitecmatrix(/* Complex */ ae_matrix* x,
1667 : ae_int_t m,
1668 : ae_int_t n,
1669 : ae_state *_state)
1670 : {
1671 : ae_int_t i;
1672 : ae_int_t j;
1673 : ae_bool result;
1674 :
1675 :
1676 0 : ae_assert(n>=0, "APSERVIsFiniteCMatrix: internal error (N<0)", _state);
1677 0 : ae_assert(m>=0, "APSERVIsFiniteCMatrix: internal error (M<0)", _state);
1678 0 : for(i=0; i<=m-1; i++)
1679 : {
1680 0 : for(j=0; j<=n-1; j++)
1681 : {
1682 0 : if( !ae_isfinite(x->ptr.pp_complex[i][j].x, _state)||!ae_isfinite(x->ptr.pp_complex[i][j].y, _state) )
1683 : {
1684 0 : result = ae_false;
1685 0 : return result;
1686 : }
1687 : }
1688 : }
1689 0 : result = ae_true;
1690 0 : return result;
1691 : }
1692 :
1693 :
1694 : /*************************************************************************
1695 : This function checks that size of X is at least NxN and all values from
1696 : upper/lower triangle of X[0..N-1,0..N-1] are finite
1697 :
1698 : -- ALGLIB --
1699 : Copyright 18.06.2010 by Bochkanov Sergey
1700 : *************************************************************************/
1701 0 : ae_bool isfinitertrmatrix(/* Real */ ae_matrix* x,
1702 : ae_int_t n,
1703 : ae_bool isupper,
1704 : ae_state *_state)
1705 : {
1706 : ae_int_t i;
1707 : ae_int_t j1;
1708 : ae_int_t j2;
1709 : ae_int_t j;
1710 : ae_bool result;
1711 :
1712 :
1713 0 : ae_assert(n>=0, "APSERVIsFiniteRTRMatrix: internal error (N<0)", _state);
1714 0 : if( n==0 )
1715 : {
1716 0 : result = ae_true;
1717 0 : return result;
1718 : }
1719 0 : if( x->rows<n||x->cols<n )
1720 : {
1721 0 : result = ae_false;
1722 0 : return result;
1723 : }
1724 0 : for(i=0; i<=n-1; i++)
1725 : {
1726 0 : if( isupper )
1727 : {
1728 0 : j1 = i;
1729 0 : j2 = n-1;
1730 : }
1731 : else
1732 : {
1733 0 : j1 = 0;
1734 0 : j2 = i;
1735 : }
1736 0 : for(j=j1; j<=j2; j++)
1737 : {
1738 0 : if( !ae_isfinite(x->ptr.pp_double[i][j], _state) )
1739 : {
1740 0 : result = ae_false;
1741 0 : return result;
1742 : }
1743 : }
1744 : }
1745 0 : result = ae_true;
1746 0 : return result;
1747 : }
1748 :
1749 :
1750 : /*************************************************************************
1751 : This function checks that all values from upper/lower triangle of
1752 : X[0..N-1,0..N-1] are finite
1753 :
1754 : -- ALGLIB --
1755 : Copyright 18.06.2010 by Bochkanov Sergey
1756 : *************************************************************************/
1757 0 : ae_bool apservisfinitectrmatrix(/* Complex */ ae_matrix* x,
1758 : ae_int_t n,
1759 : ae_bool isupper,
1760 : ae_state *_state)
1761 : {
1762 : ae_int_t i;
1763 : ae_int_t j1;
1764 : ae_int_t j2;
1765 : ae_int_t j;
1766 : ae_bool result;
1767 :
1768 :
1769 0 : ae_assert(n>=0, "APSERVIsFiniteCTRMatrix: internal error (N<0)", _state);
1770 0 : for(i=0; i<=n-1; i++)
1771 : {
1772 0 : if( isupper )
1773 : {
1774 0 : j1 = i;
1775 0 : j2 = n-1;
1776 : }
1777 : else
1778 : {
1779 0 : j1 = 0;
1780 0 : j2 = i;
1781 : }
1782 0 : for(j=j1; j<=j2; j++)
1783 : {
1784 0 : if( !ae_isfinite(x->ptr.pp_complex[i][j].x, _state)||!ae_isfinite(x->ptr.pp_complex[i][j].y, _state) )
1785 : {
1786 0 : result = ae_false;
1787 0 : return result;
1788 : }
1789 : }
1790 : }
1791 0 : result = ae_true;
1792 0 : return result;
1793 : }
1794 :
1795 :
1796 : /*************************************************************************
1797 : This function checks that all values from X[0..M-1,0..N-1] are finite or
1798 : NaN's.
1799 :
1800 : -- ALGLIB --
1801 : Copyright 18.06.2010 by Bochkanov Sergey
1802 : *************************************************************************/
1803 0 : ae_bool apservisfiniteornanmatrix(/* Real */ ae_matrix* x,
1804 : ae_int_t m,
1805 : ae_int_t n,
1806 : ae_state *_state)
1807 : {
1808 : ae_int_t i;
1809 : ae_int_t j;
1810 : ae_bool result;
1811 :
1812 :
1813 0 : ae_assert(n>=0, "APSERVIsFiniteOrNaNMatrix: internal error (N<0)", _state);
1814 0 : ae_assert(m>=0, "APSERVIsFiniteOrNaNMatrix: internal error (M<0)", _state);
1815 0 : for(i=0; i<=m-1; i++)
1816 : {
1817 0 : for(j=0; j<=n-1; j++)
1818 : {
1819 0 : if( !(ae_isfinite(x->ptr.pp_double[i][j], _state)||ae_isnan(x->ptr.pp_double[i][j], _state)) )
1820 : {
1821 0 : result = ae_false;
1822 0 : return result;
1823 : }
1824 : }
1825 : }
1826 0 : result = ae_true;
1827 0 : return result;
1828 : }
1829 :
1830 :
1831 : /*************************************************************************
1832 : Safe sqrt(x^2+y^2)
1833 :
1834 : -- ALGLIB --
1835 : Copyright by Bochkanov Sergey
1836 : *************************************************************************/
1837 0 : double safepythag2(double x, double y, ae_state *_state)
1838 : {
1839 : double w;
1840 : double xabs;
1841 : double yabs;
1842 : double z;
1843 : double result;
1844 :
1845 :
1846 0 : xabs = ae_fabs(x, _state);
1847 0 : yabs = ae_fabs(y, _state);
1848 0 : w = ae_maxreal(xabs, yabs, _state);
1849 0 : z = ae_minreal(xabs, yabs, _state);
1850 0 : if( ae_fp_eq(z,(double)(0)) )
1851 : {
1852 0 : result = w;
1853 : }
1854 : else
1855 : {
1856 0 : result = w*ae_sqrt(1+ae_sqr(z/w, _state), _state);
1857 : }
1858 0 : return result;
1859 : }
1860 :
1861 :
1862 : /*************************************************************************
1863 : Safe sqrt(x^2+y^2)
1864 :
1865 : -- ALGLIB --
1866 : Copyright by Bochkanov Sergey
1867 : *************************************************************************/
1868 0 : double safepythag3(double x, double y, double z, ae_state *_state)
1869 : {
1870 : double w;
1871 : double result;
1872 :
1873 :
1874 0 : w = ae_maxreal(ae_fabs(x, _state), ae_maxreal(ae_fabs(y, _state), ae_fabs(z, _state), _state), _state);
1875 0 : if( ae_fp_eq(w,(double)(0)) )
1876 : {
1877 0 : result = (double)(0);
1878 0 : return result;
1879 : }
1880 0 : x = x/w;
1881 0 : y = y/w;
1882 0 : z = z/w;
1883 0 : result = w*ae_sqrt(ae_sqr(x, _state)+ae_sqr(y, _state)+ae_sqr(z, _state), _state);
1884 0 : return result;
1885 : }
1886 :
1887 :
1888 : /*************************************************************************
1889 : Safe division.
1890 :
1891 : This function attempts to calculate R=X/Y without overflow.
1892 :
1893 : It returns:
1894 : * +1, if abs(X/Y)>=MaxRealNumber or undefined - overflow-like situation
1895 : (no overlfow is generated, R is either NAN, PosINF, NegINF)
1896 : * 0, if MinRealNumber<abs(X/Y)<MaxRealNumber or X=0, Y<>0
1897 : (R contains result, may be zero)
1898 : * -1, if 0<abs(X/Y)<MinRealNumber - underflow-like situation
1899 : (R contains zero; it corresponds to underflow)
1900 :
1901 : No overflow is generated in any case.
1902 :
1903 : -- ALGLIB --
1904 : Copyright by Bochkanov Sergey
1905 : *************************************************************************/
1906 0 : ae_int_t saferdiv(double x, double y, double* r, ae_state *_state)
1907 : {
1908 : ae_int_t result;
1909 :
1910 0 : *r = 0;
1911 :
1912 :
1913 : /*
1914 : * Two special cases:
1915 : * * Y=0
1916 : * * X=0 and Y<>0
1917 : */
1918 0 : if( ae_fp_eq(y,(double)(0)) )
1919 : {
1920 0 : result = 1;
1921 0 : if( ae_fp_eq(x,(double)(0)) )
1922 : {
1923 0 : *r = _state->v_nan;
1924 : }
1925 0 : if( ae_fp_greater(x,(double)(0)) )
1926 : {
1927 0 : *r = _state->v_posinf;
1928 : }
1929 0 : if( ae_fp_less(x,(double)(0)) )
1930 : {
1931 0 : *r = _state->v_neginf;
1932 : }
1933 0 : return result;
1934 : }
1935 0 : if( ae_fp_eq(x,(double)(0)) )
1936 : {
1937 0 : *r = (double)(0);
1938 0 : result = 0;
1939 0 : return result;
1940 : }
1941 :
1942 : /*
1943 : * make Y>0
1944 : */
1945 0 : if( ae_fp_less(y,(double)(0)) )
1946 : {
1947 0 : x = -x;
1948 0 : y = -y;
1949 : }
1950 :
1951 : /*
1952 : *
1953 : */
1954 0 : if( ae_fp_greater_eq(y,(double)(1)) )
1955 : {
1956 0 : *r = x/y;
1957 0 : if( ae_fp_less_eq(ae_fabs(*r, _state),ae_minrealnumber) )
1958 : {
1959 0 : result = -1;
1960 0 : *r = (double)(0);
1961 : }
1962 : else
1963 : {
1964 0 : result = 0;
1965 : }
1966 : }
1967 : else
1968 : {
1969 0 : if( ae_fp_greater_eq(ae_fabs(x, _state),ae_maxrealnumber*y) )
1970 : {
1971 0 : if( ae_fp_greater(x,(double)(0)) )
1972 : {
1973 0 : *r = _state->v_posinf;
1974 : }
1975 : else
1976 : {
1977 0 : *r = _state->v_neginf;
1978 : }
1979 0 : result = 1;
1980 : }
1981 : else
1982 : {
1983 0 : *r = x/y;
1984 0 : result = 0;
1985 : }
1986 : }
1987 0 : return result;
1988 : }
1989 :
1990 :
1991 : /*************************************************************************
1992 : This function calculates "safe" min(X/Y,V) for positive finite X, Y, V.
1993 : No overflow is generated in any case.
1994 :
1995 : -- ALGLIB --
1996 : Copyright by Bochkanov Sergey
1997 : *************************************************************************/
1998 0 : double safeminposrv(double x, double y, double v, ae_state *_state)
1999 : {
2000 : double r;
2001 : double result;
2002 :
2003 :
2004 0 : if( ae_fp_greater_eq(y,(double)(1)) )
2005 : {
2006 :
2007 : /*
2008 : * Y>=1, we can safely divide by Y
2009 : */
2010 0 : r = x/y;
2011 0 : result = v;
2012 0 : if( ae_fp_greater(v,r) )
2013 : {
2014 0 : result = r;
2015 : }
2016 : else
2017 : {
2018 0 : result = v;
2019 : }
2020 : }
2021 : else
2022 : {
2023 :
2024 : /*
2025 : * Y<1, we can safely multiply by Y
2026 : */
2027 0 : if( ae_fp_less(x,v*y) )
2028 : {
2029 0 : result = x/y;
2030 : }
2031 : else
2032 : {
2033 0 : result = v;
2034 : }
2035 : }
2036 0 : return result;
2037 : }
2038 :
2039 :
2040 : /*************************************************************************
2041 : This function makes periodic mapping of X to [A,B].
2042 :
2043 : It accepts X, A, B (A>B). It returns T which lies in [A,B] and integer K,
2044 : such that X = T + K*(B-A).
2045 :
2046 : NOTES:
2047 : * K is represented as real value, although actually it is integer
2048 : * T is guaranteed to be in [A,B]
2049 : * T replaces X
2050 :
2051 : -- ALGLIB --
2052 : Copyright by Bochkanov Sergey
2053 : *************************************************************************/
2054 0 : void apperiodicmap(double* x,
2055 : double a,
2056 : double b,
2057 : double* k,
2058 : ae_state *_state)
2059 : {
2060 :
2061 0 : *k = 0;
2062 :
2063 0 : ae_assert(ae_fp_less(a,b), "APPeriodicMap: internal error!", _state);
2064 0 : *k = (double)(ae_ifloor((*x-a)/(b-a), _state));
2065 0 : *x = *x-*k*(b-a);
2066 0 : while(ae_fp_less(*x,a))
2067 : {
2068 0 : *x = *x+(b-a);
2069 0 : *k = *k-1;
2070 : }
2071 0 : while(ae_fp_greater(*x,b))
2072 : {
2073 0 : *x = *x-(b-a);
2074 0 : *k = *k+1;
2075 : }
2076 0 : *x = ae_maxreal(*x, a, _state);
2077 0 : *x = ae_minreal(*x, b, _state);
2078 0 : }
2079 :
2080 :
2081 : /*************************************************************************
2082 : Returns random normal number using low-quality system-provided generator
2083 :
2084 : -- ALGLIB --
2085 : Copyright 20.03.2009 by Bochkanov Sergey
2086 : *************************************************************************/
2087 0 : double randomnormal(ae_state *_state)
2088 : {
2089 : double u;
2090 : double v;
2091 : double s;
2092 : double result;
2093 :
2094 :
2095 : for(;;)
2096 : {
2097 0 : u = 2*ae_randomreal(_state)-1;
2098 0 : v = 2*ae_randomreal(_state)-1;
2099 0 : s = ae_sqr(u, _state)+ae_sqr(v, _state);
2100 0 : if( ae_fp_greater(s,(double)(0))&&ae_fp_less(s,(double)(1)) )
2101 : {
2102 :
2103 : /*
2104 : * two Sqrt's instead of one to
2105 : * avoid overflow when S is too small
2106 : */
2107 0 : s = ae_sqrt(-2*ae_log(s, _state), _state)/ae_sqrt(s, _state);
2108 0 : result = u*s;
2109 0 : break;
2110 : }
2111 : }
2112 0 : return result;
2113 : }
2114 :
2115 :
2116 : /*************************************************************************
2117 : Generates random unit vector using low-quality system-provided generator.
2118 : Reallocates array if its size is too short.
2119 :
2120 : -- ALGLIB --
2121 : Copyright 20.03.2009 by Bochkanov Sergey
2122 : *************************************************************************/
2123 0 : void randomunit(ae_int_t n, /* Real */ ae_vector* x, ae_state *_state)
2124 : {
2125 : ae_int_t i;
2126 : double v;
2127 : double vv;
2128 :
2129 :
2130 0 : ae_assert(n>0, "RandomUnit: N<=0", _state);
2131 0 : if( x->cnt<n )
2132 : {
2133 0 : ae_vector_set_length(x, n, _state);
2134 : }
2135 : do
2136 : {
2137 0 : v = 0.0;
2138 0 : for(i=0; i<=n-1; i++)
2139 : {
2140 0 : vv = randomnormal(_state);
2141 0 : x->ptr.p_double[i] = vv;
2142 0 : v = v+vv*vv;
2143 : }
2144 : }
2145 0 : while(ae_fp_less_eq(v,(double)(0)));
2146 0 : v = 1/ae_sqrt(v, _state);
2147 0 : for(i=0; i<=n-1; i++)
2148 : {
2149 0 : x->ptr.p_double[i] = x->ptr.p_double[i]*v;
2150 : }
2151 0 : }
2152 :
2153 :
2154 : /*************************************************************************
2155 : This function is used to swap two integer values
2156 : *************************************************************************/
2157 0 : void swapi(ae_int_t* v0, ae_int_t* v1, ae_state *_state)
2158 : {
2159 : ae_int_t v;
2160 :
2161 :
2162 0 : v = *v0;
2163 0 : *v0 = *v1;
2164 0 : *v1 = v;
2165 0 : }
2166 :
2167 :
2168 : /*************************************************************************
2169 : This function is used to swap two real values
2170 : *************************************************************************/
2171 0 : void swapr(double* v0, double* v1, ae_state *_state)
2172 : {
2173 : double v;
2174 :
2175 :
2176 0 : v = *v0;
2177 0 : *v0 = *v1;
2178 0 : *v1 = v;
2179 0 : }
2180 :
2181 :
2182 : /*************************************************************************
2183 : This function is used to swap two rows of the matrix; if NCols<0, automatically
2184 : determined from the matrix size.
2185 : *************************************************************************/
2186 0 : void swaprows(/* Real */ ae_matrix* a,
2187 : ae_int_t i0,
2188 : ae_int_t i1,
2189 : ae_int_t ncols,
2190 : ae_state *_state)
2191 : {
2192 : ae_int_t j;
2193 : double v;
2194 :
2195 :
2196 0 : if( i0==i1 )
2197 : {
2198 0 : return;
2199 : }
2200 0 : if( ncols<0 )
2201 : {
2202 0 : ncols = a->cols;
2203 : }
2204 0 : for(j=0; j<=ncols-1; j++)
2205 : {
2206 0 : v = a->ptr.pp_double[i0][j];
2207 0 : a->ptr.pp_double[i0][j] = a->ptr.pp_double[i1][j];
2208 0 : a->ptr.pp_double[i1][j] = v;
2209 : }
2210 : }
2211 :
2212 :
2213 : /*************************************************************************
2214 : This function is used to swap two cols of the matrix; if NRows<0, automatically
2215 : determined from the matrix size.
2216 : *************************************************************************/
2217 0 : void swapcols(/* Real */ ae_matrix* a,
2218 : ae_int_t j0,
2219 : ae_int_t j1,
2220 : ae_int_t nrows,
2221 : ae_state *_state)
2222 : {
2223 : ae_int_t i;
2224 : double v;
2225 :
2226 :
2227 0 : if( j0==j1 )
2228 : {
2229 0 : return;
2230 : }
2231 0 : if( nrows<0 )
2232 : {
2233 0 : nrows = a->rows;
2234 : }
2235 0 : for(i=0; i<=nrows-1; i++)
2236 : {
2237 0 : v = a->ptr.pp_double[i][j0];
2238 0 : a->ptr.pp_double[i][j0] = a->ptr.pp_double[i][j1];
2239 0 : a->ptr.pp_double[i][j1] = v;
2240 : }
2241 : }
2242 :
2243 :
2244 : /*************************************************************************
2245 : This function is used to swap two "entries" in 1-dimensional array composed
2246 : from D-element entries
2247 : *************************************************************************/
2248 0 : void swapentries(/* Real */ ae_vector* a,
2249 : ae_int_t i0,
2250 : ae_int_t i1,
2251 : ae_int_t entrywidth,
2252 : ae_state *_state)
2253 : {
2254 : ae_int_t offs0;
2255 : ae_int_t offs1;
2256 : ae_int_t j;
2257 : double v;
2258 :
2259 :
2260 0 : if( i0==i1 )
2261 : {
2262 0 : return;
2263 : }
2264 0 : offs0 = i0*entrywidth;
2265 0 : offs1 = i1*entrywidth;
2266 0 : for(j=0; j<=entrywidth-1; j++)
2267 : {
2268 0 : v = a->ptr.p_double[offs0+j];
2269 0 : a->ptr.p_double[offs0+j] = a->ptr.p_double[offs1+j];
2270 0 : a->ptr.p_double[offs1+j] = v;
2271 : }
2272 : }
2273 :
2274 :
2275 : /*************************************************************************
2276 : This function is used to swap two elements of the vector
2277 : *************************************************************************/
2278 0 : void swapelements(/* Real */ ae_vector* a,
2279 : ae_int_t i0,
2280 : ae_int_t i1,
2281 : ae_state *_state)
2282 : {
2283 : double v;
2284 :
2285 :
2286 0 : if( i0==i1 )
2287 : {
2288 0 : return;
2289 : }
2290 0 : v = a->ptr.p_double[i0];
2291 0 : a->ptr.p_double[i0] = a->ptr.p_double[i1];
2292 0 : a->ptr.p_double[i1] = v;
2293 : }
2294 :
2295 :
2296 : /*************************************************************************
2297 : This function is used to swap two elements of the vector
2298 : *************************************************************************/
2299 0 : void swapelementsi(/* Integer */ ae_vector* a,
2300 : ae_int_t i0,
2301 : ae_int_t i1,
2302 : ae_state *_state)
2303 : {
2304 : ae_int_t v;
2305 :
2306 :
2307 0 : if( i0==i1 )
2308 : {
2309 0 : return;
2310 : }
2311 0 : v = a->ptr.p_int[i0];
2312 0 : a->ptr.p_int[i0] = a->ptr.p_int[i1];
2313 0 : a->ptr.p_int[i1] = v;
2314 : }
2315 :
2316 :
2317 : /*************************************************************************
2318 : This function is used to return maximum of three real values
2319 : *************************************************************************/
2320 0 : double maxreal3(double v0, double v1, double v2, ae_state *_state)
2321 : {
2322 : double result;
2323 :
2324 :
2325 0 : result = v0;
2326 0 : if( ae_fp_less(result,v1) )
2327 : {
2328 0 : result = v1;
2329 : }
2330 0 : if( ae_fp_less(result,v2) )
2331 : {
2332 0 : result = v2;
2333 : }
2334 0 : return result;
2335 : }
2336 :
2337 :
2338 : /*************************************************************************
2339 : This function is used to increment value of integer variable
2340 : *************************************************************************/
2341 0 : void inc(ae_int_t* v, ae_state *_state)
2342 : {
2343 :
2344 :
2345 0 : *v = *v+1;
2346 0 : }
2347 :
2348 :
2349 : /*************************************************************************
2350 : This function is used to decrement value of integer variable
2351 : *************************************************************************/
2352 0 : void dec(ae_int_t* v, ae_state *_state)
2353 : {
2354 :
2355 :
2356 0 : *v = *v-1;
2357 0 : }
2358 :
2359 :
2360 : /*************************************************************************
2361 : This function is used to increment value of integer variable; name of the
2362 : function suggests that increment is done in multithreaded setting in the
2363 : thread-unsafe manner (optional progress reports which do not need guaranteed
2364 : correctness)
2365 : *************************************************************************/
2366 0 : void threadunsafeinc(ae_int_t* v, ae_state *_state)
2367 : {
2368 :
2369 :
2370 0 : *v = *v+1;
2371 0 : }
2372 :
2373 :
2374 : /*************************************************************************
2375 : This function is used to increment value of integer variable; name of the
2376 : function suggests that increment is done in multithreaded setting in the
2377 : thread-unsafe manner (optional progress reports which do not need guaranteed
2378 : correctness)
2379 : *************************************************************************/
2380 0 : void threadunsafeincby(ae_int_t* v, ae_int_t k, ae_state *_state)
2381 : {
2382 :
2383 :
2384 0 : *v = *v+k;
2385 0 : }
2386 :
2387 :
2388 : /*************************************************************************
2389 : This function performs two operations:
2390 : 1. decrements value of integer variable, if it is positive
2391 : 2. explicitly sets variable to zero if it is non-positive
2392 : It is used by some algorithms to decrease value of internal counters.
2393 : *************************************************************************/
2394 0 : void countdown(ae_int_t* v, ae_state *_state)
2395 : {
2396 :
2397 :
2398 0 : if( *v>0 )
2399 : {
2400 0 : *v = *v-1;
2401 : }
2402 : else
2403 : {
2404 0 : *v = 0;
2405 : }
2406 0 : }
2407 :
2408 :
2409 : /*************************************************************************
2410 : This function returns +1 or -1 depending on sign of X.
2411 : x=0 results in +1 being returned.
2412 : *************************************************************************/
2413 0 : double possign(double x, ae_state *_state)
2414 : {
2415 : double result;
2416 :
2417 :
2418 0 : if( ae_fp_greater_eq(x,(double)(0)) )
2419 : {
2420 0 : result = (double)(1);
2421 : }
2422 : else
2423 : {
2424 0 : result = (double)(-1);
2425 : }
2426 0 : return result;
2427 : }
2428 :
2429 :
2430 : /*************************************************************************
2431 : This function returns product of two real numbers. It is convenient when
2432 : you have to perform typecast-and-product of two INTEGERS.
2433 : *************************************************************************/
2434 0 : double rmul2(double v0, double v1, ae_state *_state)
2435 : {
2436 : double result;
2437 :
2438 :
2439 0 : result = v0*v1;
2440 0 : return result;
2441 : }
2442 :
2443 :
2444 : /*************************************************************************
2445 : This function returns product of three real numbers. It is convenient when
2446 : you have to perform typecast-and-product of two INTEGERS.
2447 : *************************************************************************/
2448 0 : double rmul3(double v0, double v1, double v2, ae_state *_state)
2449 : {
2450 : double result;
2451 :
2452 :
2453 0 : result = v0*v1*v2;
2454 0 : return result;
2455 : }
2456 :
2457 :
2458 : /*************************************************************************
2459 : This function returns (A div B) rounded up; it expects that A>0, B>0, but
2460 : does not check it.
2461 : *************************************************************************/
2462 0 : ae_int_t idivup(ae_int_t a, ae_int_t b, ae_state *_state)
2463 : {
2464 : ae_int_t result;
2465 :
2466 :
2467 0 : result = a/b;
2468 0 : if( a%b>0 )
2469 : {
2470 0 : result = result+1;
2471 : }
2472 0 : return result;
2473 : }
2474 :
2475 :
2476 : /*************************************************************************
2477 : This function returns min(i0,i1)
2478 : *************************************************************************/
2479 0 : ae_int_t imin2(ae_int_t i0, ae_int_t i1, ae_state *_state)
2480 : {
2481 : ae_int_t result;
2482 :
2483 :
2484 0 : result = i0;
2485 0 : if( i1<result )
2486 : {
2487 0 : result = i1;
2488 : }
2489 0 : return result;
2490 : }
2491 :
2492 :
2493 : /*************************************************************************
2494 : This function returns min(i0,i1,i2)
2495 : *************************************************************************/
2496 0 : ae_int_t imin3(ae_int_t i0, ae_int_t i1, ae_int_t i2, ae_state *_state)
2497 : {
2498 : ae_int_t result;
2499 :
2500 :
2501 0 : result = i0;
2502 0 : if( i1<result )
2503 : {
2504 0 : result = i1;
2505 : }
2506 0 : if( i2<result )
2507 : {
2508 0 : result = i2;
2509 : }
2510 0 : return result;
2511 : }
2512 :
2513 :
2514 : /*************************************************************************
2515 : This function returns max(i0,i1)
2516 : *************************************************************************/
2517 0 : ae_int_t imax2(ae_int_t i0, ae_int_t i1, ae_state *_state)
2518 : {
2519 : ae_int_t result;
2520 :
2521 :
2522 0 : result = i0;
2523 0 : if( i1>result )
2524 : {
2525 0 : result = i1;
2526 : }
2527 0 : return result;
2528 : }
2529 :
2530 :
2531 : /*************************************************************************
2532 : This function returns max(i0,i1,i2)
2533 : *************************************************************************/
2534 0 : ae_int_t imax3(ae_int_t i0, ae_int_t i1, ae_int_t i2, ae_state *_state)
2535 : {
2536 : ae_int_t result;
2537 :
2538 :
2539 0 : result = i0;
2540 0 : if( i1>result )
2541 : {
2542 0 : result = i1;
2543 : }
2544 0 : if( i2>result )
2545 : {
2546 0 : result = i2;
2547 : }
2548 0 : return result;
2549 : }
2550 :
2551 :
2552 : /*************************************************************************
2553 : This function returns max(r0,r1,r2)
2554 : *************************************************************************/
2555 0 : double rmax3(double r0, double r1, double r2, ae_state *_state)
2556 : {
2557 : double result;
2558 :
2559 :
2560 0 : result = r0;
2561 0 : if( ae_fp_greater(r1,result) )
2562 : {
2563 0 : result = r1;
2564 : }
2565 0 : if( ae_fp_greater(r2,result) )
2566 : {
2567 0 : result = r2;
2568 : }
2569 0 : return result;
2570 : }
2571 :
2572 :
2573 : /*************************************************************************
2574 : This function returns max(|r0|,|r1|,|r2|)
2575 : *************************************************************************/
2576 0 : double rmaxabs3(double r0, double r1, double r2, ae_state *_state)
2577 : {
2578 : double result;
2579 :
2580 :
2581 0 : r0 = ae_fabs(r0, _state);
2582 0 : r1 = ae_fabs(r1, _state);
2583 0 : r2 = ae_fabs(r2, _state);
2584 0 : result = r0;
2585 0 : if( ae_fp_greater(r1,result) )
2586 : {
2587 0 : result = r1;
2588 : }
2589 0 : if( ae_fp_greater(r2,result) )
2590 : {
2591 0 : result = r2;
2592 : }
2593 0 : return result;
2594 : }
2595 :
2596 :
2597 : /*************************************************************************
2598 : 'bounds' value: maps X to [B1,B2]
2599 :
2600 : -- ALGLIB --
2601 : Copyright 20.03.2009 by Bochkanov Sergey
2602 : *************************************************************************/
2603 0 : double boundval(double x, double b1, double b2, ae_state *_state)
2604 : {
2605 : double result;
2606 :
2607 :
2608 0 : if( ae_fp_less_eq(x,b1) )
2609 : {
2610 0 : result = b1;
2611 0 : return result;
2612 : }
2613 0 : if( ae_fp_greater_eq(x,b2) )
2614 : {
2615 0 : result = b2;
2616 0 : return result;
2617 : }
2618 0 : result = x;
2619 0 : return result;
2620 : }
2621 :
2622 :
2623 : /*************************************************************************
2624 : 'bounds' value: maps X to [B1,B2]
2625 :
2626 : -- ALGLIB --
2627 : Copyright 20.03.2009 by Bochkanov Sergey
2628 : *************************************************************************/
2629 0 : ae_int_t iboundval(ae_int_t x, ae_int_t b1, ae_int_t b2, ae_state *_state)
2630 : {
2631 : ae_int_t result;
2632 :
2633 :
2634 0 : if( x<=b1 )
2635 : {
2636 0 : result = b1;
2637 0 : return result;
2638 : }
2639 0 : if( x>=b2 )
2640 : {
2641 0 : result = b2;
2642 0 : return result;
2643 : }
2644 0 : result = x;
2645 0 : return result;
2646 : }
2647 :
2648 :
2649 : /*************************************************************************
2650 : 'bounds' value: maps X to [B1,B2]
2651 :
2652 : -- ALGLIB --
2653 : Copyright 20.03.2009 by Bochkanov Sergey
2654 : *************************************************************************/
2655 0 : double rboundval(double x, double b1, double b2, ae_state *_state)
2656 : {
2657 : double result;
2658 :
2659 :
2660 0 : if( ae_fp_less_eq(x,b1) )
2661 : {
2662 0 : result = b1;
2663 0 : return result;
2664 : }
2665 0 : if( ae_fp_greater_eq(x,b2) )
2666 : {
2667 0 : result = b2;
2668 0 : return result;
2669 : }
2670 0 : result = x;
2671 0 : return result;
2672 : }
2673 :
2674 :
2675 : /*************************************************************************
2676 : Returns number of non-zeros
2677 : *************************************************************************/
2678 0 : ae_int_t countnz1(/* Real */ ae_vector* v,
2679 : ae_int_t n,
2680 : ae_state *_state)
2681 : {
2682 : ae_int_t i;
2683 : ae_int_t result;
2684 :
2685 :
2686 0 : result = 0;
2687 0 : for(i=0; i<=n-1; i++)
2688 : {
2689 0 : if( !(v->ptr.p_double[i]==0) )
2690 : {
2691 0 : result = result+1;
2692 : }
2693 : }
2694 0 : return result;
2695 : }
2696 :
2697 :
2698 : /*************************************************************************
2699 : Returns number of non-zeros
2700 : *************************************************************************/
2701 0 : ae_int_t countnz2(/* Real */ ae_matrix* v,
2702 : ae_int_t m,
2703 : ae_int_t n,
2704 : ae_state *_state)
2705 : {
2706 : ae_int_t i;
2707 : ae_int_t j;
2708 : ae_int_t result;
2709 :
2710 :
2711 0 : result = 0;
2712 0 : for(i=0; i<=m-1; i++)
2713 : {
2714 0 : for(j=0; j<=n-1; j++)
2715 : {
2716 0 : if( !(v->ptr.pp_double[i][j]==0) )
2717 : {
2718 0 : result = result+1;
2719 : }
2720 : }
2721 : }
2722 0 : return result;
2723 : }
2724 :
2725 :
2726 : /*************************************************************************
2727 : Allocation of serializer: complex value
2728 : *************************************************************************/
2729 0 : void alloccomplex(ae_serializer* s, ae_complex v, ae_state *_state)
2730 : {
2731 :
2732 :
2733 0 : ae_serializer_alloc_entry(s);
2734 0 : ae_serializer_alloc_entry(s);
2735 0 : }
2736 :
2737 :
2738 : /*************************************************************************
2739 : Serialization: complex value
2740 : *************************************************************************/
2741 0 : void serializecomplex(ae_serializer* s, ae_complex v, ae_state *_state)
2742 : {
2743 :
2744 :
2745 0 : ae_serializer_serialize_double(s, v.x, _state);
2746 0 : ae_serializer_serialize_double(s, v.y, _state);
2747 0 : }
2748 :
2749 :
2750 : /*************************************************************************
2751 : Unserialization: complex value
2752 : *************************************************************************/
2753 0 : ae_complex unserializecomplex(ae_serializer* s, ae_state *_state)
2754 : {
2755 : ae_complex result;
2756 :
2757 :
2758 0 : ae_serializer_unserialize_double(s, &result.x, _state);
2759 0 : ae_serializer_unserialize_double(s, &result.y, _state);
2760 0 : return result;
2761 : }
2762 :
2763 :
2764 : /*************************************************************************
2765 : Allocation of serializer: real array
2766 : *************************************************************************/
2767 0 : void allocrealarray(ae_serializer* s,
2768 : /* Real */ ae_vector* v,
2769 : ae_int_t n,
2770 : ae_state *_state)
2771 : {
2772 : ae_int_t i;
2773 :
2774 :
2775 0 : if( n<0 )
2776 : {
2777 0 : n = v->cnt;
2778 : }
2779 0 : ae_serializer_alloc_entry(s);
2780 0 : for(i=0; i<=n-1; i++)
2781 : {
2782 0 : ae_serializer_alloc_entry(s);
2783 : }
2784 0 : }
2785 :
2786 :
2787 : /*************************************************************************
2788 : Serialization: complex value
2789 : *************************************************************************/
2790 0 : void serializerealarray(ae_serializer* s,
2791 : /* Real */ ae_vector* v,
2792 : ae_int_t n,
2793 : ae_state *_state)
2794 : {
2795 : ae_int_t i;
2796 :
2797 :
2798 0 : if( n<0 )
2799 : {
2800 0 : n = v->cnt;
2801 : }
2802 0 : ae_serializer_serialize_int(s, n, _state);
2803 0 : for(i=0; i<=n-1; i++)
2804 : {
2805 0 : ae_serializer_serialize_double(s, v->ptr.p_double[i], _state);
2806 : }
2807 0 : }
2808 :
2809 :
2810 : /*************************************************************************
2811 : Unserialization: complex value
2812 : *************************************************************************/
2813 0 : void unserializerealarray(ae_serializer* s,
2814 : /* Real */ ae_vector* v,
2815 : ae_state *_state)
2816 : {
2817 : ae_int_t n;
2818 : ae_int_t i;
2819 : double t;
2820 :
2821 0 : ae_vector_clear(v);
2822 :
2823 0 : ae_serializer_unserialize_int(s, &n, _state);
2824 0 : if( n==0 )
2825 : {
2826 0 : return;
2827 : }
2828 0 : ae_vector_set_length(v, n, _state);
2829 0 : for(i=0; i<=n-1; i++)
2830 : {
2831 0 : ae_serializer_unserialize_double(s, &t, _state);
2832 0 : v->ptr.p_double[i] = t;
2833 : }
2834 : }
2835 :
2836 :
2837 : /*************************************************************************
2838 : Allocation of serializer: Integer array
2839 : *************************************************************************/
2840 0 : void allocintegerarray(ae_serializer* s,
2841 : /* Integer */ ae_vector* v,
2842 : ae_int_t n,
2843 : ae_state *_state)
2844 : {
2845 : ae_int_t i;
2846 :
2847 :
2848 0 : if( n<0 )
2849 : {
2850 0 : n = v->cnt;
2851 : }
2852 0 : ae_serializer_alloc_entry(s);
2853 0 : for(i=0; i<=n-1; i++)
2854 : {
2855 0 : ae_serializer_alloc_entry(s);
2856 : }
2857 0 : }
2858 :
2859 :
2860 : /*************************************************************************
2861 : Serialization: Integer array
2862 : *************************************************************************/
2863 0 : void serializeintegerarray(ae_serializer* s,
2864 : /* Integer */ ae_vector* v,
2865 : ae_int_t n,
2866 : ae_state *_state)
2867 : {
2868 : ae_int_t i;
2869 :
2870 :
2871 0 : if( n<0 )
2872 : {
2873 0 : n = v->cnt;
2874 : }
2875 0 : ae_serializer_serialize_int(s, n, _state);
2876 0 : for(i=0; i<=n-1; i++)
2877 : {
2878 0 : ae_serializer_serialize_int(s, v->ptr.p_int[i], _state);
2879 : }
2880 0 : }
2881 :
2882 :
2883 : /*************************************************************************
2884 : Unserialization: complex value
2885 : *************************************************************************/
2886 0 : void unserializeintegerarray(ae_serializer* s,
2887 : /* Integer */ ae_vector* v,
2888 : ae_state *_state)
2889 : {
2890 : ae_int_t n;
2891 : ae_int_t i;
2892 : ae_int_t t;
2893 :
2894 0 : ae_vector_clear(v);
2895 :
2896 0 : ae_serializer_unserialize_int(s, &n, _state);
2897 0 : if( n==0 )
2898 : {
2899 0 : return;
2900 : }
2901 0 : ae_vector_set_length(v, n, _state);
2902 0 : for(i=0; i<=n-1; i++)
2903 : {
2904 0 : ae_serializer_unserialize_int(s, &t, _state);
2905 0 : v->ptr.p_int[i] = t;
2906 : }
2907 : }
2908 :
2909 :
2910 : /*************************************************************************
2911 : Allocation of serializer: real matrix
2912 : *************************************************************************/
2913 0 : void allocrealmatrix(ae_serializer* s,
2914 : /* Real */ ae_matrix* v,
2915 : ae_int_t n0,
2916 : ae_int_t n1,
2917 : ae_state *_state)
2918 : {
2919 : ae_int_t i;
2920 : ae_int_t j;
2921 :
2922 :
2923 0 : if( n0<0 )
2924 : {
2925 0 : n0 = v->rows;
2926 : }
2927 0 : if( n1<0 )
2928 : {
2929 0 : n1 = v->cols;
2930 : }
2931 0 : ae_serializer_alloc_entry(s);
2932 0 : ae_serializer_alloc_entry(s);
2933 0 : for(i=0; i<=n0-1; i++)
2934 : {
2935 0 : for(j=0; j<=n1-1; j++)
2936 : {
2937 0 : ae_serializer_alloc_entry(s);
2938 : }
2939 : }
2940 0 : }
2941 :
2942 :
2943 : /*************************************************************************
2944 : Serialization: complex value
2945 : *************************************************************************/
2946 0 : void serializerealmatrix(ae_serializer* s,
2947 : /* Real */ ae_matrix* v,
2948 : ae_int_t n0,
2949 : ae_int_t n1,
2950 : ae_state *_state)
2951 : {
2952 : ae_int_t i;
2953 : ae_int_t j;
2954 :
2955 :
2956 0 : if( n0<0 )
2957 : {
2958 0 : n0 = v->rows;
2959 : }
2960 0 : if( n1<0 )
2961 : {
2962 0 : n1 = v->cols;
2963 : }
2964 0 : ae_serializer_serialize_int(s, n0, _state);
2965 0 : ae_serializer_serialize_int(s, n1, _state);
2966 0 : for(i=0; i<=n0-1; i++)
2967 : {
2968 0 : for(j=0; j<=n1-1; j++)
2969 : {
2970 0 : ae_serializer_serialize_double(s, v->ptr.pp_double[i][j], _state);
2971 : }
2972 : }
2973 0 : }
2974 :
2975 :
2976 : /*************************************************************************
2977 : Unserialization: complex value
2978 : *************************************************************************/
2979 0 : void unserializerealmatrix(ae_serializer* s,
2980 : /* Real */ ae_matrix* v,
2981 : ae_state *_state)
2982 : {
2983 : ae_int_t i;
2984 : ae_int_t j;
2985 : ae_int_t n0;
2986 : ae_int_t n1;
2987 : double t;
2988 :
2989 0 : ae_matrix_clear(v);
2990 :
2991 0 : ae_serializer_unserialize_int(s, &n0, _state);
2992 0 : ae_serializer_unserialize_int(s, &n1, _state);
2993 0 : if( n0==0||n1==0 )
2994 : {
2995 0 : return;
2996 : }
2997 0 : ae_matrix_set_length(v, n0, n1, _state);
2998 0 : for(i=0; i<=n0-1; i++)
2999 : {
3000 0 : for(j=0; j<=n1-1; j++)
3001 : {
3002 0 : ae_serializer_unserialize_double(s, &t, _state);
3003 0 : v->ptr.pp_double[i][j] = t;
3004 : }
3005 : }
3006 : }
3007 :
3008 :
3009 : /*************************************************************************
3010 : Copy boolean array
3011 : *************************************************************************/
3012 0 : void copybooleanarray(/* Boolean */ ae_vector* src,
3013 : /* Boolean */ ae_vector* dst,
3014 : ae_state *_state)
3015 : {
3016 : ae_int_t i;
3017 :
3018 0 : ae_vector_clear(dst);
3019 :
3020 0 : if( src->cnt>0 )
3021 : {
3022 0 : ae_vector_set_length(dst, src->cnt, _state);
3023 0 : for(i=0; i<=src->cnt-1; i++)
3024 : {
3025 0 : dst->ptr.p_bool[i] = src->ptr.p_bool[i];
3026 : }
3027 : }
3028 0 : }
3029 :
3030 :
3031 : /*************************************************************************
3032 : Copy integer array
3033 : *************************************************************************/
3034 0 : void copyintegerarray(/* Integer */ ae_vector* src,
3035 : /* Integer */ ae_vector* dst,
3036 : ae_state *_state)
3037 : {
3038 : ae_int_t i;
3039 :
3040 0 : ae_vector_clear(dst);
3041 :
3042 0 : if( src->cnt>0 )
3043 : {
3044 0 : ae_vector_set_length(dst, src->cnt, _state);
3045 0 : for(i=0; i<=src->cnt-1; i++)
3046 : {
3047 0 : dst->ptr.p_int[i] = src->ptr.p_int[i];
3048 : }
3049 : }
3050 0 : }
3051 :
3052 :
3053 : /*************************************************************************
3054 : Copy real array
3055 : *************************************************************************/
3056 0 : void copyrealarray(/* Real */ ae_vector* src,
3057 : /* Real */ ae_vector* dst,
3058 : ae_state *_state)
3059 : {
3060 : ae_int_t i;
3061 :
3062 0 : ae_vector_clear(dst);
3063 :
3064 0 : if( src->cnt>0 )
3065 : {
3066 0 : ae_vector_set_length(dst, src->cnt, _state);
3067 0 : for(i=0; i<=src->cnt-1; i++)
3068 : {
3069 0 : dst->ptr.p_double[i] = src->ptr.p_double[i];
3070 : }
3071 : }
3072 0 : }
3073 :
3074 :
3075 : /*************************************************************************
3076 : Copy real matrix
3077 : *************************************************************************/
3078 0 : void copyrealmatrix(/* Real */ ae_matrix* src,
3079 : /* Real */ ae_matrix* dst,
3080 : ae_state *_state)
3081 : {
3082 : ae_int_t i;
3083 : ae_int_t j;
3084 :
3085 0 : ae_matrix_clear(dst);
3086 :
3087 0 : if( src->rows>0&&src->cols>0 )
3088 : {
3089 0 : ae_matrix_set_length(dst, src->rows, src->cols, _state);
3090 0 : for(i=0; i<=src->rows-1; i++)
3091 : {
3092 0 : for(j=0; j<=src->cols-1; j++)
3093 : {
3094 0 : dst->ptr.pp_double[i][j] = src->ptr.pp_double[i][j];
3095 : }
3096 : }
3097 : }
3098 0 : }
3099 :
3100 :
3101 : /*************************************************************************
3102 : Clears integer array
3103 : *************************************************************************/
3104 0 : void unsetintegerarray(/* Integer */ ae_vector* a, ae_state *_state)
3105 : {
3106 :
3107 0 : ae_vector_clear(a);
3108 :
3109 0 : }
3110 :
3111 :
3112 : /*************************************************************************
3113 : Clears real array
3114 : *************************************************************************/
3115 0 : void unsetrealarray(/* Real */ ae_vector* a, ae_state *_state)
3116 : {
3117 :
3118 0 : ae_vector_clear(a);
3119 :
3120 0 : }
3121 :
3122 :
3123 : /*************************************************************************
3124 : Clears real matrix
3125 : *************************************************************************/
3126 0 : void unsetrealmatrix(/* Real */ ae_matrix* a, ae_state *_state)
3127 : {
3128 :
3129 0 : ae_matrix_clear(a);
3130 :
3131 0 : }
3132 :
3133 :
3134 : /*************************************************************************
3135 : This function is used in parallel functions for recurrent division of large
3136 : task into two smaller tasks.
3137 :
3138 : It has following properties:
3139 : * it works only for TaskSize>=2 and TaskSize>TileSize (assertion is thrown otherwise)
3140 : * Task0+Task1=TaskSize, Task0>0, Task1>0
3141 : * Task0 and Task1 are close to each other
3142 : * Task0>=Task1
3143 : * Task0 is always divisible by TileSize
3144 :
3145 : -- ALGLIB --
3146 : Copyright 07.04.2013 by Bochkanov Sergey
3147 : *************************************************************************/
3148 0 : void tiledsplit(ae_int_t tasksize,
3149 : ae_int_t tilesize,
3150 : ae_int_t* task0,
3151 : ae_int_t* task1,
3152 : ae_state *_state)
3153 : {
3154 : ae_int_t cc;
3155 :
3156 0 : *task0 = 0;
3157 0 : *task1 = 0;
3158 :
3159 0 : ae_assert(tasksize>=2, "TiledSplit: TaskSize<2", _state);
3160 0 : ae_assert(tasksize>tilesize, "TiledSplit: TaskSize<=TileSize", _state);
3161 0 : cc = chunkscount(tasksize, tilesize, _state);
3162 0 : ae_assert(cc>=2, "TiledSplit: integrity check failed", _state);
3163 0 : *task0 = idivup(cc, 2, _state)*tilesize;
3164 0 : *task1 = tasksize-(*task0);
3165 0 : ae_assert(*task0>=1, "TiledSplit: internal error", _state);
3166 0 : ae_assert(*task1>=1, "TiledSplit: internal error", _state);
3167 0 : ae_assert(*task0%tilesize==0, "TiledSplit: internal error", _state);
3168 0 : ae_assert(*task0>=(*task1), "TiledSplit: internal error", _state);
3169 0 : }
3170 :
3171 :
3172 : /*************************************************************************
3173 : This function searches integer array. Elements in this array are actually
3174 : records, each NRec elements wide. Each record has unique header - NHeader
3175 : integer values, which identify it. Records are lexicographically sorted by
3176 : header.
3177 :
3178 : Records are identified by their index, not offset (offset = NRec*index).
3179 :
3180 : This function searches A (records with indices [I0,I1)) for a record with
3181 : header B. It returns index of this record (not offset!), or -1 on failure.
3182 :
3183 : -- ALGLIB --
3184 : Copyright 28.03.2011 by Bochkanov Sergey
3185 : *************************************************************************/
3186 0 : ae_int_t recsearch(/* Integer */ ae_vector* a,
3187 : ae_int_t nrec,
3188 : ae_int_t nheader,
3189 : ae_int_t i0,
3190 : ae_int_t i1,
3191 : /* Integer */ ae_vector* b,
3192 : ae_state *_state)
3193 : {
3194 : ae_int_t mididx;
3195 : ae_int_t cflag;
3196 : ae_int_t k;
3197 : ae_int_t offs;
3198 : ae_int_t result;
3199 :
3200 :
3201 0 : result = -1;
3202 : for(;;)
3203 : {
3204 0 : if( i0>=i1 )
3205 : {
3206 0 : break;
3207 : }
3208 0 : mididx = (i0+i1)/2;
3209 0 : offs = nrec*mididx;
3210 0 : cflag = 0;
3211 0 : for(k=0; k<=nheader-1; k++)
3212 : {
3213 0 : if( a->ptr.p_int[offs+k]<b->ptr.p_int[k] )
3214 : {
3215 0 : cflag = -1;
3216 0 : break;
3217 : }
3218 0 : if( a->ptr.p_int[offs+k]>b->ptr.p_int[k] )
3219 : {
3220 0 : cflag = 1;
3221 0 : break;
3222 : }
3223 : }
3224 0 : if( cflag==0 )
3225 : {
3226 0 : result = mididx;
3227 0 : return result;
3228 : }
3229 0 : if( cflag<0 )
3230 : {
3231 0 : i0 = mididx+1;
3232 : }
3233 : else
3234 : {
3235 0 : i1 = mididx;
3236 : }
3237 : }
3238 0 : return result;
3239 : }
3240 :
3241 :
3242 : /*************************************************************************
3243 : This function is used in parallel functions for recurrent division of large
3244 : task into two smaller tasks.
3245 :
3246 : It has following properties:
3247 : * it works only for TaskSize>=2 (assertion is thrown otherwise)
3248 : * for TaskSize=2, it returns Task0=1, Task1=1
3249 : * in case TaskSize is odd, Task0=TaskSize-1, Task1=1
3250 : * in case TaskSize is even, Task0 and Task1 are approximately TaskSize/2
3251 : and both Task0 and Task1 are even, Task0>=Task1
3252 :
3253 : -- ALGLIB --
3254 : Copyright 07.04.2013 by Bochkanov Sergey
3255 : *************************************************************************/
3256 0 : void splitlengtheven(ae_int_t tasksize,
3257 : ae_int_t* task0,
3258 : ae_int_t* task1,
3259 : ae_state *_state)
3260 : {
3261 :
3262 0 : *task0 = 0;
3263 0 : *task1 = 0;
3264 :
3265 0 : ae_assert(tasksize>=2, "SplitLengthEven: TaskSize<2", _state);
3266 0 : if( tasksize==2 )
3267 : {
3268 0 : *task0 = 1;
3269 0 : *task1 = 1;
3270 0 : return;
3271 : }
3272 0 : if( tasksize%2==0 )
3273 : {
3274 :
3275 : /*
3276 : * Even division
3277 : */
3278 0 : *task0 = tasksize/2;
3279 0 : *task1 = tasksize/2;
3280 0 : if( *task0%2!=0 )
3281 : {
3282 0 : *task0 = *task0+1;
3283 0 : *task1 = *task1-1;
3284 : }
3285 : }
3286 : else
3287 : {
3288 :
3289 : /*
3290 : * Odd task size, split trailing odd part from it.
3291 : */
3292 0 : *task0 = tasksize-1;
3293 0 : *task1 = 1;
3294 : }
3295 0 : ae_assert(*task0>=1, "SplitLengthEven: internal error", _state);
3296 0 : ae_assert(*task1>=1, "SplitLengthEven: internal error", _state);
3297 : }
3298 :
3299 :
3300 : /*************************************************************************
3301 : This function is used to calculate number of chunks (including partial,
3302 : non-complete chunks) in some set. It expects that ChunkSize>=1, TaskSize>=0.
3303 : Assertion is thrown otherwise.
3304 :
3305 : Function result is equivalent to Ceil(TaskSize/ChunkSize), but with guarantees
3306 : that rounding errors won't ruin results.
3307 :
3308 : -- ALGLIB --
3309 : Copyright 21.01.2015 by Bochkanov Sergey
3310 : *************************************************************************/
3311 0 : ae_int_t chunkscount(ae_int_t tasksize,
3312 : ae_int_t chunksize,
3313 : ae_state *_state)
3314 : {
3315 : ae_int_t result;
3316 :
3317 :
3318 0 : ae_assert(tasksize>=0, "ChunksCount: TaskSize<0", _state);
3319 0 : ae_assert(chunksize>=1, "ChunksCount: ChunkSize<1", _state);
3320 0 : result = tasksize/chunksize;
3321 0 : if( tasksize%chunksize!=0 )
3322 : {
3323 0 : result = result+1;
3324 : }
3325 0 : return result;
3326 : }
3327 :
3328 :
3329 : /*************************************************************************
3330 : Returns maximum density for level 2 sparse/dense functions. Density values
3331 : below one returned by this function are better to handle via sparse Level 2
3332 : functionality.
3333 :
3334 : -- ALGLIB routine --
3335 : 10.01.2019
3336 : Bochkanov Sergey
3337 : *************************************************************************/
3338 0 : double sparselevel2density(ae_state *_state)
3339 : {
3340 : double result;
3341 :
3342 :
3343 0 : result = 0.1;
3344 0 : return result;
3345 : }
3346 :
3347 :
3348 : /*************************************************************************
3349 : Returns A-tile size for a matrix.
3350 :
3351 : A-tiles are smallest tiles (32x32), suitable for processing by ALGLIB own
3352 : implementation of Level 3 linear algebra.
3353 :
3354 : -- ALGLIB routine --
3355 : 10.01.2019
3356 : Bochkanov Sergey
3357 : *************************************************************************/
3358 0 : ae_int_t matrixtilesizea(ae_state *_state)
3359 : {
3360 : ae_int_t result;
3361 :
3362 :
3363 0 : result = 32;
3364 0 : return result;
3365 : }
3366 :
3367 :
3368 : /*************************************************************************
3369 : Returns B-tile size for a matrix.
3370 :
3371 : B-tiles are larger tiles (64x64), suitable for parallel execution or for
3372 : processing by vendor's implementation of Level 3 linear algebra.
3373 :
3374 : -- ALGLIB routine --
3375 : 10.01.2019
3376 : Bochkanov Sergey
3377 : *************************************************************************/
3378 0 : ae_int_t matrixtilesizeb(ae_state *_state)
3379 : {
3380 : #ifndef ALGLIB_INTERCEPTS_MKL
3381 : ae_int_t result;
3382 :
3383 :
3384 0 : result = 64;
3385 0 : return result;
3386 : #else
3387 : return _ialglib_i_matrixtilesizeb();
3388 : #endif
3389 : }
3390 :
3391 :
3392 : /*************************************************************************
3393 : This function returns minimum cost of task which is feasible for
3394 : multithreaded processing. It returns real number in order to avoid overflow
3395 : problems.
3396 :
3397 : -- ALGLIB --
3398 : Copyright 10.01.2018 by Bochkanov Sergey
3399 : *************************************************************************/
3400 0 : double smpactivationlevel(ae_state *_state)
3401 : {
3402 : double nn;
3403 : double result;
3404 :
3405 :
3406 0 : nn = (double)(2*matrixtilesizeb(_state));
3407 0 : result = ae_maxreal(0.95*2*nn*nn*nn, 1.0E7, _state);
3408 0 : return result;
3409 : }
3410 :
3411 :
3412 : /*************************************************************************
3413 : This function returns minimum cost of task which is feasible for
3414 : spawn (given that multithreading is active).
3415 :
3416 : It returns real number in order to avoid overflow problems.
3417 :
3418 : -- ALGLIB --
3419 : Copyright 10.01.2018 by Bochkanov Sergey
3420 : *************************************************************************/
3421 0 : double spawnlevel(ae_state *_state)
3422 : {
3423 : double nn;
3424 : double result;
3425 :
3426 :
3427 0 : nn = (double)(2*matrixtilesizea(_state));
3428 0 : result = 0.95*2*nn*nn*nn;
3429 0 : return result;
3430 : }
3431 :
3432 :
3433 : /*************************************************************************
3434 : --- OBSOLETE FUNCTION, USE TILED SPLIT INSTEAD ---
3435 :
3436 : This function is used in parallel functions for recurrent division of large
3437 : task into two smaller tasks.
3438 :
3439 : It has following properties:
3440 : * it works only for TaskSize>=2 and ChunkSize>=2
3441 : (assertion is thrown otherwise)
3442 : * Task0+Task1=TaskSize, Task0>0, Task1>0
3443 : * Task0 and Task1 are close to each other
3444 : * in case TaskSize>ChunkSize, Task0 is always divisible by ChunkSize
3445 :
3446 : -- ALGLIB --
3447 : Copyright 07.04.2013 by Bochkanov Sergey
3448 : *************************************************************************/
3449 0 : void splitlength(ae_int_t tasksize,
3450 : ae_int_t chunksize,
3451 : ae_int_t* task0,
3452 : ae_int_t* task1,
3453 : ae_state *_state)
3454 : {
3455 :
3456 0 : *task0 = 0;
3457 0 : *task1 = 0;
3458 :
3459 0 : ae_assert(chunksize>=2, "SplitLength: ChunkSize<2", _state);
3460 0 : ae_assert(tasksize>=2, "SplitLength: TaskSize<2", _state);
3461 0 : *task0 = tasksize/2;
3462 0 : if( *task0>chunksize&&*task0%chunksize!=0 )
3463 : {
3464 0 : *task0 = *task0-*task0%chunksize;
3465 : }
3466 0 : *task1 = tasksize-(*task0);
3467 0 : ae_assert(*task0>=1, "SplitLength: internal error", _state);
3468 0 : ae_assert(*task1>=1, "SplitLength: internal error", _state);
3469 0 : }
3470 :
3471 :
3472 : /*************************************************************************
3473 : Outputs vector A[I0,I1-1] to trace log using either:
3474 : a) 6-digit exponential format (no trace flags is set)
3475 : b) 15-ditit exponential format ('PREC.E15' trace flag is set)
3476 : b) 6-ditit fixed-point format ('PREC.F6' trace flag is set)
3477 :
3478 : This function checks trace flags every time it is called.
3479 : *************************************************************************/
3480 0 : void tracevectorautoprec(/* Real */ ae_vector* a,
3481 : ae_int_t i0,
3482 : ae_int_t i1,
3483 : ae_state *_state)
3484 : {
3485 : ae_int_t i;
3486 : ae_int_t prectouse;
3487 :
3488 :
3489 :
3490 : /*
3491 : * Determine precision to use
3492 : */
3493 0 : prectouse = 0;
3494 0 : if( ae_is_trace_enabled("PREC.E15") )
3495 : {
3496 0 : prectouse = 1;
3497 : }
3498 0 : if( ae_is_trace_enabled("PREC.F6") )
3499 : {
3500 0 : prectouse = 2;
3501 : }
3502 :
3503 : /*
3504 : * Output
3505 : */
3506 0 : ae_trace("[ ");
3507 0 : for(i=i0; i<=i1-1; i++)
3508 : {
3509 0 : if( prectouse==0 )
3510 : {
3511 0 : ae_trace("%14.6e",
3512 0 : (double)(a->ptr.p_double[i]));
3513 : }
3514 0 : if( prectouse==1 )
3515 : {
3516 0 : ae_trace("%23.15e",
3517 0 : (double)(a->ptr.p_double[i]));
3518 : }
3519 0 : if( prectouse==2 )
3520 : {
3521 0 : ae_trace("%13.6f",
3522 0 : (double)(a->ptr.p_double[i]));
3523 : }
3524 0 : if( i<i1-1 )
3525 : {
3526 0 : ae_trace(" ");
3527 : }
3528 : }
3529 0 : ae_trace(" ]");
3530 0 : }
3531 :
3532 :
3533 : /*************************************************************************
3534 : Unscales/unshifts vector A[N] by computing A*Scl+Sft and outputs result to
3535 : trace log using either:
3536 : a) 6-digit exponential format (no trace flags is set)
3537 : b) 15-ditit exponential format ('PREC.E15' trace flag is set)
3538 : b) 6-ditit fixed-point format ('PREC.F6' trace flag is set)
3539 :
3540 : This function checks trace flags every time it is called.
3541 : Both Scl and Sft can be omitted.
3542 : *************************************************************************/
3543 0 : void tracevectorunscaledunshiftedautoprec(/* Real */ ae_vector* x,
3544 : ae_int_t n,
3545 : /* Real */ ae_vector* scl,
3546 : ae_bool applyscl,
3547 : /* Real */ ae_vector* sft,
3548 : ae_bool applysft,
3549 : ae_state *_state)
3550 : {
3551 : ae_int_t i;
3552 : ae_int_t prectouse;
3553 : double v;
3554 :
3555 :
3556 :
3557 : /*
3558 : * Determine precision to use
3559 : */
3560 0 : prectouse = 0;
3561 0 : if( ae_is_trace_enabled("PREC.E15") )
3562 : {
3563 0 : prectouse = 1;
3564 : }
3565 0 : if( ae_is_trace_enabled("PREC.F6") )
3566 : {
3567 0 : prectouse = 2;
3568 : }
3569 :
3570 : /*
3571 : * Output
3572 : */
3573 0 : ae_trace("[ ");
3574 0 : for(i=0; i<=n-1; i++)
3575 : {
3576 0 : v = x->ptr.p_double[i];
3577 0 : if( applyscl )
3578 : {
3579 0 : v = v*scl->ptr.p_double[i];
3580 : }
3581 0 : if( applysft )
3582 : {
3583 0 : v = v+sft->ptr.p_double[i];
3584 : }
3585 0 : if( prectouse==0 )
3586 : {
3587 0 : ae_trace("%14.6e",
3588 : (double)(v));
3589 : }
3590 0 : if( prectouse==1 )
3591 : {
3592 0 : ae_trace("%23.15e",
3593 : (double)(v));
3594 : }
3595 0 : if( prectouse==2 )
3596 : {
3597 0 : ae_trace("%13.6f",
3598 : (double)(v));
3599 : }
3600 0 : if( i<n-1 )
3601 : {
3602 0 : ae_trace(" ");
3603 : }
3604 : }
3605 0 : ae_trace(" ]");
3606 0 : }
3607 :
3608 :
3609 : /*************************************************************************
3610 : Outputs vector of 1-norms of rows [I0,I1-1] of A[I0...I1-1,J0...J1-1] to
3611 : trace log using either:
3612 : a) 6-digit exponential format (no trace flags is set)
3613 : b) 15-ditit exponential format ('PREC.E15' trace flag is set)
3614 : b) 6-ditit fixed-point format ('PREC.F6' trace flag is set)
3615 :
3616 : This function checks trace flags every time it is called.
3617 : *************************************************************************/
3618 0 : void tracerownrm1autoprec(/* Real */ ae_matrix* a,
3619 : ae_int_t i0,
3620 : ae_int_t i1,
3621 : ae_int_t j0,
3622 : ae_int_t j1,
3623 : ae_state *_state)
3624 : {
3625 : ae_int_t i;
3626 : ae_int_t j;
3627 : double v;
3628 : ae_int_t prectouse;
3629 :
3630 :
3631 :
3632 : /*
3633 : * Determine precision to use
3634 : */
3635 0 : prectouse = 0;
3636 0 : if( ae_is_trace_enabled("PREC.E15") )
3637 : {
3638 0 : prectouse = 1;
3639 : }
3640 0 : if( ae_is_trace_enabled("PREC.F6") )
3641 : {
3642 0 : prectouse = 2;
3643 : }
3644 :
3645 : /*
3646 : * Output
3647 : */
3648 0 : ae_trace("[ ");
3649 0 : for(i=i0; i<=i1-1; i++)
3650 : {
3651 0 : v = (double)(0);
3652 0 : for(j=j0; j<=j1-1; j++)
3653 : {
3654 0 : v = ae_maxreal(v, ae_fabs(a->ptr.pp_double[i][j], _state), _state);
3655 : }
3656 0 : if( prectouse==0 )
3657 : {
3658 0 : ae_trace("%14.6e",
3659 : (double)(v));
3660 : }
3661 0 : if( prectouse==1 )
3662 : {
3663 0 : ae_trace("%23.15e",
3664 : (double)(v));
3665 : }
3666 0 : if( prectouse==2 )
3667 : {
3668 0 : ae_trace("%13.6f",
3669 : (double)(v));
3670 : }
3671 0 : if( i<i1-1 )
3672 : {
3673 0 : ae_trace(" ");
3674 : }
3675 : }
3676 0 : ae_trace(" ]");
3677 0 : }
3678 :
3679 :
3680 : /*************************************************************************
3681 : Outputs vector A[I0,I1-1] to trace log using E8 precision
3682 : *************************************************************************/
3683 0 : void tracevectore6(/* Real */ ae_vector* a,
3684 : ae_int_t i0,
3685 : ae_int_t i1,
3686 : ae_state *_state)
3687 : {
3688 : ae_int_t i;
3689 :
3690 :
3691 0 : ae_trace("[ ");
3692 0 : for(i=i0; i<=i1-1; i++)
3693 : {
3694 0 : ae_trace("%14.6e",
3695 0 : (double)(a->ptr.p_double[i]));
3696 0 : if( i<i1-1 )
3697 : {
3698 0 : ae_trace(" ");
3699 : }
3700 : }
3701 0 : ae_trace(" ]");
3702 0 : }
3703 :
3704 :
3705 : /*************************************************************************
3706 : Outputs vector A[I0,I1-1] to trace log using E8 or E15 precision
3707 : *************************************************************************/
3708 0 : void tracevectore615(/* Real */ ae_vector* a,
3709 : ae_int_t i0,
3710 : ae_int_t i1,
3711 : ae_bool usee15,
3712 : ae_state *_state)
3713 : {
3714 : ae_int_t i;
3715 :
3716 :
3717 0 : ae_trace("[ ");
3718 0 : for(i=i0; i<=i1-1; i++)
3719 : {
3720 0 : if( usee15 )
3721 : {
3722 0 : ae_trace("%23.15e",
3723 0 : (double)(a->ptr.p_double[i]));
3724 : }
3725 : else
3726 : {
3727 0 : ae_trace("%14.6e",
3728 0 : (double)(a->ptr.p_double[i]));
3729 : }
3730 0 : if( i<i1-1 )
3731 : {
3732 0 : ae_trace(" ");
3733 : }
3734 : }
3735 0 : ae_trace(" ]");
3736 0 : }
3737 :
3738 :
3739 : /*************************************************************************
3740 : Outputs vector of 1-norms of rows [I0,I1-1] of A[I0...I1-1,J0...J1-1] to
3741 : trace log using E8 precision
3742 : *************************************************************************/
3743 0 : void tracerownrm1e6(/* Real */ ae_matrix* a,
3744 : ae_int_t i0,
3745 : ae_int_t i1,
3746 : ae_int_t j0,
3747 : ae_int_t j1,
3748 : ae_state *_state)
3749 : {
3750 : ae_int_t i;
3751 : ae_int_t j;
3752 : double v;
3753 :
3754 :
3755 0 : ae_trace("[ ");
3756 0 : for(i=i0; i<=i1-1; i++)
3757 : {
3758 0 : v = (double)(0);
3759 0 : for(j=j0; j<=j1-1; j++)
3760 : {
3761 0 : v = ae_maxreal(v, ae_fabs(a->ptr.pp_double[i][j], _state), _state);
3762 : }
3763 0 : ae_trace("%14.6e",
3764 : (double)(v));
3765 0 : if( i<i1-1 )
3766 : {
3767 0 : ae_trace(" ");
3768 : }
3769 : }
3770 0 : ae_trace(" ]");
3771 0 : }
3772 :
3773 :
3774 0 : void _apbuffers_init(void* _p, ae_state *_state, ae_bool make_automatic)
3775 : {
3776 0 : apbuffers *p = (apbuffers*)_p;
3777 0 : ae_touch_ptr((void*)p);
3778 0 : ae_vector_init(&p->ba0, 0, DT_BOOL, _state, make_automatic);
3779 0 : ae_vector_init(&p->ia0, 0, DT_INT, _state, make_automatic);
3780 0 : ae_vector_init(&p->ia1, 0, DT_INT, _state, make_automatic);
3781 0 : ae_vector_init(&p->ia2, 0, DT_INT, _state, make_automatic);
3782 0 : ae_vector_init(&p->ia3, 0, DT_INT, _state, make_automatic);
3783 0 : ae_vector_init(&p->ra0, 0, DT_REAL, _state, make_automatic);
3784 0 : ae_vector_init(&p->ra1, 0, DT_REAL, _state, make_automatic);
3785 0 : ae_vector_init(&p->ra2, 0, DT_REAL, _state, make_automatic);
3786 0 : ae_vector_init(&p->ra3, 0, DT_REAL, _state, make_automatic);
3787 0 : ae_matrix_init(&p->rm0, 0, 0, DT_REAL, _state, make_automatic);
3788 0 : ae_matrix_init(&p->rm1, 0, 0, DT_REAL, _state, make_automatic);
3789 0 : }
3790 :
3791 :
3792 0 : void _apbuffers_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3793 : {
3794 0 : apbuffers *dst = (apbuffers*)_dst;
3795 0 : apbuffers *src = (apbuffers*)_src;
3796 0 : ae_vector_init_copy(&dst->ba0, &src->ba0, _state, make_automatic);
3797 0 : ae_vector_init_copy(&dst->ia0, &src->ia0, _state, make_automatic);
3798 0 : ae_vector_init_copy(&dst->ia1, &src->ia1, _state, make_automatic);
3799 0 : ae_vector_init_copy(&dst->ia2, &src->ia2, _state, make_automatic);
3800 0 : ae_vector_init_copy(&dst->ia3, &src->ia3, _state, make_automatic);
3801 0 : ae_vector_init_copy(&dst->ra0, &src->ra0, _state, make_automatic);
3802 0 : ae_vector_init_copy(&dst->ra1, &src->ra1, _state, make_automatic);
3803 0 : ae_vector_init_copy(&dst->ra2, &src->ra2, _state, make_automatic);
3804 0 : ae_vector_init_copy(&dst->ra3, &src->ra3, _state, make_automatic);
3805 0 : ae_matrix_init_copy(&dst->rm0, &src->rm0, _state, make_automatic);
3806 0 : ae_matrix_init_copy(&dst->rm1, &src->rm1, _state, make_automatic);
3807 0 : }
3808 :
3809 :
3810 0 : void _apbuffers_clear(void* _p)
3811 : {
3812 0 : apbuffers *p = (apbuffers*)_p;
3813 0 : ae_touch_ptr((void*)p);
3814 0 : ae_vector_clear(&p->ba0);
3815 0 : ae_vector_clear(&p->ia0);
3816 0 : ae_vector_clear(&p->ia1);
3817 0 : ae_vector_clear(&p->ia2);
3818 0 : ae_vector_clear(&p->ia3);
3819 0 : ae_vector_clear(&p->ra0);
3820 0 : ae_vector_clear(&p->ra1);
3821 0 : ae_vector_clear(&p->ra2);
3822 0 : ae_vector_clear(&p->ra3);
3823 0 : ae_matrix_clear(&p->rm0);
3824 0 : ae_matrix_clear(&p->rm1);
3825 0 : }
3826 :
3827 :
3828 0 : void _apbuffers_destroy(void* _p)
3829 : {
3830 0 : apbuffers *p = (apbuffers*)_p;
3831 0 : ae_touch_ptr((void*)p);
3832 0 : ae_vector_destroy(&p->ba0);
3833 0 : ae_vector_destroy(&p->ia0);
3834 0 : ae_vector_destroy(&p->ia1);
3835 0 : ae_vector_destroy(&p->ia2);
3836 0 : ae_vector_destroy(&p->ia3);
3837 0 : ae_vector_destroy(&p->ra0);
3838 0 : ae_vector_destroy(&p->ra1);
3839 0 : ae_vector_destroy(&p->ra2);
3840 0 : ae_vector_destroy(&p->ra3);
3841 0 : ae_matrix_destroy(&p->rm0);
3842 0 : ae_matrix_destroy(&p->rm1);
3843 0 : }
3844 :
3845 :
3846 0 : void _sboolean_init(void* _p, ae_state *_state, ae_bool make_automatic)
3847 : {
3848 0 : sboolean *p = (sboolean*)_p;
3849 0 : ae_touch_ptr((void*)p);
3850 0 : }
3851 :
3852 :
3853 0 : void _sboolean_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3854 : {
3855 0 : sboolean *dst = (sboolean*)_dst;
3856 0 : sboolean *src = (sboolean*)_src;
3857 0 : dst->val = src->val;
3858 0 : }
3859 :
3860 :
3861 0 : void _sboolean_clear(void* _p)
3862 : {
3863 0 : sboolean *p = (sboolean*)_p;
3864 0 : ae_touch_ptr((void*)p);
3865 0 : }
3866 :
3867 :
3868 0 : void _sboolean_destroy(void* _p)
3869 : {
3870 0 : sboolean *p = (sboolean*)_p;
3871 0 : ae_touch_ptr((void*)p);
3872 0 : }
3873 :
3874 :
3875 0 : void _sbooleanarray_init(void* _p, ae_state *_state, ae_bool make_automatic)
3876 : {
3877 0 : sbooleanarray *p = (sbooleanarray*)_p;
3878 0 : ae_touch_ptr((void*)p);
3879 0 : ae_vector_init(&p->val, 0, DT_BOOL, _state, make_automatic);
3880 0 : }
3881 :
3882 :
3883 0 : void _sbooleanarray_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3884 : {
3885 0 : sbooleanarray *dst = (sbooleanarray*)_dst;
3886 0 : sbooleanarray *src = (sbooleanarray*)_src;
3887 0 : ae_vector_init_copy(&dst->val, &src->val, _state, make_automatic);
3888 0 : }
3889 :
3890 :
3891 0 : void _sbooleanarray_clear(void* _p)
3892 : {
3893 0 : sbooleanarray *p = (sbooleanarray*)_p;
3894 0 : ae_touch_ptr((void*)p);
3895 0 : ae_vector_clear(&p->val);
3896 0 : }
3897 :
3898 :
3899 0 : void _sbooleanarray_destroy(void* _p)
3900 : {
3901 0 : sbooleanarray *p = (sbooleanarray*)_p;
3902 0 : ae_touch_ptr((void*)p);
3903 0 : ae_vector_destroy(&p->val);
3904 0 : }
3905 :
3906 :
3907 0 : void _sinteger_init(void* _p, ae_state *_state, ae_bool make_automatic)
3908 : {
3909 0 : sinteger *p = (sinteger*)_p;
3910 0 : ae_touch_ptr((void*)p);
3911 0 : }
3912 :
3913 :
3914 0 : void _sinteger_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3915 : {
3916 0 : sinteger *dst = (sinteger*)_dst;
3917 0 : sinteger *src = (sinteger*)_src;
3918 0 : dst->val = src->val;
3919 0 : }
3920 :
3921 :
3922 0 : void _sinteger_clear(void* _p)
3923 : {
3924 0 : sinteger *p = (sinteger*)_p;
3925 0 : ae_touch_ptr((void*)p);
3926 0 : }
3927 :
3928 :
3929 0 : void _sinteger_destroy(void* _p)
3930 : {
3931 0 : sinteger *p = (sinteger*)_p;
3932 0 : ae_touch_ptr((void*)p);
3933 0 : }
3934 :
3935 :
3936 0 : void _sintegerarray_init(void* _p, ae_state *_state, ae_bool make_automatic)
3937 : {
3938 0 : sintegerarray *p = (sintegerarray*)_p;
3939 0 : ae_touch_ptr((void*)p);
3940 0 : ae_vector_init(&p->val, 0, DT_INT, _state, make_automatic);
3941 0 : }
3942 :
3943 :
3944 0 : void _sintegerarray_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3945 : {
3946 0 : sintegerarray *dst = (sintegerarray*)_dst;
3947 0 : sintegerarray *src = (sintegerarray*)_src;
3948 0 : ae_vector_init_copy(&dst->val, &src->val, _state, make_automatic);
3949 0 : }
3950 :
3951 :
3952 0 : void _sintegerarray_clear(void* _p)
3953 : {
3954 0 : sintegerarray *p = (sintegerarray*)_p;
3955 0 : ae_touch_ptr((void*)p);
3956 0 : ae_vector_clear(&p->val);
3957 0 : }
3958 :
3959 :
3960 0 : void _sintegerarray_destroy(void* _p)
3961 : {
3962 0 : sintegerarray *p = (sintegerarray*)_p;
3963 0 : ae_touch_ptr((void*)p);
3964 0 : ae_vector_destroy(&p->val);
3965 0 : }
3966 :
3967 :
3968 0 : void _sreal_init(void* _p, ae_state *_state, ae_bool make_automatic)
3969 : {
3970 0 : sreal *p = (sreal*)_p;
3971 0 : ae_touch_ptr((void*)p);
3972 0 : }
3973 :
3974 :
3975 0 : void _sreal_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
3976 : {
3977 0 : sreal *dst = (sreal*)_dst;
3978 0 : sreal *src = (sreal*)_src;
3979 0 : dst->val = src->val;
3980 0 : }
3981 :
3982 :
3983 0 : void _sreal_clear(void* _p)
3984 : {
3985 0 : sreal *p = (sreal*)_p;
3986 0 : ae_touch_ptr((void*)p);
3987 0 : }
3988 :
3989 :
3990 0 : void _sreal_destroy(void* _p)
3991 : {
3992 0 : sreal *p = (sreal*)_p;
3993 0 : ae_touch_ptr((void*)p);
3994 0 : }
3995 :
3996 :
3997 0 : void _srealarray_init(void* _p, ae_state *_state, ae_bool make_automatic)
3998 : {
3999 0 : srealarray *p = (srealarray*)_p;
4000 0 : ae_touch_ptr((void*)p);
4001 0 : ae_vector_init(&p->val, 0, DT_REAL, _state, make_automatic);
4002 0 : }
4003 :
4004 :
4005 0 : void _srealarray_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
4006 : {
4007 0 : srealarray *dst = (srealarray*)_dst;
4008 0 : srealarray *src = (srealarray*)_src;
4009 0 : ae_vector_init_copy(&dst->val, &src->val, _state, make_automatic);
4010 0 : }
4011 :
4012 :
4013 0 : void _srealarray_clear(void* _p)
4014 : {
4015 0 : srealarray *p = (srealarray*)_p;
4016 0 : ae_touch_ptr((void*)p);
4017 0 : ae_vector_clear(&p->val);
4018 0 : }
4019 :
4020 :
4021 0 : void _srealarray_destroy(void* _p)
4022 : {
4023 0 : srealarray *p = (srealarray*)_p;
4024 0 : ae_touch_ptr((void*)p);
4025 0 : ae_vector_destroy(&p->val);
4026 0 : }
4027 :
4028 :
4029 0 : void _scomplex_init(void* _p, ae_state *_state, ae_bool make_automatic)
4030 : {
4031 0 : scomplex *p = (scomplex*)_p;
4032 0 : ae_touch_ptr((void*)p);
4033 0 : }
4034 :
4035 :
4036 0 : void _scomplex_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
4037 : {
4038 0 : scomplex *dst = (scomplex*)_dst;
4039 0 : scomplex *src = (scomplex*)_src;
4040 0 : dst->val = src->val;
4041 0 : }
4042 :
4043 :
4044 0 : void _scomplex_clear(void* _p)
4045 : {
4046 0 : scomplex *p = (scomplex*)_p;
4047 0 : ae_touch_ptr((void*)p);
4048 0 : }
4049 :
4050 :
4051 0 : void _scomplex_destroy(void* _p)
4052 : {
4053 0 : scomplex *p = (scomplex*)_p;
4054 0 : ae_touch_ptr((void*)p);
4055 0 : }
4056 :
4057 :
4058 0 : void _scomplexarray_init(void* _p, ae_state *_state, ae_bool make_automatic)
4059 : {
4060 0 : scomplexarray *p = (scomplexarray*)_p;
4061 0 : ae_touch_ptr((void*)p);
4062 0 : ae_vector_init(&p->val, 0, DT_COMPLEX, _state, make_automatic);
4063 0 : }
4064 :
4065 :
4066 0 : void _scomplexarray_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
4067 : {
4068 0 : scomplexarray *dst = (scomplexarray*)_dst;
4069 0 : scomplexarray *src = (scomplexarray*)_src;
4070 0 : ae_vector_init_copy(&dst->val, &src->val, _state, make_automatic);
4071 0 : }
4072 :
4073 :
4074 0 : void _scomplexarray_clear(void* _p)
4075 : {
4076 0 : scomplexarray *p = (scomplexarray*)_p;
4077 0 : ae_touch_ptr((void*)p);
4078 0 : ae_vector_clear(&p->val);
4079 0 : }
4080 :
4081 :
4082 0 : void _scomplexarray_destroy(void* _p)
4083 : {
4084 0 : scomplexarray *p = (scomplexarray*)_p;
4085 0 : ae_touch_ptr((void*)p);
4086 0 : ae_vector_destroy(&p->val);
4087 0 : }
4088 :
4089 :
4090 : #endif
4091 : #if defined(AE_COMPILE_TSORT) || !defined(AE_PARTIAL_BUILD)
4092 :
4093 :
4094 : /*************************************************************************
4095 : This function sorts array of real keys by ascending.
4096 :
4097 : Its results are:
4098 : * sorted array A
4099 : * permutation tables P1, P2
4100 :
4101 : Algorithm outputs permutation tables using two formats:
4102 : * as usual permutation of [0..N-1]. If P1[i]=j, then sorted A[i] contains
4103 : value which was moved there from J-th position.
4104 : * as a sequence of pairwise permutations. Sorted A[] may be obtained by
4105 : swaping A[i] and A[P2[i]] for all i from 0 to N-1.
4106 :
4107 : INPUT PARAMETERS:
4108 : A - unsorted array
4109 : N - array size
4110 :
4111 : OUPUT PARAMETERS:
4112 : A - sorted array
4113 : P1, P2 - permutation tables, array[N]
4114 :
4115 : NOTES:
4116 : this function assumes that A[] is finite; it doesn't checks that
4117 : condition. All other conditions (size of input arrays, etc.) are not
4118 : checked too.
4119 :
4120 : -- ALGLIB --
4121 : Copyright 14.05.2008 by Bochkanov Sergey
4122 : *************************************************************************/
4123 0 : void tagsort(/* Real */ ae_vector* a,
4124 : ae_int_t n,
4125 : /* Integer */ ae_vector* p1,
4126 : /* Integer */ ae_vector* p2,
4127 : ae_state *_state)
4128 : {
4129 : ae_frame _frame_block;
4130 : apbuffers buf;
4131 :
4132 0 : ae_frame_make(_state, &_frame_block);
4133 0 : memset(&buf, 0, sizeof(buf));
4134 0 : ae_vector_clear(p1);
4135 0 : ae_vector_clear(p2);
4136 0 : _apbuffers_init(&buf, _state, ae_true);
4137 :
4138 0 : tagsortbuf(a, n, p1, p2, &buf, _state);
4139 0 : ae_frame_leave(_state);
4140 0 : }
4141 :
4142 :
4143 : /*************************************************************************
4144 : Buffered variant of TagSort, which accepts preallocated output arrays as
4145 : well as special structure for buffered allocations. If arrays are too
4146 : short, they are reallocated. If they are large enough, no memory
4147 : allocation is done.
4148 :
4149 : It is intended to be used in the performance-critical parts of code, where
4150 : additional allocations can lead to severe performance degradation
4151 :
4152 : -- ALGLIB --
4153 : Copyright 14.05.2008 by Bochkanov Sergey
4154 : *************************************************************************/
4155 0 : void tagsortbuf(/* Real */ ae_vector* a,
4156 : ae_int_t n,
4157 : /* Integer */ ae_vector* p1,
4158 : /* Integer */ ae_vector* p2,
4159 : apbuffers* buf,
4160 : ae_state *_state)
4161 : {
4162 : ae_int_t i;
4163 : ae_int_t lv;
4164 : ae_int_t lp;
4165 : ae_int_t rv;
4166 : ae_int_t rp;
4167 :
4168 :
4169 :
4170 : /*
4171 : * Special cases
4172 : */
4173 0 : if( n<=0 )
4174 : {
4175 0 : return;
4176 : }
4177 0 : if( n==1 )
4178 : {
4179 0 : ivectorsetlengthatleast(p1, 1, _state);
4180 0 : ivectorsetlengthatleast(p2, 1, _state);
4181 0 : p1->ptr.p_int[0] = 0;
4182 0 : p2->ptr.p_int[0] = 0;
4183 0 : return;
4184 : }
4185 :
4186 : /*
4187 : * General case, N>1: prepare permutations table P1
4188 : */
4189 0 : ivectorsetlengthatleast(p1, n, _state);
4190 0 : for(i=0; i<=n-1; i++)
4191 : {
4192 0 : p1->ptr.p_int[i] = i;
4193 : }
4194 :
4195 : /*
4196 : * General case, N>1: sort, update P1
4197 : */
4198 0 : rvectorsetlengthatleast(&buf->ra0, n, _state);
4199 0 : ivectorsetlengthatleast(&buf->ia0, n, _state);
4200 0 : tagsortfasti(a, p1, &buf->ra0, &buf->ia0, n, _state);
4201 :
4202 : /*
4203 : * General case, N>1: fill permutations table P2
4204 : *
4205 : * To fill P2 we maintain two arrays:
4206 : * * PV (Buf.IA0), Position(Value). PV[i] contains position of I-th key at the moment
4207 : * * VP (Buf.IA1), Value(Position). VP[i] contains key which has position I at the moment
4208 : *
4209 : * At each step we making permutation of two items:
4210 : * Left, which is given by position/value pair LP/LV
4211 : * and Right, which is given by RP/RV
4212 : * and updating PV[] and VP[] correspondingly.
4213 : */
4214 0 : ivectorsetlengthatleast(&buf->ia0, n, _state);
4215 0 : ivectorsetlengthatleast(&buf->ia1, n, _state);
4216 0 : ivectorsetlengthatleast(p2, n, _state);
4217 0 : for(i=0; i<=n-1; i++)
4218 : {
4219 0 : buf->ia0.ptr.p_int[i] = i;
4220 0 : buf->ia1.ptr.p_int[i] = i;
4221 : }
4222 0 : for(i=0; i<=n-1; i++)
4223 : {
4224 :
4225 : /*
4226 : * calculate LP, LV, RP, RV
4227 : */
4228 0 : lp = i;
4229 0 : lv = buf->ia1.ptr.p_int[lp];
4230 0 : rv = p1->ptr.p_int[i];
4231 0 : rp = buf->ia0.ptr.p_int[rv];
4232 :
4233 : /*
4234 : * Fill P2
4235 : */
4236 0 : p2->ptr.p_int[i] = rp;
4237 :
4238 : /*
4239 : * update PV and VP
4240 : */
4241 0 : buf->ia1.ptr.p_int[lp] = rv;
4242 0 : buf->ia1.ptr.p_int[rp] = lv;
4243 0 : buf->ia0.ptr.p_int[lv] = rp;
4244 0 : buf->ia0.ptr.p_int[rv] = lp;
4245 : }
4246 : }
4247 :
4248 :
4249 : /*************************************************************************
4250 : Same as TagSort, but optimized for real keys and integer labels.
4251 :
4252 : A is sorted, and same permutations are applied to B.
4253 :
4254 : NOTES:
4255 : 1. this function assumes that A[] is finite; it doesn't checks that
4256 : condition. All other conditions (size of input arrays, etc.) are not
4257 : checked too.
4258 : 2. this function uses two buffers, BufA and BufB, each is N elements large.
4259 : They may be preallocated (which will save some time) or not, in which
4260 : case function will automatically allocate memory.
4261 :
4262 : -- ALGLIB --
4263 : Copyright 11.12.2008 by Bochkanov Sergey
4264 : *************************************************************************/
4265 0 : void tagsortfasti(/* Real */ ae_vector* a,
4266 : /* Integer */ ae_vector* b,
4267 : /* Real */ ae_vector* bufa,
4268 : /* Integer */ ae_vector* bufb,
4269 : ae_int_t n,
4270 : ae_state *_state)
4271 : {
4272 : ae_int_t i;
4273 : ae_int_t j;
4274 : ae_bool isascending;
4275 : ae_bool isdescending;
4276 : double tmpr;
4277 : ae_int_t tmpi;
4278 :
4279 :
4280 :
4281 : /*
4282 : * Special case
4283 : */
4284 0 : if( n<=1 )
4285 : {
4286 0 : return;
4287 : }
4288 :
4289 : /*
4290 : * Test for already sorted set
4291 : */
4292 0 : isascending = ae_true;
4293 0 : isdescending = ae_true;
4294 0 : for(i=1; i<=n-1; i++)
4295 : {
4296 0 : isascending = isascending&&a->ptr.p_double[i]>=a->ptr.p_double[i-1];
4297 0 : isdescending = isdescending&&a->ptr.p_double[i]<=a->ptr.p_double[i-1];
4298 : }
4299 0 : if( isascending )
4300 : {
4301 0 : return;
4302 : }
4303 0 : if( isdescending )
4304 : {
4305 0 : for(i=0; i<=n-1; i++)
4306 : {
4307 0 : j = n-1-i;
4308 0 : if( j<=i )
4309 : {
4310 0 : break;
4311 : }
4312 0 : tmpr = a->ptr.p_double[i];
4313 0 : a->ptr.p_double[i] = a->ptr.p_double[j];
4314 0 : a->ptr.p_double[j] = tmpr;
4315 0 : tmpi = b->ptr.p_int[i];
4316 0 : b->ptr.p_int[i] = b->ptr.p_int[j];
4317 0 : b->ptr.p_int[j] = tmpi;
4318 : }
4319 0 : return;
4320 : }
4321 :
4322 : /*
4323 : * General case
4324 : */
4325 0 : if( bufa->cnt<n )
4326 : {
4327 0 : ae_vector_set_length(bufa, n, _state);
4328 : }
4329 0 : if( bufb->cnt<n )
4330 : {
4331 0 : ae_vector_set_length(bufb, n, _state);
4332 : }
4333 0 : tsort_tagsortfastirec(a, b, bufa, bufb, 0, n-1, _state);
4334 : }
4335 :
4336 :
4337 : /*************************************************************************
4338 : Same as TagSort, but optimized for real keys and real labels.
4339 :
4340 : A is sorted, and same permutations are applied to B.
4341 :
4342 : NOTES:
4343 : 1. this function assumes that A[] is finite; it doesn't checks that
4344 : condition. All other conditions (size of input arrays, etc.) are not
4345 : checked too.
4346 : 2. this function uses two buffers, BufA and BufB, each is N elements large.
4347 : They may be preallocated (which will save some time) or not, in which
4348 : case function will automatically allocate memory.
4349 :
4350 : -- ALGLIB --
4351 : Copyright 11.12.2008 by Bochkanov Sergey
4352 : *************************************************************************/
4353 0 : void tagsortfastr(/* Real */ ae_vector* a,
4354 : /* Real */ ae_vector* b,
4355 : /* Real */ ae_vector* bufa,
4356 : /* Real */ ae_vector* bufb,
4357 : ae_int_t n,
4358 : ae_state *_state)
4359 : {
4360 : ae_int_t i;
4361 : ae_int_t j;
4362 : ae_bool isascending;
4363 : ae_bool isdescending;
4364 : double tmpr;
4365 :
4366 :
4367 :
4368 : /*
4369 : * Special case
4370 : */
4371 0 : if( n<=1 )
4372 : {
4373 0 : return;
4374 : }
4375 :
4376 : /*
4377 : * Test for already sorted set
4378 : */
4379 0 : isascending = ae_true;
4380 0 : isdescending = ae_true;
4381 0 : for(i=1; i<=n-1; i++)
4382 : {
4383 0 : isascending = isascending&&a->ptr.p_double[i]>=a->ptr.p_double[i-1];
4384 0 : isdescending = isdescending&&a->ptr.p_double[i]<=a->ptr.p_double[i-1];
4385 : }
4386 0 : if( isascending )
4387 : {
4388 0 : return;
4389 : }
4390 0 : if( isdescending )
4391 : {
4392 0 : for(i=0; i<=n-1; i++)
4393 : {
4394 0 : j = n-1-i;
4395 0 : if( j<=i )
4396 : {
4397 0 : break;
4398 : }
4399 0 : tmpr = a->ptr.p_double[i];
4400 0 : a->ptr.p_double[i] = a->ptr.p_double[j];
4401 0 : a->ptr.p_double[j] = tmpr;
4402 0 : tmpr = b->ptr.p_double[i];
4403 0 : b->ptr.p_double[i] = b->ptr.p_double[j];
4404 0 : b->ptr.p_double[j] = tmpr;
4405 : }
4406 0 : return;
4407 : }
4408 :
4409 : /*
4410 : * General case
4411 : */
4412 0 : if( bufa->cnt<n )
4413 : {
4414 0 : ae_vector_set_length(bufa, n, _state);
4415 : }
4416 0 : if( bufb->cnt<n )
4417 : {
4418 0 : ae_vector_set_length(bufb, n, _state);
4419 : }
4420 0 : tsort_tagsortfastrrec(a, b, bufa, bufb, 0, n-1, _state);
4421 : }
4422 :
4423 :
4424 : /*************************************************************************
4425 : Same as TagSort, but optimized for real keys without labels.
4426 :
4427 : A is sorted, and that's all.
4428 :
4429 : NOTES:
4430 : 1. this function assumes that A[] is finite; it doesn't checks that
4431 : condition. All other conditions (size of input arrays, etc.) are not
4432 : checked too.
4433 : 2. this function uses buffer, BufA, which is N elements large. It may be
4434 : preallocated (which will save some time) or not, in which case
4435 : function will automatically allocate memory.
4436 :
4437 : -- ALGLIB --
4438 : Copyright 11.12.2008 by Bochkanov Sergey
4439 : *************************************************************************/
4440 0 : void tagsortfast(/* Real */ ae_vector* a,
4441 : /* Real */ ae_vector* bufa,
4442 : ae_int_t n,
4443 : ae_state *_state)
4444 : {
4445 : ae_int_t i;
4446 : ae_int_t j;
4447 : ae_bool isascending;
4448 : ae_bool isdescending;
4449 : double tmpr;
4450 :
4451 :
4452 :
4453 : /*
4454 : * Special case
4455 : */
4456 0 : if( n<=1 )
4457 : {
4458 0 : return;
4459 : }
4460 :
4461 : /*
4462 : * Test for already sorted set
4463 : */
4464 0 : isascending = ae_true;
4465 0 : isdescending = ae_true;
4466 0 : for(i=1; i<=n-1; i++)
4467 : {
4468 0 : isascending = isascending&&a->ptr.p_double[i]>=a->ptr.p_double[i-1];
4469 0 : isdescending = isdescending&&a->ptr.p_double[i]<=a->ptr.p_double[i-1];
4470 : }
4471 0 : if( isascending )
4472 : {
4473 0 : return;
4474 : }
4475 0 : if( isdescending )
4476 : {
4477 0 : for(i=0; i<=n-1; i++)
4478 : {
4479 0 : j = n-1-i;
4480 0 : if( j<=i )
4481 : {
4482 0 : break;
4483 : }
4484 0 : tmpr = a->ptr.p_double[i];
4485 0 : a->ptr.p_double[i] = a->ptr.p_double[j];
4486 0 : a->ptr.p_double[j] = tmpr;
4487 : }
4488 0 : return;
4489 : }
4490 :
4491 : /*
4492 : * General case
4493 : */
4494 0 : if( bufa->cnt<n )
4495 : {
4496 0 : ae_vector_set_length(bufa, n, _state);
4497 : }
4498 0 : tsort_tagsortfastrec(a, bufa, 0, n-1, _state);
4499 : }
4500 :
4501 :
4502 : /*************************************************************************
4503 : Sorting function optimized for integer keys and real labels, can be used
4504 : to sort middle of the array
4505 :
4506 : A is sorted, and same permutations are applied to B.
4507 :
4508 : NOTES:
4509 : this function assumes that A[] is finite; it doesn't checks that
4510 : condition. All other conditions (size of input arrays, etc.) are not
4511 : checked too.
4512 :
4513 : -- ALGLIB --
4514 : Copyright 11.12.2008 by Bochkanov Sergey
4515 : *************************************************************************/
4516 0 : void tagsortmiddleir(/* Integer */ ae_vector* a,
4517 : /* Real */ ae_vector* b,
4518 : ae_int_t offset,
4519 : ae_int_t n,
4520 : ae_state *_state)
4521 : {
4522 : ae_int_t i;
4523 : ae_int_t k;
4524 : ae_int_t t;
4525 : ae_int_t tmp;
4526 : double tmpr;
4527 : ae_int_t p0;
4528 : ae_int_t p1;
4529 : ae_int_t at;
4530 : ae_int_t ak;
4531 : ae_int_t ak1;
4532 : double bt;
4533 :
4534 :
4535 :
4536 : /*
4537 : * Special cases
4538 : */
4539 0 : if( n<=1 )
4540 : {
4541 0 : return;
4542 : }
4543 :
4544 : /*
4545 : * General case, N>1: sort, update B
4546 : */
4547 0 : for(i=2; i<=n; i++)
4548 : {
4549 0 : t = i;
4550 0 : while(t!=1)
4551 : {
4552 0 : k = t/2;
4553 0 : p0 = offset+k-1;
4554 0 : p1 = offset+t-1;
4555 0 : ak = a->ptr.p_int[p0];
4556 0 : at = a->ptr.p_int[p1];
4557 0 : if( ak>=at )
4558 : {
4559 0 : break;
4560 : }
4561 0 : a->ptr.p_int[p0] = at;
4562 0 : a->ptr.p_int[p1] = ak;
4563 0 : tmpr = b->ptr.p_double[p0];
4564 0 : b->ptr.p_double[p0] = b->ptr.p_double[p1];
4565 0 : b->ptr.p_double[p1] = tmpr;
4566 0 : t = k;
4567 : }
4568 : }
4569 0 : for(i=n-1; i>=1; i--)
4570 : {
4571 0 : p0 = offset+0;
4572 0 : p1 = offset+i;
4573 0 : tmp = a->ptr.p_int[p1];
4574 0 : a->ptr.p_int[p1] = a->ptr.p_int[p0];
4575 0 : a->ptr.p_int[p0] = tmp;
4576 0 : at = tmp;
4577 0 : tmpr = b->ptr.p_double[p1];
4578 0 : b->ptr.p_double[p1] = b->ptr.p_double[p0];
4579 0 : b->ptr.p_double[p0] = tmpr;
4580 0 : bt = tmpr;
4581 0 : t = 0;
4582 : for(;;)
4583 : {
4584 0 : k = 2*t+1;
4585 0 : if( k+1>i )
4586 : {
4587 0 : break;
4588 : }
4589 0 : p0 = offset+t;
4590 0 : p1 = offset+k;
4591 0 : ak = a->ptr.p_int[p1];
4592 0 : if( k+1<i )
4593 : {
4594 0 : ak1 = a->ptr.p_int[p1+1];
4595 0 : if( ak1>ak )
4596 : {
4597 0 : ak = ak1;
4598 0 : p1 = p1+1;
4599 0 : k = k+1;
4600 : }
4601 : }
4602 0 : if( at>=ak )
4603 : {
4604 0 : break;
4605 : }
4606 0 : a->ptr.p_int[p1] = at;
4607 0 : a->ptr.p_int[p0] = ak;
4608 0 : b->ptr.p_double[p0] = b->ptr.p_double[p1];
4609 0 : b->ptr.p_double[p1] = bt;
4610 0 : t = k;
4611 : }
4612 : }
4613 : }
4614 :
4615 :
4616 : /*************************************************************************
4617 : Sorting function optimized for integer keys and real labels, can be used
4618 : to sort middle of the array
4619 :
4620 : A is sorted, and same permutations are applied to B.
4621 :
4622 : NOTES:
4623 : this function assumes that A[] is finite; it doesn't checks that
4624 : condition. All other conditions (size of input arrays, etc.) are not
4625 : checked too.
4626 :
4627 : -- ALGLIB --
4628 : Copyright 11.12.2008 by Bochkanov Sergey
4629 : *************************************************************************/
4630 0 : void tagsortmiddlei(/* Integer */ ae_vector* a,
4631 : ae_int_t offset,
4632 : ae_int_t n,
4633 : ae_state *_state)
4634 : {
4635 : ae_int_t i;
4636 : ae_int_t k;
4637 : ae_int_t t;
4638 : ae_int_t tmp;
4639 : ae_int_t p0;
4640 : ae_int_t p1;
4641 : ae_int_t at;
4642 : ae_int_t ak;
4643 : ae_int_t ak1;
4644 :
4645 :
4646 :
4647 : /*
4648 : * Special cases
4649 : */
4650 0 : if( n<=1 )
4651 : {
4652 0 : return;
4653 : }
4654 :
4655 : /*
4656 : * General case, N>1: sort, update B
4657 : */
4658 0 : for(i=2; i<=n; i++)
4659 : {
4660 0 : t = i;
4661 0 : while(t!=1)
4662 : {
4663 0 : k = t/2;
4664 0 : p0 = offset+k-1;
4665 0 : p1 = offset+t-1;
4666 0 : ak = a->ptr.p_int[p0];
4667 0 : at = a->ptr.p_int[p1];
4668 0 : if( ak>=at )
4669 : {
4670 0 : break;
4671 : }
4672 0 : a->ptr.p_int[p0] = at;
4673 0 : a->ptr.p_int[p1] = ak;
4674 0 : t = k;
4675 : }
4676 : }
4677 0 : for(i=n-1; i>=1; i--)
4678 : {
4679 0 : p0 = offset+0;
4680 0 : p1 = offset+i;
4681 0 : tmp = a->ptr.p_int[p1];
4682 0 : a->ptr.p_int[p1] = a->ptr.p_int[p0];
4683 0 : a->ptr.p_int[p0] = tmp;
4684 0 : at = tmp;
4685 0 : t = 0;
4686 : for(;;)
4687 : {
4688 0 : k = 2*t+1;
4689 0 : if( k+1>i )
4690 : {
4691 0 : break;
4692 : }
4693 0 : p0 = offset+t;
4694 0 : p1 = offset+k;
4695 0 : ak = a->ptr.p_int[p1];
4696 0 : if( k+1<i )
4697 : {
4698 0 : ak1 = a->ptr.p_int[p1+1];
4699 0 : if( ak1>ak )
4700 : {
4701 0 : ak = ak1;
4702 0 : p1 = p1+1;
4703 0 : k = k+1;
4704 : }
4705 : }
4706 0 : if( at>=ak )
4707 : {
4708 0 : break;
4709 : }
4710 0 : a->ptr.p_int[p1] = at;
4711 0 : a->ptr.p_int[p0] = ak;
4712 0 : t = k;
4713 : }
4714 : }
4715 : }
4716 :
4717 :
4718 : /*************************************************************************
4719 : Sorting function optimized for integer values (only keys, no labels), can
4720 : be used to sort middle of the array
4721 :
4722 : -- ALGLIB --
4723 : Copyright 11.12.2008 by Bochkanov Sergey
4724 : *************************************************************************/
4725 0 : void sortmiddlei(/* Integer */ ae_vector* a,
4726 : ae_int_t offset,
4727 : ae_int_t n,
4728 : ae_state *_state)
4729 : {
4730 : ae_int_t i;
4731 : ae_int_t k;
4732 : ae_int_t t;
4733 : ae_int_t tmp;
4734 : ae_int_t p0;
4735 : ae_int_t p1;
4736 : ae_int_t at;
4737 : ae_int_t ak;
4738 : ae_int_t ak1;
4739 :
4740 :
4741 :
4742 : /*
4743 : * Special cases
4744 : */
4745 0 : if( n<=1 )
4746 : {
4747 0 : return;
4748 : }
4749 :
4750 : /*
4751 : * General case, N>1: sort, update B
4752 : */
4753 0 : for(i=2; i<=n; i++)
4754 : {
4755 0 : t = i;
4756 0 : while(t!=1)
4757 : {
4758 0 : k = t/2;
4759 0 : p0 = offset+k-1;
4760 0 : p1 = offset+t-1;
4761 0 : ak = a->ptr.p_int[p0];
4762 0 : at = a->ptr.p_int[p1];
4763 0 : if( ak>=at )
4764 : {
4765 0 : break;
4766 : }
4767 0 : a->ptr.p_int[p0] = at;
4768 0 : a->ptr.p_int[p1] = ak;
4769 0 : t = k;
4770 : }
4771 : }
4772 0 : for(i=n-1; i>=1; i--)
4773 : {
4774 0 : p0 = offset+0;
4775 0 : p1 = offset+i;
4776 0 : tmp = a->ptr.p_int[p1];
4777 0 : a->ptr.p_int[p1] = a->ptr.p_int[p0];
4778 0 : a->ptr.p_int[p0] = tmp;
4779 0 : at = tmp;
4780 0 : t = 0;
4781 : for(;;)
4782 : {
4783 0 : k = 2*t+1;
4784 0 : if( k+1>i )
4785 : {
4786 0 : break;
4787 : }
4788 0 : p0 = offset+t;
4789 0 : p1 = offset+k;
4790 0 : ak = a->ptr.p_int[p1];
4791 0 : if( k+1<i )
4792 : {
4793 0 : ak1 = a->ptr.p_int[p1+1];
4794 0 : if( ak1>ak )
4795 : {
4796 0 : ak = ak1;
4797 0 : p1 = p1+1;
4798 0 : k = k+1;
4799 : }
4800 : }
4801 0 : if( at>=ak )
4802 : {
4803 0 : break;
4804 : }
4805 0 : a->ptr.p_int[p1] = at;
4806 0 : a->ptr.p_int[p0] = ak;
4807 0 : t = k;
4808 : }
4809 : }
4810 : }
4811 :
4812 :
4813 : /*************************************************************************
4814 : Heap operations: adds element to the heap
4815 :
4816 : PARAMETERS:
4817 : A - heap itself, must be at least array[0..N]
4818 : B - array of integer tags, which are updated according to
4819 : permutations in the heap
4820 : N - size of the heap (without new element).
4821 : updated on output
4822 : VA - value of the element being added
4823 : VB - value of the tag
4824 :
4825 : -- ALGLIB --
4826 : Copyright 28.02.2010 by Bochkanov Sergey
4827 : *************************************************************************/
4828 0 : void tagheappushi(/* Real */ ae_vector* a,
4829 : /* Integer */ ae_vector* b,
4830 : ae_int_t* n,
4831 : double va,
4832 : ae_int_t vb,
4833 : ae_state *_state)
4834 : {
4835 : ae_int_t j;
4836 : ae_int_t k;
4837 : double v;
4838 :
4839 :
4840 0 : if( *n<0 )
4841 : {
4842 0 : return;
4843 : }
4844 :
4845 : /*
4846 : * N=0 is a special case
4847 : */
4848 0 : if( *n==0 )
4849 : {
4850 0 : a->ptr.p_double[0] = va;
4851 0 : b->ptr.p_int[0] = vb;
4852 0 : *n = *n+1;
4853 0 : return;
4854 : }
4855 :
4856 : /*
4857 : * add current point to the heap
4858 : * (add to the bottom, then move up)
4859 : *
4860 : * we don't write point to the heap
4861 : * until its final position is determined
4862 : * (it allow us to reduce number of array access operations)
4863 : */
4864 0 : j = *n;
4865 0 : *n = *n+1;
4866 0 : while(j>0)
4867 : {
4868 0 : k = (j-1)/2;
4869 0 : v = a->ptr.p_double[k];
4870 0 : if( v<va )
4871 : {
4872 :
4873 : /*
4874 : * swap with higher element
4875 : */
4876 0 : a->ptr.p_double[j] = v;
4877 0 : b->ptr.p_int[j] = b->ptr.p_int[k];
4878 0 : j = k;
4879 : }
4880 : else
4881 : {
4882 :
4883 : /*
4884 : * element in its place. terminate.
4885 : */
4886 0 : break;
4887 : }
4888 : }
4889 0 : a->ptr.p_double[j] = va;
4890 0 : b->ptr.p_int[j] = vb;
4891 : }
4892 :
4893 :
4894 : /*************************************************************************
4895 : Heap operations: replaces top element with new element
4896 : (which is moved down)
4897 :
4898 : PARAMETERS:
4899 : A - heap itself, must be at least array[0..N-1]
4900 : B - array of integer tags, which are updated according to
4901 : permutations in the heap
4902 : N - size of the heap
4903 : VA - value of the element which replaces top element
4904 : VB - value of the tag
4905 :
4906 : -- ALGLIB --
4907 : Copyright 28.02.2010 by Bochkanov Sergey
4908 : *************************************************************************/
4909 0 : void tagheapreplacetopi(/* Real */ ae_vector* a,
4910 : /* Integer */ ae_vector* b,
4911 : ae_int_t n,
4912 : double va,
4913 : ae_int_t vb,
4914 : ae_state *_state)
4915 : {
4916 : ae_int_t j;
4917 : ae_int_t k1;
4918 : ae_int_t k2;
4919 : double v;
4920 : double v1;
4921 : double v2;
4922 :
4923 :
4924 0 : if( n<1 )
4925 : {
4926 0 : return;
4927 : }
4928 :
4929 : /*
4930 : * N=1 is a special case
4931 : */
4932 0 : if( n==1 )
4933 : {
4934 0 : a->ptr.p_double[0] = va;
4935 0 : b->ptr.p_int[0] = vb;
4936 0 : return;
4937 : }
4938 :
4939 : /*
4940 : * move down through heap:
4941 : * * J - current element
4942 : * * K1 - first child (always exists)
4943 : * * K2 - second child (may not exists)
4944 : *
4945 : * we don't write point to the heap
4946 : * until its final position is determined
4947 : * (it allow us to reduce number of array access operations)
4948 : */
4949 0 : j = 0;
4950 0 : k1 = 1;
4951 0 : k2 = 2;
4952 0 : while(k1<n)
4953 : {
4954 0 : if( k2>=n )
4955 : {
4956 :
4957 : /*
4958 : * only one child.
4959 : *
4960 : * swap and terminate (because this child
4961 : * have no siblings due to heap structure)
4962 : */
4963 0 : v = a->ptr.p_double[k1];
4964 0 : if( v>va )
4965 : {
4966 0 : a->ptr.p_double[j] = v;
4967 0 : b->ptr.p_int[j] = b->ptr.p_int[k1];
4968 0 : j = k1;
4969 : }
4970 0 : break;
4971 : }
4972 : else
4973 : {
4974 :
4975 : /*
4976 : * two childs
4977 : */
4978 0 : v1 = a->ptr.p_double[k1];
4979 0 : v2 = a->ptr.p_double[k2];
4980 0 : if( v1>v2 )
4981 : {
4982 0 : if( va<v1 )
4983 : {
4984 0 : a->ptr.p_double[j] = v1;
4985 0 : b->ptr.p_int[j] = b->ptr.p_int[k1];
4986 0 : j = k1;
4987 : }
4988 : else
4989 : {
4990 0 : break;
4991 : }
4992 : }
4993 : else
4994 : {
4995 0 : if( va<v2 )
4996 : {
4997 0 : a->ptr.p_double[j] = v2;
4998 0 : b->ptr.p_int[j] = b->ptr.p_int[k2];
4999 0 : j = k2;
5000 : }
5001 : else
5002 : {
5003 0 : break;
5004 : }
5005 : }
5006 0 : k1 = 2*j+1;
5007 0 : k2 = 2*j+2;
5008 : }
5009 : }
5010 0 : a->ptr.p_double[j] = va;
5011 0 : b->ptr.p_int[j] = vb;
5012 : }
5013 :
5014 :
5015 : /*************************************************************************
5016 : Heap operations: pops top element from the heap
5017 :
5018 : PARAMETERS:
5019 : A - heap itself, must be at least array[0..N-1]
5020 : B - array of integer tags, which are updated according to
5021 : permutations in the heap
5022 : N - size of the heap, N>=1
5023 :
5024 : On output top element is moved to A[N-1], B[N-1], heap is reordered, N is
5025 : decreased by 1.
5026 :
5027 : -- ALGLIB --
5028 : Copyright 28.02.2010 by Bochkanov Sergey
5029 : *************************************************************************/
5030 0 : void tagheappopi(/* Real */ ae_vector* a,
5031 : /* Integer */ ae_vector* b,
5032 : ae_int_t* n,
5033 : ae_state *_state)
5034 : {
5035 : double va;
5036 : ae_int_t vb;
5037 :
5038 :
5039 0 : if( *n<1 )
5040 : {
5041 0 : return;
5042 : }
5043 :
5044 : /*
5045 : * N=1 is a special case
5046 : */
5047 0 : if( *n==1 )
5048 : {
5049 0 : *n = 0;
5050 0 : return;
5051 : }
5052 :
5053 : /*
5054 : * swap top element and last element,
5055 : * then reorder heap
5056 : */
5057 0 : va = a->ptr.p_double[*n-1];
5058 0 : vb = b->ptr.p_int[*n-1];
5059 0 : a->ptr.p_double[*n-1] = a->ptr.p_double[0];
5060 0 : b->ptr.p_int[*n-1] = b->ptr.p_int[0];
5061 0 : *n = *n-1;
5062 0 : tagheapreplacetopi(a, b, *n, va, vb, _state);
5063 : }
5064 :
5065 :
5066 : /*************************************************************************
5067 : Search first element less than T in sorted array.
5068 :
5069 : PARAMETERS:
5070 : A - sorted array by ascending from 0 to N-1
5071 : N - number of elements in array
5072 : T - the desired element
5073 :
5074 : RESULT:
5075 : The very first element's index, which isn't less than T.
5076 : In the case when there aren't such elements, returns N.
5077 : *************************************************************************/
5078 0 : ae_int_t lowerbound(/* Real */ ae_vector* a,
5079 : ae_int_t n,
5080 : double t,
5081 : ae_state *_state)
5082 : {
5083 : ae_int_t l;
5084 : ae_int_t half;
5085 : ae_int_t first;
5086 : ae_int_t middle;
5087 : ae_int_t result;
5088 :
5089 :
5090 0 : l = n;
5091 0 : first = 0;
5092 0 : while(l>0)
5093 : {
5094 0 : half = l/2;
5095 0 : middle = first+half;
5096 0 : if( ae_fp_less(a->ptr.p_double[middle],t) )
5097 : {
5098 0 : first = middle+1;
5099 0 : l = l-half-1;
5100 : }
5101 : else
5102 : {
5103 0 : l = half;
5104 : }
5105 : }
5106 0 : result = first;
5107 0 : return result;
5108 : }
5109 :
5110 :
5111 : /*************************************************************************
5112 : Search first element more than T in sorted array.
5113 :
5114 : PARAMETERS:
5115 : A - sorted array by ascending from 0 to N-1
5116 : N - number of elements in array
5117 : T - the desired element
5118 :
5119 : RESULT:
5120 : The very first element's index, which more than T.
5121 : In the case when there aren't such elements, returns N.
5122 : *************************************************************************/
5123 0 : ae_int_t upperbound(/* Real */ ae_vector* a,
5124 : ae_int_t n,
5125 : double t,
5126 : ae_state *_state)
5127 : {
5128 : ae_int_t l;
5129 : ae_int_t half;
5130 : ae_int_t first;
5131 : ae_int_t middle;
5132 : ae_int_t result;
5133 :
5134 :
5135 0 : l = n;
5136 0 : first = 0;
5137 0 : while(l>0)
5138 : {
5139 0 : half = l/2;
5140 0 : middle = first+half;
5141 0 : if( ae_fp_less(t,a->ptr.p_double[middle]) )
5142 : {
5143 0 : l = half;
5144 : }
5145 : else
5146 : {
5147 0 : first = middle+1;
5148 0 : l = l-half-1;
5149 : }
5150 : }
5151 0 : result = first;
5152 0 : return result;
5153 : }
5154 :
5155 :
5156 : /*************************************************************************
5157 : Internal TagSortFastI: sorts A[I1...I2] (both bounds are included),
5158 : applies same permutations to B.
5159 :
5160 : -- ALGLIB --
5161 : Copyright 06.09.2010 by Bochkanov Sergey
5162 : *************************************************************************/
5163 0 : static void tsort_tagsortfastirec(/* Real */ ae_vector* a,
5164 : /* Integer */ ae_vector* b,
5165 : /* Real */ ae_vector* bufa,
5166 : /* Integer */ ae_vector* bufb,
5167 : ae_int_t i1,
5168 : ae_int_t i2,
5169 : ae_state *_state)
5170 : {
5171 : ae_int_t i;
5172 : ae_int_t j;
5173 : ae_int_t k;
5174 : ae_int_t cntless;
5175 : ae_int_t cnteq;
5176 : ae_int_t cntgreater;
5177 : double tmpr;
5178 : ae_int_t tmpi;
5179 : double v0;
5180 : double v1;
5181 : double v2;
5182 : double vp;
5183 :
5184 :
5185 :
5186 : /*
5187 : * Fast exit
5188 : */
5189 0 : if( i2<=i1 )
5190 : {
5191 0 : return;
5192 : }
5193 :
5194 : /*
5195 : * Non-recursive sort for small arrays
5196 : */
5197 0 : if( i2-i1<=16 )
5198 : {
5199 0 : for(j=i1+1; j<=i2; j++)
5200 : {
5201 :
5202 : /*
5203 : * Search elements [I1..J-1] for place to insert Jth element.
5204 : *
5205 : * This code stops immediately if we can leave A[J] at J-th position
5206 : * (all elements have same value of A[J] larger than any of them)
5207 : */
5208 0 : tmpr = a->ptr.p_double[j];
5209 0 : tmpi = j;
5210 0 : for(k=j-1; k>=i1; k--)
5211 : {
5212 0 : if( a->ptr.p_double[k]<=tmpr )
5213 : {
5214 0 : break;
5215 : }
5216 0 : tmpi = k;
5217 : }
5218 0 : k = tmpi;
5219 :
5220 : /*
5221 : * Insert Jth element into Kth position
5222 : */
5223 0 : if( k!=j )
5224 : {
5225 0 : tmpr = a->ptr.p_double[j];
5226 0 : tmpi = b->ptr.p_int[j];
5227 0 : for(i=j-1; i>=k; i--)
5228 : {
5229 0 : a->ptr.p_double[i+1] = a->ptr.p_double[i];
5230 0 : b->ptr.p_int[i+1] = b->ptr.p_int[i];
5231 : }
5232 0 : a->ptr.p_double[k] = tmpr;
5233 0 : b->ptr.p_int[k] = tmpi;
5234 : }
5235 : }
5236 0 : return;
5237 : }
5238 :
5239 : /*
5240 : * Quicksort: choose pivot
5241 : * Here we assume that I2-I1>=2
5242 : */
5243 0 : v0 = a->ptr.p_double[i1];
5244 0 : v1 = a->ptr.p_double[i1+(i2-i1)/2];
5245 0 : v2 = a->ptr.p_double[i2];
5246 0 : if( v0>v1 )
5247 : {
5248 0 : tmpr = v1;
5249 0 : v1 = v0;
5250 0 : v0 = tmpr;
5251 : }
5252 0 : if( v1>v2 )
5253 : {
5254 0 : tmpr = v2;
5255 0 : v2 = v1;
5256 0 : v1 = tmpr;
5257 : }
5258 0 : if( v0>v1 )
5259 : {
5260 0 : tmpr = v1;
5261 0 : v1 = v0;
5262 0 : v0 = tmpr;
5263 : }
5264 0 : vp = v1;
5265 :
5266 : /*
5267 : * now pass through A/B and:
5268 : * * move elements that are LESS than VP to the left of A/B
5269 : * * move elements that are EQUAL to VP to the right of BufA/BufB (in the reverse order)
5270 : * * move elements that are GREATER than VP to the left of BufA/BufB (in the normal order
5271 : * * move elements from the tail of BufA/BufB to the middle of A/B (restoring normal order)
5272 : * * move elements from the left of BufA/BufB to the end of A/B
5273 : */
5274 0 : cntless = 0;
5275 0 : cnteq = 0;
5276 0 : cntgreater = 0;
5277 0 : for(i=i1; i<=i2; i++)
5278 : {
5279 0 : v0 = a->ptr.p_double[i];
5280 0 : if( v0<vp )
5281 : {
5282 :
5283 : /*
5284 : * LESS
5285 : */
5286 0 : k = i1+cntless;
5287 0 : if( i!=k )
5288 : {
5289 0 : a->ptr.p_double[k] = v0;
5290 0 : b->ptr.p_int[k] = b->ptr.p_int[i];
5291 : }
5292 0 : cntless = cntless+1;
5293 0 : continue;
5294 : }
5295 0 : if( v0==vp )
5296 : {
5297 :
5298 : /*
5299 : * EQUAL
5300 : */
5301 0 : k = i2-cnteq;
5302 0 : bufa->ptr.p_double[k] = v0;
5303 0 : bufb->ptr.p_int[k] = b->ptr.p_int[i];
5304 0 : cnteq = cnteq+1;
5305 0 : continue;
5306 : }
5307 :
5308 : /*
5309 : * GREATER
5310 : */
5311 0 : k = i1+cntgreater;
5312 0 : bufa->ptr.p_double[k] = v0;
5313 0 : bufb->ptr.p_int[k] = b->ptr.p_int[i];
5314 0 : cntgreater = cntgreater+1;
5315 : }
5316 0 : for(i=0; i<=cnteq-1; i++)
5317 : {
5318 0 : j = i1+cntless+cnteq-1-i;
5319 0 : k = i2+i-(cnteq-1);
5320 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5321 0 : b->ptr.p_int[j] = bufb->ptr.p_int[k];
5322 : }
5323 0 : for(i=0; i<=cntgreater-1; i++)
5324 : {
5325 0 : j = i1+cntless+cnteq+i;
5326 0 : k = i1+i;
5327 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5328 0 : b->ptr.p_int[j] = bufb->ptr.p_int[k];
5329 : }
5330 :
5331 : /*
5332 : * Sort left and right parts of the array (ignoring middle part)
5333 : */
5334 0 : tsort_tagsortfastirec(a, b, bufa, bufb, i1, i1+cntless-1, _state);
5335 0 : tsort_tagsortfastirec(a, b, bufa, bufb, i1+cntless+cnteq, i2, _state);
5336 : }
5337 :
5338 :
5339 : /*************************************************************************
5340 : Internal TagSortFastR: sorts A[I1...I2] (both bounds are included),
5341 : applies same permutations to B.
5342 :
5343 : -- ALGLIB --
5344 : Copyright 06.09.2010 by Bochkanov Sergey
5345 : *************************************************************************/
5346 0 : static void tsort_tagsortfastrrec(/* Real */ ae_vector* a,
5347 : /* Real */ ae_vector* b,
5348 : /* Real */ ae_vector* bufa,
5349 : /* Real */ ae_vector* bufb,
5350 : ae_int_t i1,
5351 : ae_int_t i2,
5352 : ae_state *_state)
5353 : {
5354 : ae_int_t i;
5355 : ae_int_t j;
5356 : ae_int_t k;
5357 : double tmpr;
5358 : double tmpr2;
5359 : ae_int_t tmpi;
5360 : ae_int_t cntless;
5361 : ae_int_t cnteq;
5362 : ae_int_t cntgreater;
5363 : double v0;
5364 : double v1;
5365 : double v2;
5366 : double vp;
5367 :
5368 :
5369 :
5370 : /*
5371 : * Fast exit
5372 : */
5373 0 : if( i2<=i1 )
5374 : {
5375 0 : return;
5376 : }
5377 :
5378 : /*
5379 : * Non-recursive sort for small arrays
5380 : */
5381 0 : if( i2-i1<=16 )
5382 : {
5383 0 : for(j=i1+1; j<=i2; j++)
5384 : {
5385 :
5386 : /*
5387 : * Search elements [I1..J-1] for place to insert Jth element.
5388 : *
5389 : * This code stops immediatly if we can leave A[J] at J-th position
5390 : * (all elements have same value of A[J] larger than any of them)
5391 : */
5392 0 : tmpr = a->ptr.p_double[j];
5393 0 : tmpi = j;
5394 0 : for(k=j-1; k>=i1; k--)
5395 : {
5396 0 : if( a->ptr.p_double[k]<=tmpr )
5397 : {
5398 0 : break;
5399 : }
5400 0 : tmpi = k;
5401 : }
5402 0 : k = tmpi;
5403 :
5404 : /*
5405 : * Insert Jth element into Kth position
5406 : */
5407 0 : if( k!=j )
5408 : {
5409 0 : tmpr = a->ptr.p_double[j];
5410 0 : tmpr2 = b->ptr.p_double[j];
5411 0 : for(i=j-1; i>=k; i--)
5412 : {
5413 0 : a->ptr.p_double[i+1] = a->ptr.p_double[i];
5414 0 : b->ptr.p_double[i+1] = b->ptr.p_double[i];
5415 : }
5416 0 : a->ptr.p_double[k] = tmpr;
5417 0 : b->ptr.p_double[k] = tmpr2;
5418 : }
5419 : }
5420 0 : return;
5421 : }
5422 :
5423 : /*
5424 : * Quicksort: choose pivot
5425 : * Here we assume that I2-I1>=16
5426 : */
5427 0 : v0 = a->ptr.p_double[i1];
5428 0 : v1 = a->ptr.p_double[i1+(i2-i1)/2];
5429 0 : v2 = a->ptr.p_double[i2];
5430 0 : if( v0>v1 )
5431 : {
5432 0 : tmpr = v1;
5433 0 : v1 = v0;
5434 0 : v0 = tmpr;
5435 : }
5436 0 : if( v1>v2 )
5437 : {
5438 0 : tmpr = v2;
5439 0 : v2 = v1;
5440 0 : v1 = tmpr;
5441 : }
5442 0 : if( v0>v1 )
5443 : {
5444 0 : tmpr = v1;
5445 0 : v1 = v0;
5446 0 : v0 = tmpr;
5447 : }
5448 0 : vp = v1;
5449 :
5450 : /*
5451 : * now pass through A/B and:
5452 : * * move elements that are LESS than VP to the left of A/B
5453 : * * move elements that are EQUAL to VP to the right of BufA/BufB (in the reverse order)
5454 : * * move elements that are GREATER than VP to the left of BufA/BufB (in the normal order
5455 : * * move elements from the tail of BufA/BufB to the middle of A/B (restoring normal order)
5456 : * * move elements from the left of BufA/BufB to the end of A/B
5457 : */
5458 0 : cntless = 0;
5459 0 : cnteq = 0;
5460 0 : cntgreater = 0;
5461 0 : for(i=i1; i<=i2; i++)
5462 : {
5463 0 : v0 = a->ptr.p_double[i];
5464 0 : if( v0<vp )
5465 : {
5466 :
5467 : /*
5468 : * LESS
5469 : */
5470 0 : k = i1+cntless;
5471 0 : if( i!=k )
5472 : {
5473 0 : a->ptr.p_double[k] = v0;
5474 0 : b->ptr.p_double[k] = b->ptr.p_double[i];
5475 : }
5476 0 : cntless = cntless+1;
5477 0 : continue;
5478 : }
5479 0 : if( v0==vp )
5480 : {
5481 :
5482 : /*
5483 : * EQUAL
5484 : */
5485 0 : k = i2-cnteq;
5486 0 : bufa->ptr.p_double[k] = v0;
5487 0 : bufb->ptr.p_double[k] = b->ptr.p_double[i];
5488 0 : cnteq = cnteq+1;
5489 0 : continue;
5490 : }
5491 :
5492 : /*
5493 : * GREATER
5494 : */
5495 0 : k = i1+cntgreater;
5496 0 : bufa->ptr.p_double[k] = v0;
5497 0 : bufb->ptr.p_double[k] = b->ptr.p_double[i];
5498 0 : cntgreater = cntgreater+1;
5499 : }
5500 0 : for(i=0; i<=cnteq-1; i++)
5501 : {
5502 0 : j = i1+cntless+cnteq-1-i;
5503 0 : k = i2+i-(cnteq-1);
5504 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5505 0 : b->ptr.p_double[j] = bufb->ptr.p_double[k];
5506 : }
5507 0 : for(i=0; i<=cntgreater-1; i++)
5508 : {
5509 0 : j = i1+cntless+cnteq+i;
5510 0 : k = i1+i;
5511 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5512 0 : b->ptr.p_double[j] = bufb->ptr.p_double[k];
5513 : }
5514 :
5515 : /*
5516 : * Sort left and right parts of the array (ignoring middle part)
5517 : */
5518 0 : tsort_tagsortfastrrec(a, b, bufa, bufb, i1, i1+cntless-1, _state);
5519 0 : tsort_tagsortfastrrec(a, b, bufa, bufb, i1+cntless+cnteq, i2, _state);
5520 : }
5521 :
5522 :
5523 : /*************************************************************************
5524 : Internal TagSortFastI: sorts A[I1...I2] (both bounds are included),
5525 : applies same permutations to B.
5526 :
5527 : -- ALGLIB --
5528 : Copyright 06.09.2010 by Bochkanov Sergey
5529 : *************************************************************************/
5530 0 : static void tsort_tagsortfastrec(/* Real */ ae_vector* a,
5531 : /* Real */ ae_vector* bufa,
5532 : ae_int_t i1,
5533 : ae_int_t i2,
5534 : ae_state *_state)
5535 : {
5536 : ae_int_t cntless;
5537 : ae_int_t cnteq;
5538 : ae_int_t cntgreater;
5539 : ae_int_t i;
5540 : ae_int_t j;
5541 : ae_int_t k;
5542 : double tmpr;
5543 : ae_int_t tmpi;
5544 : double v0;
5545 : double v1;
5546 : double v2;
5547 : double vp;
5548 :
5549 :
5550 :
5551 : /*
5552 : * Fast exit
5553 : */
5554 0 : if( i2<=i1 )
5555 : {
5556 0 : return;
5557 : }
5558 :
5559 : /*
5560 : * Non-recursive sort for small arrays
5561 : */
5562 0 : if( i2-i1<=16 )
5563 : {
5564 0 : for(j=i1+1; j<=i2; j++)
5565 : {
5566 :
5567 : /*
5568 : * Search elements [I1..J-1] for place to insert Jth element.
5569 : *
5570 : * This code stops immediatly if we can leave A[J] at J-th position
5571 : * (all elements have same value of A[J] larger than any of them)
5572 : */
5573 0 : tmpr = a->ptr.p_double[j];
5574 0 : tmpi = j;
5575 0 : for(k=j-1; k>=i1; k--)
5576 : {
5577 0 : if( a->ptr.p_double[k]<=tmpr )
5578 : {
5579 0 : break;
5580 : }
5581 0 : tmpi = k;
5582 : }
5583 0 : k = tmpi;
5584 :
5585 : /*
5586 : * Insert Jth element into Kth position
5587 : */
5588 0 : if( k!=j )
5589 : {
5590 0 : tmpr = a->ptr.p_double[j];
5591 0 : for(i=j-1; i>=k; i--)
5592 : {
5593 0 : a->ptr.p_double[i+1] = a->ptr.p_double[i];
5594 : }
5595 0 : a->ptr.p_double[k] = tmpr;
5596 : }
5597 : }
5598 0 : return;
5599 : }
5600 :
5601 : /*
5602 : * Quicksort: choose pivot
5603 : * Here we assume that I2-I1>=16
5604 : */
5605 0 : v0 = a->ptr.p_double[i1];
5606 0 : v1 = a->ptr.p_double[i1+(i2-i1)/2];
5607 0 : v2 = a->ptr.p_double[i2];
5608 0 : if( v0>v1 )
5609 : {
5610 0 : tmpr = v1;
5611 0 : v1 = v0;
5612 0 : v0 = tmpr;
5613 : }
5614 0 : if( v1>v2 )
5615 : {
5616 0 : tmpr = v2;
5617 0 : v2 = v1;
5618 0 : v1 = tmpr;
5619 : }
5620 0 : if( v0>v1 )
5621 : {
5622 0 : tmpr = v1;
5623 0 : v1 = v0;
5624 0 : v0 = tmpr;
5625 : }
5626 0 : vp = v1;
5627 :
5628 : /*
5629 : * now pass through A/B and:
5630 : * * move elements that are LESS than VP to the left of A/B
5631 : * * move elements that are EQUAL to VP to the right of BufA/BufB (in the reverse order)
5632 : * * move elements that are GREATER than VP to the left of BufA/BufB (in the normal order
5633 : * * move elements from the tail of BufA/BufB to the middle of A/B (restoring normal order)
5634 : * * move elements from the left of BufA/BufB to the end of A/B
5635 : */
5636 0 : cntless = 0;
5637 0 : cnteq = 0;
5638 0 : cntgreater = 0;
5639 0 : for(i=i1; i<=i2; i++)
5640 : {
5641 0 : v0 = a->ptr.p_double[i];
5642 0 : if( v0<vp )
5643 : {
5644 :
5645 : /*
5646 : * LESS
5647 : */
5648 0 : k = i1+cntless;
5649 0 : if( i!=k )
5650 : {
5651 0 : a->ptr.p_double[k] = v0;
5652 : }
5653 0 : cntless = cntless+1;
5654 0 : continue;
5655 : }
5656 0 : if( v0==vp )
5657 : {
5658 :
5659 : /*
5660 : * EQUAL
5661 : */
5662 0 : k = i2-cnteq;
5663 0 : bufa->ptr.p_double[k] = v0;
5664 0 : cnteq = cnteq+1;
5665 0 : continue;
5666 : }
5667 :
5668 : /*
5669 : * GREATER
5670 : */
5671 0 : k = i1+cntgreater;
5672 0 : bufa->ptr.p_double[k] = v0;
5673 0 : cntgreater = cntgreater+1;
5674 : }
5675 0 : for(i=0; i<=cnteq-1; i++)
5676 : {
5677 0 : j = i1+cntless+cnteq-1-i;
5678 0 : k = i2+i-(cnteq-1);
5679 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5680 : }
5681 0 : for(i=0; i<=cntgreater-1; i++)
5682 : {
5683 0 : j = i1+cntless+cnteq+i;
5684 0 : k = i1+i;
5685 0 : a->ptr.p_double[j] = bufa->ptr.p_double[k];
5686 : }
5687 :
5688 : /*
5689 : * Sort left and right parts of the array (ignoring middle part)
5690 : */
5691 0 : tsort_tagsortfastrec(a, bufa, i1, i1+cntless-1, _state);
5692 0 : tsort_tagsortfastrec(a, bufa, i1+cntless+cnteq, i2, _state);
5693 : }
5694 :
5695 :
5696 : #endif
5697 : #if defined(AE_COMPILE_ABLASF) || !defined(AE_PARTIAL_BUILD)
5698 :
5699 :
5700 : /*************************************************************************
5701 : Computes dot product (X,Y) for elements [0,N) of X[] and Y[]
5702 :
5703 : INPUT PARAMETERS:
5704 : N - vector length
5705 : X - array[N], vector to process
5706 : Y - array[N], vector to process
5707 :
5708 : RESULT:
5709 : (X,Y)
5710 :
5711 : -- ALGLIB --
5712 : Copyright 20.01.2020 by Bochkanov Sergey
5713 : *************************************************************************/
5714 0 : double rdotv(ae_int_t n,
5715 : /* Real */ ae_vector* x,
5716 : /* Real */ ae_vector* y,
5717 : ae_state *_state)
5718 : {
5719 : ae_int_t i;
5720 : double result;
5721 :
5722 :
5723 0 : result = (double)(0);
5724 0 : for(i=0; i<=n-1; i++)
5725 : {
5726 0 : result = result+x->ptr.p_double[i]*y->ptr.p_double[i];
5727 : }
5728 0 : return result;
5729 : }
5730 :
5731 :
5732 : /*************************************************************************
5733 : Computes dot product (X,A[i]) for elements [0,N) of vector X[] and row A[i,*]
5734 :
5735 : INPUT PARAMETERS:
5736 : N - vector length
5737 : X - array[N], vector to process
5738 : A - array[?,N], matrix to process
5739 : I - row index
5740 :
5741 : RESULT:
5742 : (X,Ai)
5743 :
5744 : -- ALGLIB --
5745 : Copyright 20.01.2020 by Bochkanov Sergey
5746 : *************************************************************************/
5747 0 : double rdotvr(ae_int_t n,
5748 : /* Real */ ae_vector* x,
5749 : /* Real */ ae_matrix* a,
5750 : ae_int_t i,
5751 : ae_state *_state)
5752 : {
5753 : ae_int_t j;
5754 : double result;
5755 :
5756 :
5757 0 : result = (double)(0);
5758 0 : for(j=0; j<=n-1; j++)
5759 : {
5760 0 : result = result+x->ptr.p_double[j]*a->ptr.pp_double[i][j];
5761 : }
5762 0 : return result;
5763 : }
5764 :
5765 :
5766 : /*************************************************************************
5767 : Computes dot product (X,A[i]) for rows A[ia,*] and B[ib,*]
5768 :
5769 : INPUT PARAMETERS:
5770 : N - vector length
5771 : X - array[N], vector to process
5772 : A - array[?,N], matrix to process
5773 : I - row index
5774 :
5775 : RESULT:
5776 : (X,Ai)
5777 :
5778 : -- ALGLIB --
5779 : Copyright 20.01.2020 by Bochkanov Sergey
5780 : *************************************************************************/
5781 0 : double rdotrr(ae_int_t n,
5782 : /* Real */ ae_matrix* a,
5783 : ae_int_t ia,
5784 : /* Real */ ae_matrix* b,
5785 : ae_int_t ib,
5786 : ae_state *_state)
5787 : {
5788 : ae_int_t j;
5789 : double result;
5790 :
5791 :
5792 0 : result = (double)(0);
5793 0 : for(j=0; j<=n-1; j++)
5794 : {
5795 0 : result = result+a->ptr.pp_double[ia][j]*b->ptr.pp_double[ib][j];
5796 : }
5797 0 : return result;
5798 : }
5799 :
5800 :
5801 : /*************************************************************************
5802 : Computes dot product (X,X) for elements [0,N) of X[]
5803 :
5804 : INPUT PARAMETERS:
5805 : N - vector length
5806 : X - array[N], vector to process
5807 :
5808 : RESULT:
5809 : (X,X)
5810 :
5811 : -- ALGLIB --
5812 : Copyright 20.01.2020 by Bochkanov Sergey
5813 : *************************************************************************/
5814 0 : double rdotv2(ae_int_t n, /* Real */ ae_vector* x, ae_state *_state)
5815 : {
5816 : ae_int_t i;
5817 : double v;
5818 : double result;
5819 :
5820 :
5821 0 : result = (double)(0);
5822 0 : for(i=0; i<=n-1; i++)
5823 : {
5824 0 : v = x->ptr.p_double[i];
5825 0 : result = result+v*v;
5826 : }
5827 0 : return result;
5828 : }
5829 :
5830 :
5831 : /*************************************************************************
5832 : Performs inplace addition of Y[] to X[]
5833 :
5834 : INPUT PARAMETERS:
5835 : N - vector length
5836 : Alpha - multiplier
5837 : Y - array[N], vector to process
5838 : X - array[N], vector to process
5839 :
5840 : RESULT:
5841 : X := X + alpha*Y
5842 :
5843 : -- ALGLIB --
5844 : Copyright 20.01.2020 by Bochkanov Sergey
5845 : *************************************************************************/
5846 0 : void raddv(ae_int_t n,
5847 : double alpha,
5848 : /* Real */ ae_vector* y,
5849 : /* Real */ ae_vector* x,
5850 : ae_state *_state)
5851 : {
5852 : ae_int_t i;
5853 :
5854 :
5855 0 : for(i=0; i<=n-1; i++)
5856 : {
5857 0 : x->ptr.p_double[i] = x->ptr.p_double[i]+alpha*y->ptr.p_double[i];
5858 : }
5859 0 : }
5860 :
5861 :
5862 : /*************************************************************************
5863 : Performs inplace addition of Y[] to X[]
5864 :
5865 : INPUT PARAMETERS:
5866 : N - vector length
5867 : Alpha - multiplier
5868 : Y - source vector
5869 : OffsY - source offset
5870 : X - destination vector
5871 : OffsX - destination offset
5872 :
5873 : RESULT:
5874 : X := X + alpha*Y
5875 :
5876 : -- ALGLIB --
5877 : Copyright 20.01.2020 by Bochkanov Sergey
5878 : *************************************************************************/
5879 0 : void raddvx(ae_int_t n,
5880 : double alpha,
5881 : /* Real */ ae_vector* y,
5882 : ae_int_t offsy,
5883 : /* Real */ ae_vector* x,
5884 : ae_int_t offsx,
5885 : ae_state *_state)
5886 : {
5887 : ae_int_t i;
5888 :
5889 :
5890 0 : for(i=0; i<=n-1; i++)
5891 : {
5892 0 : x->ptr.p_double[offsx+i] = x->ptr.p_double[offsx+i]+alpha*y->ptr.p_double[offsy+i];
5893 : }
5894 0 : }
5895 :
5896 :
5897 : /*************************************************************************
5898 : Performs inplace addition of vector Y[] to column X[]
5899 :
5900 : INPUT PARAMETERS:
5901 : N - vector length
5902 : Alpha - multiplier
5903 : Y - vector to add
5904 : X - target column ColIdx
5905 :
5906 : RESULT:
5907 : X := X + alpha*Y
5908 :
5909 : -- ALGLIB --
5910 : Copyright 20.01.2020 by Bochkanov Sergey
5911 : *************************************************************************/
5912 0 : void raddvc(ae_int_t n,
5913 : double alpha,
5914 : /* Real */ ae_vector* y,
5915 : /* Real */ ae_matrix* x,
5916 : ae_int_t colidx,
5917 : ae_state *_state)
5918 : {
5919 : ae_int_t i;
5920 :
5921 :
5922 0 : for(i=0; i<=n-1; i++)
5923 : {
5924 0 : x->ptr.pp_double[i][colidx] = x->ptr.pp_double[i][colidx]+alpha*y->ptr.p_double[i];
5925 : }
5926 0 : }
5927 :
5928 :
5929 : /*************************************************************************
5930 : Performs inplace addition of vector Y[] to row X[]
5931 :
5932 : INPUT PARAMETERS:
5933 : N - vector length
5934 : Alpha - multiplier
5935 : Y - vector to add
5936 : X - target row RowIdx
5937 :
5938 : RESULT:
5939 : X := X + alpha*Y
5940 :
5941 : -- ALGLIB --
5942 : Copyright 20.01.2020 by Bochkanov Sergey
5943 : *************************************************************************/
5944 0 : void raddvr(ae_int_t n,
5945 : double alpha,
5946 : /* Real */ ae_vector* y,
5947 : /* Real */ ae_matrix* x,
5948 : ae_int_t rowidx,
5949 : ae_state *_state)
5950 : {
5951 : ae_int_t i;
5952 :
5953 :
5954 0 : for(i=0; i<=n-1; i++)
5955 : {
5956 0 : x->ptr.pp_double[rowidx][i] = x->ptr.pp_double[rowidx][i]+alpha*y->ptr.p_double[i];
5957 : }
5958 0 : }
5959 :
5960 :
5961 : /*************************************************************************
5962 : Performs componentwise multiplication of row X[] by vector Y[]
5963 :
5964 : INPUT PARAMETERS:
5965 : N - vector length
5966 : Y - vector to multiply by
5967 : X - target row RowIdx
5968 :
5969 : RESULT:
5970 : X := componentwise(X*Y)
5971 :
5972 : -- ALGLIB --
5973 : Copyright 20.01.2020 by Bochkanov Sergey
5974 : *************************************************************************/
5975 0 : void rmergemulvr(ae_int_t n,
5976 : /* Real */ ae_vector* y,
5977 : /* Real */ ae_matrix* x,
5978 : ae_int_t rowidx,
5979 : ae_state *_state)
5980 : {
5981 : ae_int_t i;
5982 :
5983 :
5984 0 : for(i=0; i<=n-1; i++)
5985 : {
5986 0 : x->ptr.pp_double[rowidx][i] = x->ptr.pp_double[rowidx][i]*y->ptr.p_double[i];
5987 : }
5988 0 : }
5989 :
5990 :
5991 : /*************************************************************************
5992 : Performs componentwise max of row X[I] and vector Y[]
5993 :
5994 : INPUT PARAMETERS:
5995 : N - vector length
5996 : X - matrix, I-th row is source
5997 : X - target row RowIdx
5998 :
5999 : RESULT:
6000 : X := componentwise(X*Y)
6001 :
6002 : -- ALGLIB --
6003 : Copyright 20.01.2020 by Bochkanov Sergey
6004 : *************************************************************************/
6005 0 : void rmergemaxrv(ae_int_t n,
6006 : /* Real */ ae_matrix* x,
6007 : ae_int_t rowidx,
6008 : /* Real */ ae_vector* y,
6009 : ae_state *_state)
6010 : {
6011 : ae_int_t i;
6012 :
6013 :
6014 0 : for(i=0; i<=n-1; i++)
6015 : {
6016 0 : y->ptr.p_double[i] = ae_maxreal(y->ptr.p_double[i], x->ptr.pp_double[rowidx][i], _state);
6017 : }
6018 0 : }
6019 :
6020 :
6021 : /*************************************************************************
6022 : Performs inplace addition of Y[RIdx,...] to X[]
6023 :
6024 : INPUT PARAMETERS:
6025 : N - vector length
6026 : Alpha - multiplier
6027 : Y - array[?,N], matrix whose RIdx-th row is added
6028 : RIdx - row index
6029 : X - array[N], vector to process
6030 :
6031 : RESULT:
6032 : X := X + alpha*Y
6033 :
6034 : -- ALGLIB --
6035 : Copyright 20.01.2020 by Bochkanov Sergey
6036 : *************************************************************************/
6037 0 : void raddrv(ae_int_t n,
6038 : double alpha,
6039 : /* Real */ ae_matrix* y,
6040 : ae_int_t ridx,
6041 : /* Real */ ae_vector* x,
6042 : ae_state *_state)
6043 : {
6044 : ae_int_t i;
6045 :
6046 :
6047 0 : for(i=0; i<=n-1; i++)
6048 : {
6049 0 : x->ptr.p_double[i] = x->ptr.p_double[i]+alpha*y->ptr.pp_double[ridx][i];
6050 : }
6051 0 : }
6052 :
6053 :
6054 : /*************************************************************************
6055 : Performs inplace multiplication of X[] by V
6056 :
6057 : INPUT PARAMETERS:
6058 : N - vector length
6059 : X - array[N], vector to process
6060 : V - multiplier
6061 :
6062 : OUTPUT PARAMETERS:
6063 : X - elements 0...N-1 multiplied by V
6064 :
6065 : -- ALGLIB --
6066 : Copyright 20.01.2020 by Bochkanov Sergey
6067 : *************************************************************************/
6068 0 : void rmulv(ae_int_t n,
6069 : double v,
6070 : /* Real */ ae_vector* x,
6071 : ae_state *_state)
6072 : {
6073 : ae_int_t i;
6074 :
6075 :
6076 0 : for(i=0; i<=n-1; i++)
6077 : {
6078 0 : x->ptr.p_double[i] = x->ptr.p_double[i]*v;
6079 : }
6080 0 : }
6081 :
6082 :
6083 : /*************************************************************************
6084 : Performs inplace multiplication of X[] by V
6085 :
6086 : INPUT PARAMETERS:
6087 : N - row length
6088 : X - array[?,N], row to process
6089 : V - multiplier
6090 :
6091 : OUTPUT PARAMETERS:
6092 : X - elements 0...N-1 of row RowIdx are multiplied by V
6093 :
6094 : -- ALGLIB --
6095 : Copyright 20.01.2020 by Bochkanov Sergey
6096 : *************************************************************************/
6097 0 : void rmulr(ae_int_t n,
6098 : double v,
6099 : /* Real */ ae_matrix* x,
6100 : ae_int_t rowidx,
6101 : ae_state *_state)
6102 : {
6103 : ae_int_t i;
6104 :
6105 :
6106 0 : for(i=0; i<=n-1; i++)
6107 : {
6108 0 : x->ptr.pp_double[rowidx][i] = x->ptr.pp_double[rowidx][i]*v;
6109 : }
6110 0 : }
6111 :
6112 :
6113 : /*************************************************************************
6114 : Performs inplace multiplication of X[OffsX:OffsX+N-1] by V
6115 :
6116 : INPUT PARAMETERS:
6117 : N - subvector length
6118 : X - vector to process
6119 : V - multiplier
6120 :
6121 : OUTPUT PARAMETERS:
6122 : X - elements OffsX:OffsX+N-1 multiplied by V
6123 :
6124 : -- ALGLIB --
6125 : Copyright 20.01.2020 by Bochkanov Sergey
6126 : *************************************************************************/
6127 0 : void rmulvx(ae_int_t n,
6128 : double v,
6129 : /* Real */ ae_vector* x,
6130 : ae_int_t offsx,
6131 : ae_state *_state)
6132 : {
6133 : ae_int_t i;
6134 :
6135 :
6136 0 : for(i=0; i<=n-1; i++)
6137 : {
6138 0 : x->ptr.p_double[offsx+i] = x->ptr.p_double[offsx+i]*v;
6139 : }
6140 0 : }
6141 :
6142 :
6143 : /*************************************************************************
6144 : Returns maximum |X|
6145 :
6146 : INPUT PARAMETERS:
6147 : N - vector length
6148 : X - array[N], vector to process
6149 :
6150 : OUTPUT PARAMETERS:
6151 : max(|X[i]|)
6152 :
6153 : -- ALGLIB --
6154 : Copyright 20.01.2020 by Bochkanov Sergey
6155 : *************************************************************************/
6156 0 : double rmaxabsv(ae_int_t n, /* Real */ ae_vector* x, ae_state *_state)
6157 : {
6158 : ae_int_t i;
6159 : double v;
6160 : double result;
6161 :
6162 :
6163 0 : result = (double)(0);
6164 0 : for(i=0; i<=n-1; i++)
6165 : {
6166 0 : v = ae_fabs(x->ptr.p_double[i], _state);
6167 0 : if( ae_fp_greater(v,result) )
6168 : {
6169 0 : result = v;
6170 : }
6171 : }
6172 0 : return result;
6173 : }
6174 :
6175 :
6176 : /*************************************************************************
6177 : Sets vector X[] to V
6178 :
6179 : INPUT PARAMETERS:
6180 : N - vector length
6181 : V - value to set
6182 : X - array[N]
6183 :
6184 : OUTPUT PARAMETERS:
6185 : X - leading N elements are replaced by V
6186 :
6187 : -- ALGLIB --
6188 : Copyright 20.01.2020 by Bochkanov Sergey
6189 : *************************************************************************/
6190 0 : void rsetv(ae_int_t n,
6191 : double v,
6192 : /* Real */ ae_vector* x,
6193 : ae_state *_state)
6194 : {
6195 : ae_int_t j;
6196 :
6197 :
6198 0 : for(j=0; j<=n-1; j++)
6199 : {
6200 0 : x->ptr.p_double[j] = v;
6201 : }
6202 0 : }
6203 :
6204 :
6205 : /*************************************************************************
6206 : Sets X[OffsX:OffsX+N-1] to V
6207 :
6208 : INPUT PARAMETERS:
6209 : N - subvector length
6210 : V - value to set
6211 : X - array[N]
6212 :
6213 : OUTPUT PARAMETERS:
6214 : X - X[OffsX:OffsX+N-1] is replaced by V
6215 :
6216 : -- ALGLIB --
6217 : Copyright 20.01.2020 by Bochkanov Sergey
6218 : *************************************************************************/
6219 0 : void rsetvx(ae_int_t n,
6220 : double v,
6221 : /* Real */ ae_vector* x,
6222 : ae_int_t offsx,
6223 : ae_state *_state)
6224 : {
6225 : ae_int_t j;
6226 :
6227 :
6228 0 : for(j=0; j<=n-1; j++)
6229 : {
6230 0 : x->ptr.p_double[offsx+j] = v;
6231 : }
6232 0 : }
6233 :
6234 :
6235 : /*************************************************************************
6236 : Sets vector X[] to V
6237 :
6238 : INPUT PARAMETERS:
6239 : N - vector length
6240 : V - value to set
6241 : X - array[N]
6242 :
6243 : OUTPUT PARAMETERS:
6244 : X - leading N elements are replaced by V
6245 :
6246 : -- ALGLIB --
6247 : Copyright 20.01.2020 by Bochkanov Sergey
6248 : *************************************************************************/
6249 0 : void isetv(ae_int_t n,
6250 : ae_int_t v,
6251 : /* Integer */ ae_vector* x,
6252 : ae_state *_state)
6253 : {
6254 : ae_int_t j;
6255 :
6256 :
6257 0 : for(j=0; j<=n-1; j++)
6258 : {
6259 0 : x->ptr.p_int[j] = v;
6260 : }
6261 0 : }
6262 :
6263 :
6264 : /*************************************************************************
6265 : Sets vector X[] to V
6266 :
6267 : INPUT PARAMETERS:
6268 : N - vector length
6269 : V - value to set
6270 : X - array[N]
6271 :
6272 : OUTPUT PARAMETERS:
6273 : X - leading N elements are replaced by V
6274 :
6275 : -- ALGLIB --
6276 : Copyright 20.01.2020 by Bochkanov Sergey
6277 : *************************************************************************/
6278 0 : void bsetv(ae_int_t n,
6279 : ae_bool v,
6280 : /* Boolean */ ae_vector* x,
6281 : ae_state *_state)
6282 : {
6283 : ae_int_t j;
6284 :
6285 :
6286 0 : for(j=0; j<=n-1; j++)
6287 : {
6288 0 : x->ptr.p_bool[j] = v;
6289 : }
6290 0 : }
6291 :
6292 :
6293 : /*************************************************************************
6294 : Sets matrix A[] to V
6295 :
6296 : INPUT PARAMETERS:
6297 : M, N - rows/cols count
6298 : V - value to set
6299 : A - array[M,N]
6300 :
6301 : OUTPUT PARAMETERS:
6302 : A - leading M rows, N cols are replaced by V
6303 :
6304 : -- ALGLIB --
6305 : Copyright 20.01.2020 by Bochkanov Sergey
6306 : *************************************************************************/
6307 0 : void rsetm(ae_int_t m,
6308 : ae_int_t n,
6309 : double v,
6310 : /* Real */ ae_matrix* a,
6311 : ae_state *_state)
6312 : {
6313 : ae_int_t i;
6314 : ae_int_t j;
6315 :
6316 :
6317 0 : for(i=0; i<=m-1; i++)
6318 : {
6319 0 : for(j=0; j<=n-1; j++)
6320 : {
6321 0 : a->ptr.pp_double[i][j] = v;
6322 : }
6323 : }
6324 0 : }
6325 :
6326 :
6327 : /*************************************************************************
6328 : Sets vector X[] to V, reallocating X[] if too small
6329 :
6330 : INPUT PARAMETERS:
6331 : N - vector length
6332 : V - value to set
6333 : X - possibly preallocated array
6334 :
6335 : OUTPUT PARAMETERS:
6336 : X - leading N elements are replaced by V; array is reallocated
6337 : if its length is less than N.
6338 :
6339 : -- ALGLIB --
6340 : Copyright 20.01.2020 by Bochkanov Sergey
6341 : *************************************************************************/
6342 0 : void rsetallocv(ae_int_t n,
6343 : double v,
6344 : /* Real */ ae_vector* x,
6345 : ae_state *_state)
6346 : {
6347 :
6348 :
6349 0 : if( x->cnt<n )
6350 : {
6351 0 : ae_vector_set_length(x, n, _state);
6352 : }
6353 0 : rsetv(n, v, x, _state);
6354 0 : }
6355 :
6356 :
6357 : /*************************************************************************
6358 : Sets vector A[] to V, reallocating A[] if too small.
6359 :
6360 : INPUT PARAMETERS:
6361 : M - rows count
6362 : N - cols count
6363 : V - value to set
6364 : A - possibly preallocated matrix
6365 :
6366 : OUTPUT PARAMETERS:
6367 : A - leading M rows, N cols are replaced by V; the matrix is
6368 : reallocated if its rows/cols count is less than M/N.
6369 :
6370 : -- ALGLIB --
6371 : Copyright 20.01.2020 by Bochkanov Sergey
6372 : *************************************************************************/
6373 0 : void rsetallocm(ae_int_t m,
6374 : ae_int_t n,
6375 : double v,
6376 : /* Real */ ae_matrix* a,
6377 : ae_state *_state)
6378 : {
6379 :
6380 :
6381 0 : if( a->rows<m||a->cols<n )
6382 : {
6383 0 : ae_matrix_set_length(a, m, n, _state);
6384 : }
6385 0 : rsetm(m, n, v, a, _state);
6386 0 : }
6387 :
6388 :
6389 : /*************************************************************************
6390 : Reallocates X[] if its length is less than required value. Does not change
6391 : its length and contents if it is large enough.
6392 :
6393 : INPUT PARAMETERS:
6394 : N - desired vector length
6395 : X - possibly preallocated array
6396 :
6397 : OUTPUT PARAMETERS:
6398 : X - length(X)>=N
6399 :
6400 : -- ALGLIB --
6401 : Copyright 20.01.2020 by Bochkanov Sergey
6402 : *************************************************************************/
6403 0 : void rallocv(ae_int_t n, /* Real */ ae_vector* x, ae_state *_state)
6404 : {
6405 :
6406 :
6407 0 : if( x->cnt<n )
6408 : {
6409 0 : ae_vector_set_length(x, n, _state);
6410 : }
6411 0 : }
6412 :
6413 :
6414 : /*************************************************************************
6415 : Reallocates X[] if its length is less than required value. Does not change
6416 : its length and contents if it is large enough.
6417 :
6418 : INPUT PARAMETERS:
6419 : N - desired vector length
6420 : X - possibly preallocated array
6421 :
6422 : OUTPUT PARAMETERS:
6423 : X - length(X)>=N
6424 :
6425 : -- ALGLIB --
6426 : Copyright 20.01.2020 by Bochkanov Sergey
6427 : *************************************************************************/
6428 0 : void ballocv(ae_int_t n, /* Boolean */ ae_vector* x, ae_state *_state)
6429 : {
6430 :
6431 :
6432 0 : if( x->cnt<n )
6433 : {
6434 0 : ae_vector_set_length(x, n, _state);
6435 : }
6436 0 : }
6437 :
6438 :
6439 : /*************************************************************************
6440 : Reallocates matrix if its rows or cols count is less than required. Does
6441 : not change its size if it is exactly that size or larger.
6442 :
6443 : INPUT PARAMETERS:
6444 : M - rows count
6445 : N - cols count
6446 : A - possibly preallocated matrix
6447 :
6448 : OUTPUT PARAMETERS:
6449 : A - size is at least M*N
6450 :
6451 : -- ALGLIB --
6452 : Copyright 20.01.2020 by Bochkanov Sergey
6453 : *************************************************************************/
6454 0 : void rallocm(ae_int_t m,
6455 : ae_int_t n,
6456 : /* Real */ ae_matrix* a,
6457 : ae_state *_state)
6458 : {
6459 :
6460 :
6461 0 : if( a->rows<m||a->cols<n )
6462 : {
6463 0 : ae_matrix_set_length(a, m, n, _state);
6464 : }
6465 0 : }
6466 :
6467 :
6468 : /*************************************************************************
6469 : Sets vector X[] to V, reallocating X[] if too small
6470 :
6471 : INPUT PARAMETERS:
6472 : N - vector length
6473 : V - value to set
6474 : X - possibly preallocated array
6475 :
6476 : OUTPUT PARAMETERS:
6477 : X - leading N elements are replaced by V; array is reallocated
6478 : if its length is less than N.
6479 :
6480 : -- ALGLIB --
6481 : Copyright 20.01.2020 by Bochkanov Sergey
6482 : *************************************************************************/
6483 0 : void isetallocv(ae_int_t n,
6484 : ae_int_t v,
6485 : /* Integer */ ae_vector* x,
6486 : ae_state *_state)
6487 : {
6488 :
6489 :
6490 0 : if( x->cnt<n )
6491 : {
6492 0 : ae_vector_set_length(x, n, _state);
6493 : }
6494 0 : isetv(n, v, x, _state);
6495 0 : }
6496 :
6497 :
6498 : /*************************************************************************
6499 : Sets vector X[] to V, reallocating X[] if too small
6500 :
6501 : INPUT PARAMETERS:
6502 : N - vector length
6503 : V - value to set
6504 : X - possibly preallocated array
6505 :
6506 : OUTPUT PARAMETERS:
6507 : X - leading N elements are replaced by V; array is reallocated
6508 : if its length is less than N.
6509 :
6510 : -- ALGLIB --
6511 : Copyright 20.01.2020 by Bochkanov Sergey
6512 : *************************************************************************/
6513 0 : void bsetallocv(ae_int_t n,
6514 : ae_bool v,
6515 : /* Boolean */ ae_vector* x,
6516 : ae_state *_state)
6517 : {
6518 :
6519 :
6520 0 : if( x->cnt<n )
6521 : {
6522 0 : ae_vector_set_length(x, n, _state);
6523 : }
6524 0 : bsetv(n, v, x, _state);
6525 0 : }
6526 :
6527 :
6528 : /*************************************************************************
6529 : Sets row I of A[,] to V
6530 :
6531 : INPUT PARAMETERS:
6532 : N - vector length
6533 : V - value to set
6534 : A - array[N,N] or larger
6535 : I - row index
6536 :
6537 : OUTPUT PARAMETERS:
6538 : A - leading N elements of I-th row are replaced by V
6539 :
6540 : -- ALGLIB --
6541 : Copyright 20.01.2020 by Bochkanov Sergey
6542 : *************************************************************************/
6543 0 : void rsetr(ae_int_t n,
6544 : double v,
6545 : /* Real */ ae_matrix* a,
6546 : ae_int_t i,
6547 : ae_state *_state)
6548 : {
6549 : ae_int_t j;
6550 :
6551 :
6552 0 : for(j=0; j<=n-1; j++)
6553 : {
6554 0 : a->ptr.pp_double[i][j] = v;
6555 : }
6556 0 : }
6557 :
6558 :
6559 : /*************************************************************************
6560 : Sets col J of A[,] to V
6561 :
6562 : INPUT PARAMETERS:
6563 : N - vector length
6564 : V - value to set
6565 : A - array[N,N] or larger
6566 : J - col index
6567 :
6568 : OUTPUT PARAMETERS:
6569 : A - leading N elements of I-th col are replaced by V
6570 :
6571 : -- ALGLIB --
6572 : Copyright 20.01.2020 by Bochkanov Sergey
6573 : *************************************************************************/
6574 0 : void rsetc(ae_int_t n,
6575 : double v,
6576 : /* Real */ ae_matrix* a,
6577 : ae_int_t j,
6578 : ae_state *_state)
6579 : {
6580 : ae_int_t i;
6581 :
6582 :
6583 0 : for(i=0; i<=n-1; i++)
6584 : {
6585 0 : a->ptr.pp_double[i][j] = v;
6586 : }
6587 0 : }
6588 :
6589 :
6590 : /*************************************************************************
6591 : Copies vector X[] to Y[]
6592 :
6593 : INPUT PARAMETERS:
6594 : N - vector length
6595 : X - array[N], source
6596 : Y - preallocated array[N]
6597 :
6598 : OUTPUT PARAMETERS:
6599 : Y - leading N elements are replaced by X
6600 :
6601 :
6602 : NOTE: destination and source should NOT overlap
6603 :
6604 : -- ALGLIB --
6605 : Copyright 20.01.2020 by Bochkanov Sergey
6606 : *************************************************************************/
6607 0 : void rcopyv(ae_int_t n,
6608 : /* Real */ ae_vector* x,
6609 : /* Real */ ae_vector* y,
6610 : ae_state *_state)
6611 : {
6612 : ae_int_t j;
6613 :
6614 :
6615 0 : for(j=0; j<=n-1; j++)
6616 : {
6617 0 : y->ptr.p_double[j] = x->ptr.p_double[j];
6618 : }
6619 0 : }
6620 :
6621 :
6622 : /*************************************************************************
6623 : Copies vector X[] to Y[]
6624 :
6625 : INPUT PARAMETERS:
6626 : N - vector length
6627 : X - array[N], source
6628 : Y - preallocated array[N]
6629 :
6630 : OUTPUT PARAMETERS:
6631 : Y - leading N elements are replaced by X
6632 :
6633 :
6634 : NOTE: destination and source should NOT overlap
6635 :
6636 : -- ALGLIB --
6637 : Copyright 20.01.2020 by Bochkanov Sergey
6638 : *************************************************************************/
6639 0 : void bcopyv(ae_int_t n,
6640 : /* Boolean */ ae_vector* x,
6641 : /* Boolean */ ae_vector* y,
6642 : ae_state *_state)
6643 : {
6644 : ae_int_t j;
6645 :
6646 :
6647 0 : for(j=0; j<=n-1; j++)
6648 : {
6649 0 : y->ptr.p_bool[j] = x->ptr.p_bool[j];
6650 : }
6651 0 : }
6652 :
6653 :
6654 : /*************************************************************************
6655 : Copies vector X[] to Y[], extended version
6656 :
6657 : INPUT PARAMETERS:
6658 : N - vector length
6659 : X - source array
6660 : OffsX - source offset
6661 : Y - preallocated array[N]
6662 : OffsY - destination offset
6663 :
6664 : OUTPUT PARAMETERS:
6665 : Y - N elements starting from OffsY are replaced by X[OffsX:OffsX+N-1]
6666 :
6667 : NOTE: destination and source should NOT overlap
6668 :
6669 : -- ALGLIB --
6670 : Copyright 20.01.2020 by Bochkanov Sergey
6671 : *************************************************************************/
6672 0 : void rcopyvx(ae_int_t n,
6673 : /* Real */ ae_vector* x,
6674 : ae_int_t offsx,
6675 : /* Real */ ae_vector* y,
6676 : ae_int_t offsy,
6677 : ae_state *_state)
6678 : {
6679 : ae_int_t j;
6680 :
6681 :
6682 0 : for(j=0; j<=n-1; j++)
6683 : {
6684 0 : y->ptr.p_double[offsy+j] = x->ptr.p_double[offsx+j];
6685 : }
6686 0 : }
6687 :
6688 :
6689 : /*************************************************************************
6690 : Copies vector X[] to Y[], resizing Y[] if needed.
6691 :
6692 : INPUT PARAMETERS:
6693 : N - vector length
6694 : X - array[N], source
6695 : Y - possibly preallocated array[N] (resized if needed)
6696 :
6697 : OUTPUT PARAMETERS:
6698 : Y - leading N elements are replaced by X
6699 :
6700 : -- ALGLIB --
6701 : Copyright 20.01.2020 by Bochkanov Sergey
6702 : *************************************************************************/
6703 0 : void rcopyallocv(ae_int_t n,
6704 : /* Real */ ae_vector* x,
6705 : /* Real */ ae_vector* y,
6706 : ae_state *_state)
6707 : {
6708 : ae_int_t j;
6709 :
6710 :
6711 0 : if( y->cnt<n )
6712 : {
6713 0 : ae_vector_set_length(y, n, _state);
6714 : }
6715 0 : for(j=0; j<=n-1; j++)
6716 : {
6717 0 : y->ptr.p_double[j] = x->ptr.p_double[j];
6718 : }
6719 0 : }
6720 :
6721 :
6722 : /*************************************************************************
6723 : Copies matrix X[] to Y[], resizing Y[] if needed. On resize, dimensions of
6724 : Y[] are increased - but not decreased.
6725 :
6726 : INPUT PARAMETERS:
6727 : M - rows count
6728 : N - cols count
6729 : X - array[M,N], source
6730 : Y - possibly preallocated array[M,N] (resized if needed)
6731 :
6732 : OUTPUT PARAMETERS:
6733 : Y - leading [M,N] elements are replaced by X
6734 :
6735 : -- ALGLIB --
6736 : Copyright 20.01.2020 by Bochkanov Sergey
6737 : *************************************************************************/
6738 0 : void rcopyallocm(ae_int_t m,
6739 : ae_int_t n,
6740 : /* Real */ ae_matrix* x,
6741 : /* Real */ ae_matrix* y,
6742 : ae_state *_state)
6743 : {
6744 : ae_int_t i;
6745 : ae_int_t j;
6746 :
6747 :
6748 0 : if( m==0||n==0 )
6749 : {
6750 0 : return;
6751 : }
6752 0 : if( y->rows<m||y->cols<n )
6753 : {
6754 0 : ae_matrix_set_length(y, ae_maxint(m, y->rows, _state), ae_maxint(n, y->cols, _state), _state);
6755 : }
6756 0 : for(i=0; i<=m-1; i++)
6757 : {
6758 0 : for(j=0; j<=n-1; j++)
6759 : {
6760 0 : y->ptr.pp_double[i][j] = x->ptr.pp_double[i][j];
6761 : }
6762 : }
6763 : }
6764 :
6765 :
6766 : /*************************************************************************
6767 : Copies vector X[] to Y[], resizing Y[] if needed.
6768 :
6769 : INPUT PARAMETERS:
6770 : N - vector length
6771 : X - array[N], source
6772 : Y - possibly preallocated array[N] (resized if needed)
6773 :
6774 : OUTPUT PARAMETERS:
6775 : Y - leading N elements are replaced by X
6776 :
6777 : -- ALGLIB --
6778 : Copyright 20.01.2020 by Bochkanov Sergey
6779 : *************************************************************************/
6780 0 : void icopyallocv(ae_int_t n,
6781 : /* Integer */ ae_vector* x,
6782 : /* Integer */ ae_vector* y,
6783 : ae_state *_state)
6784 : {
6785 : ae_int_t j;
6786 :
6787 :
6788 0 : if( y->cnt<n )
6789 : {
6790 0 : ae_vector_set_length(y, n, _state);
6791 : }
6792 0 : for(j=0; j<=n-1; j++)
6793 : {
6794 0 : y->ptr.p_int[j] = x->ptr.p_int[j];
6795 : }
6796 0 : }
6797 :
6798 :
6799 : /*************************************************************************
6800 : Copies vector X[] to Y[], resizing Y[] if needed.
6801 :
6802 : INPUT PARAMETERS:
6803 : N - vector length
6804 : X - array[N], source
6805 : Y - possibly preallocated array[N] (resized if needed)
6806 :
6807 : OUTPUT PARAMETERS:
6808 : Y - leading N elements are replaced by X
6809 :
6810 : -- ALGLIB --
6811 : Copyright 20.01.2020 by Bochkanov Sergey
6812 : *************************************************************************/
6813 0 : void bcopyallocv(ae_int_t n,
6814 : /* Boolean */ ae_vector* x,
6815 : /* Boolean */ ae_vector* y,
6816 : ae_state *_state)
6817 : {
6818 : ae_int_t j;
6819 :
6820 :
6821 0 : if( y->cnt<n )
6822 : {
6823 0 : ae_vector_set_length(y, n, _state);
6824 : }
6825 0 : for(j=0; j<=n-1; j++)
6826 : {
6827 0 : y->ptr.p_bool[j] = x->ptr.p_bool[j];
6828 : }
6829 0 : }
6830 :
6831 :
6832 : /*************************************************************************
6833 : Copies vector X[] to Y[]
6834 :
6835 : INPUT PARAMETERS:
6836 : N - vector length
6837 : X - source array
6838 : Y - preallocated array[N]
6839 :
6840 : OUTPUT PARAMETERS:
6841 : Y - X copied to Y
6842 :
6843 : -- ALGLIB --
6844 : Copyright 20.01.2020 by Bochkanov Sergey
6845 : *************************************************************************/
6846 0 : void icopyv(ae_int_t n,
6847 : /* Integer */ ae_vector* x,
6848 : /* Integer */ ae_vector* y,
6849 : ae_state *_state)
6850 : {
6851 : ae_int_t j;
6852 :
6853 :
6854 0 : for(j=0; j<=n-1; j++)
6855 : {
6856 0 : y->ptr.p_int[j] = x->ptr.p_int[j];
6857 : }
6858 0 : }
6859 :
6860 :
6861 : /*************************************************************************
6862 : Copies vector X[] to Y[], extended version
6863 :
6864 : INPUT PARAMETERS:
6865 : N - vector length
6866 : X - source array
6867 : OffsX - source offset
6868 : Y - preallocated array[N]
6869 : OffsY - destination offset
6870 :
6871 : OUTPUT PARAMETERS:
6872 : Y - N elements starting from OffsY are replaced by X[OffsX:OffsX+N-1]
6873 :
6874 : NOTE: destination and source should NOT overlap
6875 :
6876 : -- ALGLIB --
6877 : Copyright 20.01.2020 by Bochkanov Sergey
6878 : *************************************************************************/
6879 0 : void icopyvx(ae_int_t n,
6880 : /* Integer */ ae_vector* x,
6881 : ae_int_t offsx,
6882 : /* Integer */ ae_vector* y,
6883 : ae_int_t offsy,
6884 : ae_state *_state)
6885 : {
6886 : ae_int_t j;
6887 :
6888 :
6889 0 : for(j=0; j<=n-1; j++)
6890 : {
6891 0 : y->ptr.p_int[offsy+j] = x->ptr.p_int[offsx+j];
6892 : }
6893 0 : }
6894 :
6895 :
6896 : /*************************************************************************
6897 : Grows X, i.e. changes its size in such a way that:
6898 : a) contents is preserved
6899 : b) new size is at least N
6900 : c) actual size can be larger than N, so subsequent grow() calls can return
6901 : without reallocation
6902 :
6903 : -- ALGLIB --
6904 : Copyright 20.03.2009 by Bochkanov Sergey
6905 : *************************************************************************/
6906 0 : void igrowv(ae_int_t newn, /* Integer */ ae_vector* x, ae_state *_state)
6907 : {
6908 : ae_frame _frame_block;
6909 : ae_vector oldx;
6910 : ae_int_t oldn;
6911 :
6912 0 : ae_frame_make(_state, &_frame_block);
6913 0 : memset(&oldx, 0, sizeof(oldx));
6914 0 : ae_vector_init(&oldx, 0, DT_INT, _state, ae_true);
6915 :
6916 0 : if( x->cnt>=newn )
6917 : {
6918 0 : ae_frame_leave(_state);
6919 0 : return;
6920 : }
6921 0 : oldn = x->cnt;
6922 0 : newn = ae_maxint(newn, ae_round(1.8*oldn+1, _state), _state);
6923 0 : ae_swap_vectors(x, &oldx);
6924 0 : ae_vector_set_length(x, newn, _state);
6925 0 : icopyv(oldn, &oldx, x, _state);
6926 0 : ae_frame_leave(_state);
6927 : }
6928 :
6929 :
6930 : /*************************************************************************
6931 : Performs copying with multiplication of V*X[] to Y[]
6932 :
6933 : INPUT PARAMETERS:
6934 : N - vector length
6935 : V - multiplier
6936 : X - array[N], source
6937 : Y - preallocated array[N]
6938 :
6939 : OUTPUT PARAMETERS:
6940 : Y - array[N], Y = V*X
6941 :
6942 : -- ALGLIB --
6943 : Copyright 20.01.2020 by Bochkanov Sergey
6944 : *************************************************************************/
6945 0 : void rcopymulv(ae_int_t n,
6946 : double v,
6947 : /* Real */ ae_vector* x,
6948 : /* Real */ ae_vector* y,
6949 : ae_state *_state)
6950 : {
6951 : ae_int_t i;
6952 :
6953 :
6954 0 : for(i=0; i<=n-1; i++)
6955 : {
6956 0 : y->ptr.p_double[i] = v*x->ptr.p_double[i];
6957 : }
6958 0 : }
6959 :
6960 :
6961 : /*************************************************************************
6962 : Performs copying with multiplication of V*X[] to Y[I,*]
6963 :
6964 : INPUT PARAMETERS:
6965 : N - vector length
6966 : V - multiplier
6967 : X - array[N], source
6968 : Y - preallocated array[?,N]
6969 : RIdx - destination row index
6970 :
6971 : OUTPUT PARAMETERS:
6972 : Y - Y[RIdx,...] = V*X
6973 :
6974 : -- ALGLIB --
6975 : Copyright 20.01.2020 by Bochkanov Sergey
6976 : *************************************************************************/
6977 0 : void rcopymulvr(ae_int_t n,
6978 : double v,
6979 : /* Real */ ae_vector* x,
6980 : /* Real */ ae_matrix* y,
6981 : ae_int_t ridx,
6982 : ae_state *_state)
6983 : {
6984 : ae_int_t i;
6985 :
6986 :
6987 0 : for(i=0; i<=n-1; i++)
6988 : {
6989 0 : y->ptr.pp_double[ridx][i] = v*x->ptr.p_double[i];
6990 : }
6991 0 : }
6992 :
6993 :
6994 : /*************************************************************************
6995 : Copies vector X[] to row I of A[,]
6996 :
6997 : INPUT PARAMETERS:
6998 : N - vector length
6999 : X - array[N], source
7000 : A - preallocated 2D array large enough to store result
7001 : I - destination row index
7002 :
7003 : OUTPUT PARAMETERS:
7004 : A - leading N elements of I-th row are replaced by X
7005 :
7006 : -- ALGLIB --
7007 : Copyright 20.01.2020 by Bochkanov Sergey
7008 : *************************************************************************/
7009 0 : void rcopyvr(ae_int_t n,
7010 : /* Real */ ae_vector* x,
7011 : /* Real */ ae_matrix* a,
7012 : ae_int_t i,
7013 : ae_state *_state)
7014 : {
7015 : ae_int_t j;
7016 :
7017 :
7018 0 : for(j=0; j<=n-1; j++)
7019 : {
7020 0 : a->ptr.pp_double[i][j] = x->ptr.p_double[j];
7021 : }
7022 0 : }
7023 :
7024 :
7025 : /*************************************************************************
7026 : Copies row I of A[,] to vector X[]
7027 :
7028 : INPUT PARAMETERS:
7029 : N - vector length
7030 : A - 2D array, source
7031 : I - source row index
7032 : X - preallocated destination
7033 :
7034 : OUTPUT PARAMETERS:
7035 : X - array[N], destination
7036 :
7037 : -- ALGLIB --
7038 : Copyright 20.01.2020 by Bochkanov Sergey
7039 : *************************************************************************/
7040 0 : void rcopyrv(ae_int_t n,
7041 : /* Real */ ae_matrix* a,
7042 : ae_int_t i,
7043 : /* Real */ ae_vector* x,
7044 : ae_state *_state)
7045 : {
7046 : ae_int_t j;
7047 :
7048 :
7049 0 : for(j=0; j<=n-1; j++)
7050 : {
7051 0 : x->ptr.p_double[j] = a->ptr.pp_double[i][j];
7052 : }
7053 0 : }
7054 :
7055 :
7056 : /*************************************************************************
7057 : Copies row I of A[,] to row K of B[,].
7058 :
7059 : A[i,...] and B[k,...] may overlap.
7060 :
7061 : INPUT PARAMETERS:
7062 : N - vector length
7063 : A - 2D array, source
7064 : I - source row index
7065 : B - preallocated destination
7066 : K - destination row index
7067 :
7068 : OUTPUT PARAMETERS:
7069 : B - row K overwritten
7070 :
7071 : -- ALGLIB --
7072 : Copyright 20.01.2020 by Bochkanov Sergey
7073 : *************************************************************************/
7074 0 : void rcopyrr(ae_int_t n,
7075 : /* Real */ ae_matrix* a,
7076 : ae_int_t i,
7077 : /* Real */ ae_matrix* b,
7078 : ae_int_t k,
7079 : ae_state *_state)
7080 : {
7081 : ae_int_t j;
7082 :
7083 :
7084 0 : for(j=0; j<=n-1; j++)
7085 : {
7086 0 : b->ptr.pp_double[k][j] = a->ptr.pp_double[i][j];
7087 : }
7088 0 : }
7089 :
7090 :
7091 : /*************************************************************************
7092 : Copies vector X[] to column J of A[,]
7093 :
7094 : INPUT PARAMETERS:
7095 : N - vector length
7096 : X - array[N], source
7097 : A - preallocated 2D array large enough to store result
7098 : J - destination col index
7099 :
7100 : OUTPUT PARAMETERS:
7101 : A - leading N elements of J-th column are replaced by X
7102 :
7103 : -- ALGLIB --
7104 : Copyright 20.01.2020 by Bochkanov Sergey
7105 : *************************************************************************/
7106 0 : void rcopyvc(ae_int_t n,
7107 : /* Real */ ae_vector* x,
7108 : /* Real */ ae_matrix* a,
7109 : ae_int_t j,
7110 : ae_state *_state)
7111 : {
7112 : ae_int_t i;
7113 :
7114 :
7115 0 : for(i=0; i<=n-1; i++)
7116 : {
7117 0 : a->ptr.pp_double[i][j] = x->ptr.p_double[i];
7118 : }
7119 0 : }
7120 :
7121 :
7122 : /*************************************************************************
7123 : Copies column J of A[,] to vector X[]
7124 :
7125 : INPUT PARAMETERS:
7126 : N - vector length
7127 : A - source 2D array
7128 : J - source col index
7129 :
7130 : OUTPUT PARAMETERS:
7131 : X - preallocated array[N], destination
7132 :
7133 : -- ALGLIB --
7134 : Copyright 20.01.2020 by Bochkanov Sergey
7135 : *************************************************************************/
7136 0 : void rcopycv(ae_int_t n,
7137 : /* Real */ ae_matrix* a,
7138 : ae_int_t j,
7139 : /* Real */ ae_vector* x,
7140 : ae_state *_state)
7141 : {
7142 : ae_int_t i;
7143 :
7144 :
7145 0 : for(i=0; i<=n-1; i++)
7146 : {
7147 0 : x->ptr.p_double[i] = a->ptr.pp_double[i][j];
7148 : }
7149 0 : }
7150 :
7151 :
7152 : /*************************************************************************
7153 : Fast kernel
7154 :
7155 : -- ALGLIB routine --
7156 : 19.01.2010
7157 : Bochkanov Sergey
7158 : *************************************************************************/
7159 0 : ae_bool rmatrixgerf(ae_int_t m,
7160 : ae_int_t n,
7161 : /* Real */ ae_matrix* a,
7162 : ae_int_t ia,
7163 : ae_int_t ja,
7164 : double ralpha,
7165 : /* Real */ ae_vector* u,
7166 : ae_int_t iu,
7167 : /* Real */ ae_vector* v,
7168 : ae_int_t iv,
7169 : ae_state *_state)
7170 : {
7171 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7172 : ae_bool result;
7173 :
7174 :
7175 : result = ae_false;
7176 : return result;
7177 : #else
7178 0 : return _ialglib_i_rmatrixgerf(m, n, a, ia, ja, ralpha, u, iu, v, iv);
7179 : #endif
7180 : }
7181 :
7182 :
7183 : /*************************************************************************
7184 : Fast kernel
7185 :
7186 : -- ALGLIB routine --
7187 : 19.01.2010
7188 : Bochkanov Sergey
7189 : *************************************************************************/
7190 0 : ae_bool cmatrixrank1f(ae_int_t m,
7191 : ae_int_t n,
7192 : /* Complex */ ae_matrix* a,
7193 : ae_int_t ia,
7194 : ae_int_t ja,
7195 : /* Complex */ ae_vector* u,
7196 : ae_int_t iu,
7197 : /* Complex */ ae_vector* v,
7198 : ae_int_t iv,
7199 : ae_state *_state)
7200 : {
7201 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7202 : ae_bool result;
7203 :
7204 :
7205 : result = ae_false;
7206 : return result;
7207 : #else
7208 0 : return _ialglib_i_cmatrixrank1f(m, n, a, ia, ja, u, iu, v, iv);
7209 : #endif
7210 : }
7211 :
7212 :
7213 : /*************************************************************************
7214 : Fast kernel
7215 :
7216 : -- ALGLIB routine --
7217 : 19.01.2010
7218 : Bochkanov Sergey
7219 : *************************************************************************/
7220 0 : ae_bool rmatrixrank1f(ae_int_t m,
7221 : ae_int_t n,
7222 : /* Real */ ae_matrix* a,
7223 : ae_int_t ia,
7224 : ae_int_t ja,
7225 : /* Real */ ae_vector* u,
7226 : ae_int_t iu,
7227 : /* Real */ ae_vector* v,
7228 : ae_int_t iv,
7229 : ae_state *_state)
7230 : {
7231 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7232 : ae_bool result;
7233 :
7234 :
7235 : result = ae_false;
7236 : return result;
7237 : #else
7238 0 : return _ialglib_i_rmatrixrank1f(m, n, a, ia, ja, u, iu, v, iv);
7239 : #endif
7240 : }
7241 :
7242 :
7243 : /*************************************************************************
7244 : Fast kernel
7245 :
7246 : -- ALGLIB routine --
7247 : 19.01.2010
7248 : Bochkanov Sergey
7249 : *************************************************************************/
7250 0 : ae_bool cmatrixrighttrsmf(ae_int_t m,
7251 : ae_int_t n,
7252 : /* Complex */ ae_matrix* a,
7253 : ae_int_t i1,
7254 : ae_int_t j1,
7255 : ae_bool isupper,
7256 : ae_bool isunit,
7257 : ae_int_t optype,
7258 : /* Complex */ ae_matrix* x,
7259 : ae_int_t i2,
7260 : ae_int_t j2,
7261 : ae_state *_state)
7262 : {
7263 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7264 : ae_bool result;
7265 :
7266 :
7267 : result = ae_false;
7268 : return result;
7269 : #else
7270 0 : return _ialglib_i_cmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
7271 : #endif
7272 : }
7273 :
7274 :
7275 : /*************************************************************************
7276 : Fast kernel
7277 :
7278 : -- ALGLIB routine --
7279 : 19.01.2010
7280 : Bochkanov Sergey
7281 : *************************************************************************/
7282 0 : ae_bool cmatrixlefttrsmf(ae_int_t m,
7283 : ae_int_t n,
7284 : /* Complex */ ae_matrix* a,
7285 : ae_int_t i1,
7286 : ae_int_t j1,
7287 : ae_bool isupper,
7288 : ae_bool isunit,
7289 : ae_int_t optype,
7290 : /* Complex */ ae_matrix* x,
7291 : ae_int_t i2,
7292 : ae_int_t j2,
7293 : ae_state *_state)
7294 : {
7295 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7296 : ae_bool result;
7297 :
7298 :
7299 : result = ae_false;
7300 : return result;
7301 : #else
7302 0 : return _ialglib_i_cmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
7303 : #endif
7304 : }
7305 :
7306 :
7307 : /*************************************************************************
7308 : Fast kernel
7309 :
7310 : -- ALGLIB routine --
7311 : 19.01.2010
7312 : Bochkanov Sergey
7313 : *************************************************************************/
7314 0 : ae_bool rmatrixrighttrsmf(ae_int_t m,
7315 : ae_int_t n,
7316 : /* Real */ ae_matrix* a,
7317 : ae_int_t i1,
7318 : ae_int_t j1,
7319 : ae_bool isupper,
7320 : ae_bool isunit,
7321 : ae_int_t optype,
7322 : /* Real */ ae_matrix* x,
7323 : ae_int_t i2,
7324 : ae_int_t j2,
7325 : ae_state *_state)
7326 : {
7327 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7328 : ae_bool result;
7329 :
7330 :
7331 : result = ae_false;
7332 : return result;
7333 : #else
7334 0 : return _ialglib_i_rmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
7335 : #endif
7336 : }
7337 :
7338 :
7339 : /*************************************************************************
7340 : Fast kernel
7341 :
7342 : -- ALGLIB routine --
7343 : 19.01.2010
7344 : Bochkanov Sergey
7345 : *************************************************************************/
7346 0 : ae_bool rmatrixlefttrsmf(ae_int_t m,
7347 : ae_int_t n,
7348 : /* Real */ ae_matrix* a,
7349 : ae_int_t i1,
7350 : ae_int_t j1,
7351 : ae_bool isupper,
7352 : ae_bool isunit,
7353 : ae_int_t optype,
7354 : /* Real */ ae_matrix* x,
7355 : ae_int_t i2,
7356 : ae_int_t j2,
7357 : ae_state *_state)
7358 : {
7359 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7360 : ae_bool result;
7361 :
7362 :
7363 : result = ae_false;
7364 : return result;
7365 : #else
7366 0 : return _ialglib_i_rmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
7367 : #endif
7368 : }
7369 :
7370 :
7371 : /*************************************************************************
7372 : Fast kernel
7373 :
7374 : -- ALGLIB routine --
7375 : 19.01.2010
7376 : Bochkanov Sergey
7377 : *************************************************************************/
7378 0 : ae_bool cmatrixherkf(ae_int_t n,
7379 : ae_int_t k,
7380 : double alpha,
7381 : /* Complex */ ae_matrix* a,
7382 : ae_int_t ia,
7383 : ae_int_t ja,
7384 : ae_int_t optypea,
7385 : double beta,
7386 : /* Complex */ ae_matrix* c,
7387 : ae_int_t ic,
7388 : ae_int_t jc,
7389 : ae_bool isupper,
7390 : ae_state *_state)
7391 : {
7392 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7393 : ae_bool result;
7394 :
7395 :
7396 : result = ae_false;
7397 : return result;
7398 : #else
7399 0 : return _ialglib_i_cmatrixherkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper);
7400 : #endif
7401 : }
7402 :
7403 :
7404 : /*************************************************************************
7405 : Fast kernel
7406 :
7407 : -- ALGLIB routine --
7408 : 19.01.2010
7409 : Bochkanov Sergey
7410 : *************************************************************************/
7411 0 : ae_bool rmatrixsyrkf(ae_int_t n,
7412 : ae_int_t k,
7413 : double alpha,
7414 : /* Real */ ae_matrix* a,
7415 : ae_int_t ia,
7416 : ae_int_t ja,
7417 : ae_int_t optypea,
7418 : double beta,
7419 : /* Real */ ae_matrix* c,
7420 : ae_int_t ic,
7421 : ae_int_t jc,
7422 : ae_bool isupper,
7423 : ae_state *_state)
7424 : {
7425 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7426 : ae_bool result;
7427 :
7428 :
7429 : result = ae_false;
7430 : return result;
7431 : #else
7432 0 : return _ialglib_i_rmatrixsyrkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper);
7433 : #endif
7434 : }
7435 :
7436 :
7437 : /*************************************************************************
7438 : Fast kernel
7439 :
7440 : -- ALGLIB routine --
7441 : 19.01.2010
7442 : Bochkanov Sergey
7443 : *************************************************************************/
7444 0 : ae_bool rmatrixgemmf(ae_int_t m,
7445 : ae_int_t n,
7446 : ae_int_t k,
7447 : double alpha,
7448 : /* Real */ ae_matrix* a,
7449 : ae_int_t ia,
7450 : ae_int_t ja,
7451 : ae_int_t optypea,
7452 : /* Real */ ae_matrix* b,
7453 : ae_int_t ib,
7454 : ae_int_t jb,
7455 : ae_int_t optypeb,
7456 : double beta,
7457 : /* Real */ ae_matrix* c,
7458 : ae_int_t ic,
7459 : ae_int_t jc,
7460 : ae_state *_state)
7461 : {
7462 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7463 : ae_bool result;
7464 :
7465 :
7466 : result = ae_false;
7467 : return result;
7468 : #else
7469 0 : return _ialglib_i_rmatrixgemmf(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc);
7470 : #endif
7471 : }
7472 :
7473 :
7474 : /*************************************************************************
7475 : Fast kernel
7476 :
7477 : -- ALGLIB routine --
7478 : 19.01.2010
7479 : Bochkanov Sergey
7480 : *************************************************************************/
7481 0 : ae_bool cmatrixgemmf(ae_int_t m,
7482 : ae_int_t n,
7483 : ae_int_t k,
7484 : ae_complex alpha,
7485 : /* Complex */ ae_matrix* a,
7486 : ae_int_t ia,
7487 : ae_int_t ja,
7488 : ae_int_t optypea,
7489 : /* Complex */ ae_matrix* b,
7490 : ae_int_t ib,
7491 : ae_int_t jb,
7492 : ae_int_t optypeb,
7493 : ae_complex beta,
7494 : /* Complex */ ae_matrix* c,
7495 : ae_int_t ic,
7496 : ae_int_t jc,
7497 : ae_state *_state)
7498 : {
7499 : #ifndef ALGLIB_INTERCEPTS_ABLAS
7500 : ae_bool result;
7501 :
7502 :
7503 : result = ae_false;
7504 : return result;
7505 : #else
7506 0 : return _ialglib_i_cmatrixgemmf(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc);
7507 : #endif
7508 : }
7509 :
7510 :
7511 : /*************************************************************************
7512 : CMatrixGEMM kernel, basecase code for CMatrixGEMM.
7513 :
7514 : This subroutine calculates C = alpha*op1(A)*op2(B) +beta*C where:
7515 : * C is MxN general matrix
7516 : * op1(A) is MxK matrix
7517 : * op2(B) is KxN matrix
7518 : * "op" may be identity transformation, transposition, conjugate transposition
7519 :
7520 : Additional info:
7521 : * multiplication result replaces C. If Beta=0, C elements are not used in
7522 : calculations (not multiplied by zero - just not referenced)
7523 : * if Alpha=0, A is not used (not multiplied by zero - just not referenced)
7524 : * if both Beta and Alpha are zero, C is filled by zeros.
7525 :
7526 : IMPORTANT:
7527 :
7528 : This function does NOT preallocate output matrix C, it MUST be preallocated
7529 : by caller prior to calling this function. In case C does not have enough
7530 : space to store result, exception will be generated.
7531 :
7532 : INPUT PARAMETERS
7533 : M - matrix size, M>0
7534 : N - matrix size, N>0
7535 : K - matrix size, K>0
7536 : Alpha - coefficient
7537 : A - matrix
7538 : IA - submatrix offset
7539 : JA - submatrix offset
7540 : OpTypeA - transformation type:
7541 : * 0 - no transformation
7542 : * 1 - transposition
7543 : * 2 - conjugate transposition
7544 : B - matrix
7545 : IB - submatrix offset
7546 : JB - submatrix offset
7547 : OpTypeB - transformation type:
7548 : * 0 - no transformation
7549 : * 1 - transposition
7550 : * 2 - conjugate transposition
7551 : Beta - coefficient
7552 : C - PREALLOCATED output matrix
7553 : IC - submatrix offset
7554 : JC - submatrix offset
7555 :
7556 : -- ALGLIB routine --
7557 : 27.03.2013
7558 : Bochkanov Sergey
7559 : *************************************************************************/
7560 0 : void cmatrixgemmk(ae_int_t m,
7561 : ae_int_t n,
7562 : ae_int_t k,
7563 : ae_complex alpha,
7564 : /* Complex */ ae_matrix* a,
7565 : ae_int_t ia,
7566 : ae_int_t ja,
7567 : ae_int_t optypea,
7568 : /* Complex */ ae_matrix* b,
7569 : ae_int_t ib,
7570 : ae_int_t jb,
7571 : ae_int_t optypeb,
7572 : ae_complex beta,
7573 : /* Complex */ ae_matrix* c,
7574 : ae_int_t ic,
7575 : ae_int_t jc,
7576 : ae_state *_state)
7577 : {
7578 : ae_int_t i;
7579 : ae_int_t j;
7580 : ae_complex v;
7581 : ae_complex v00;
7582 : ae_complex v01;
7583 : ae_complex v10;
7584 : ae_complex v11;
7585 : double v00x;
7586 : double v00y;
7587 : double v01x;
7588 : double v01y;
7589 : double v10x;
7590 : double v10y;
7591 : double v11x;
7592 : double v11y;
7593 : double a0x;
7594 : double a0y;
7595 : double a1x;
7596 : double a1y;
7597 : double b0x;
7598 : double b0y;
7599 : double b1x;
7600 : double b1y;
7601 : ae_int_t idxa0;
7602 : ae_int_t idxa1;
7603 : ae_int_t idxb0;
7604 : ae_int_t idxb1;
7605 : ae_int_t i0;
7606 : ae_int_t i1;
7607 : ae_int_t ik;
7608 : ae_int_t j0;
7609 : ae_int_t j1;
7610 : ae_int_t jk;
7611 : ae_int_t t;
7612 : ae_int_t offsa;
7613 : ae_int_t offsb;
7614 :
7615 :
7616 :
7617 : /*
7618 : * if matrix size is zero
7619 : */
7620 0 : if( m==0||n==0 )
7621 : {
7622 0 : return;
7623 : }
7624 :
7625 : /*
7626 : * Try optimized code
7627 : */
7628 0 : if( cmatrixgemmf(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state) )
7629 : {
7630 0 : return;
7631 : }
7632 :
7633 : /*
7634 : * if K=0 or Alpha=0, then C=Beta*C
7635 : */
7636 0 : if( k==0||ae_c_eq_d(alpha,(double)(0)) )
7637 : {
7638 0 : if( ae_c_neq_d(beta,(double)(1)) )
7639 : {
7640 0 : if( ae_c_neq_d(beta,(double)(0)) )
7641 : {
7642 0 : for(i=0; i<=m-1; i++)
7643 : {
7644 0 : for(j=0; j<=n-1; j++)
7645 : {
7646 0 : c->ptr.pp_complex[ic+i][jc+j] = ae_c_mul(beta,c->ptr.pp_complex[ic+i][jc+j]);
7647 : }
7648 : }
7649 : }
7650 : else
7651 : {
7652 0 : for(i=0; i<=m-1; i++)
7653 : {
7654 0 : for(j=0; j<=n-1; j++)
7655 : {
7656 0 : c->ptr.pp_complex[ic+i][jc+j] = ae_complex_from_i(0);
7657 : }
7658 : }
7659 : }
7660 : }
7661 0 : return;
7662 : }
7663 :
7664 : /*
7665 : * This phase is not really necessary, but compiler complains
7666 : * about "possibly uninitialized variables"
7667 : */
7668 0 : a0x = (double)(0);
7669 0 : a0y = (double)(0);
7670 0 : a1x = (double)(0);
7671 0 : a1y = (double)(0);
7672 0 : b0x = (double)(0);
7673 0 : b0y = (double)(0);
7674 0 : b1x = (double)(0);
7675 0 : b1y = (double)(0);
7676 :
7677 : /*
7678 : * General case
7679 : */
7680 0 : i = 0;
7681 0 : while(i<m)
7682 : {
7683 0 : j = 0;
7684 0 : while(j<n)
7685 : {
7686 :
7687 : /*
7688 : * Choose between specialized 4x4 code and general code
7689 : */
7690 0 : if( i+2<=m&&j+2<=n )
7691 : {
7692 :
7693 : /*
7694 : * Specialized 4x4 code for [I..I+3]x[J..J+3] submatrix of C.
7695 : *
7696 : * This submatrix is calculated as sum of K rank-1 products,
7697 : * with operands cached in local variables in order to speed
7698 : * up operations with arrays.
7699 : */
7700 0 : v00x = 0.0;
7701 0 : v00y = 0.0;
7702 0 : v01x = 0.0;
7703 0 : v01y = 0.0;
7704 0 : v10x = 0.0;
7705 0 : v10y = 0.0;
7706 0 : v11x = 0.0;
7707 0 : v11y = 0.0;
7708 0 : if( optypea==0 )
7709 : {
7710 0 : idxa0 = ia+i+0;
7711 0 : idxa1 = ia+i+1;
7712 0 : offsa = ja;
7713 : }
7714 : else
7715 : {
7716 0 : idxa0 = ja+i+0;
7717 0 : idxa1 = ja+i+1;
7718 0 : offsa = ia;
7719 : }
7720 0 : if( optypeb==0 )
7721 : {
7722 0 : idxb0 = jb+j+0;
7723 0 : idxb1 = jb+j+1;
7724 0 : offsb = ib;
7725 : }
7726 : else
7727 : {
7728 0 : idxb0 = ib+j+0;
7729 0 : idxb1 = ib+j+1;
7730 0 : offsb = jb;
7731 : }
7732 0 : for(t=0; t<=k-1; t++)
7733 : {
7734 0 : if( optypea==0 )
7735 : {
7736 0 : a0x = a->ptr.pp_complex[idxa0][offsa].x;
7737 0 : a0y = a->ptr.pp_complex[idxa0][offsa].y;
7738 0 : a1x = a->ptr.pp_complex[idxa1][offsa].x;
7739 0 : a1y = a->ptr.pp_complex[idxa1][offsa].y;
7740 : }
7741 0 : if( optypea==1 )
7742 : {
7743 0 : a0x = a->ptr.pp_complex[offsa][idxa0].x;
7744 0 : a0y = a->ptr.pp_complex[offsa][idxa0].y;
7745 0 : a1x = a->ptr.pp_complex[offsa][idxa1].x;
7746 0 : a1y = a->ptr.pp_complex[offsa][idxa1].y;
7747 : }
7748 0 : if( optypea==2 )
7749 : {
7750 0 : a0x = a->ptr.pp_complex[offsa][idxa0].x;
7751 0 : a0y = -a->ptr.pp_complex[offsa][idxa0].y;
7752 0 : a1x = a->ptr.pp_complex[offsa][idxa1].x;
7753 0 : a1y = -a->ptr.pp_complex[offsa][idxa1].y;
7754 : }
7755 0 : if( optypeb==0 )
7756 : {
7757 0 : b0x = b->ptr.pp_complex[offsb][idxb0].x;
7758 0 : b0y = b->ptr.pp_complex[offsb][idxb0].y;
7759 0 : b1x = b->ptr.pp_complex[offsb][idxb1].x;
7760 0 : b1y = b->ptr.pp_complex[offsb][idxb1].y;
7761 : }
7762 0 : if( optypeb==1 )
7763 : {
7764 0 : b0x = b->ptr.pp_complex[idxb0][offsb].x;
7765 0 : b0y = b->ptr.pp_complex[idxb0][offsb].y;
7766 0 : b1x = b->ptr.pp_complex[idxb1][offsb].x;
7767 0 : b1y = b->ptr.pp_complex[idxb1][offsb].y;
7768 : }
7769 0 : if( optypeb==2 )
7770 : {
7771 0 : b0x = b->ptr.pp_complex[idxb0][offsb].x;
7772 0 : b0y = -b->ptr.pp_complex[idxb0][offsb].y;
7773 0 : b1x = b->ptr.pp_complex[idxb1][offsb].x;
7774 0 : b1y = -b->ptr.pp_complex[idxb1][offsb].y;
7775 : }
7776 0 : v00x = v00x+a0x*b0x-a0y*b0y;
7777 0 : v00y = v00y+a0x*b0y+a0y*b0x;
7778 0 : v01x = v01x+a0x*b1x-a0y*b1y;
7779 0 : v01y = v01y+a0x*b1y+a0y*b1x;
7780 0 : v10x = v10x+a1x*b0x-a1y*b0y;
7781 0 : v10y = v10y+a1x*b0y+a1y*b0x;
7782 0 : v11x = v11x+a1x*b1x-a1y*b1y;
7783 0 : v11y = v11y+a1x*b1y+a1y*b1x;
7784 0 : offsa = offsa+1;
7785 0 : offsb = offsb+1;
7786 : }
7787 0 : v00.x = v00x;
7788 0 : v00.y = v00y;
7789 0 : v10.x = v10x;
7790 0 : v10.y = v10y;
7791 0 : v01.x = v01x;
7792 0 : v01.y = v01y;
7793 0 : v11.x = v11x;
7794 0 : v11.y = v11y;
7795 0 : if( ae_c_eq_d(beta,(double)(0)) )
7796 : {
7797 0 : c->ptr.pp_complex[ic+i+0][jc+j+0] = ae_c_mul(alpha,v00);
7798 0 : c->ptr.pp_complex[ic+i+0][jc+j+1] = ae_c_mul(alpha,v01);
7799 0 : c->ptr.pp_complex[ic+i+1][jc+j+0] = ae_c_mul(alpha,v10);
7800 0 : c->ptr.pp_complex[ic+i+1][jc+j+1] = ae_c_mul(alpha,v11);
7801 : }
7802 : else
7803 : {
7804 0 : c->ptr.pp_complex[ic+i+0][jc+j+0] = ae_c_add(ae_c_mul(beta,c->ptr.pp_complex[ic+i+0][jc+j+0]),ae_c_mul(alpha,v00));
7805 0 : c->ptr.pp_complex[ic+i+0][jc+j+1] = ae_c_add(ae_c_mul(beta,c->ptr.pp_complex[ic+i+0][jc+j+1]),ae_c_mul(alpha,v01));
7806 0 : c->ptr.pp_complex[ic+i+1][jc+j+0] = ae_c_add(ae_c_mul(beta,c->ptr.pp_complex[ic+i+1][jc+j+0]),ae_c_mul(alpha,v10));
7807 0 : c->ptr.pp_complex[ic+i+1][jc+j+1] = ae_c_add(ae_c_mul(beta,c->ptr.pp_complex[ic+i+1][jc+j+1]),ae_c_mul(alpha,v11));
7808 : }
7809 : }
7810 : else
7811 : {
7812 :
7813 : /*
7814 : * Determine submatrix [I0..I1]x[J0..J1] to process
7815 : */
7816 0 : i0 = i;
7817 0 : i1 = ae_minint(i+1, m-1, _state);
7818 0 : j0 = j;
7819 0 : j1 = ae_minint(j+1, n-1, _state);
7820 :
7821 : /*
7822 : * Process submatrix
7823 : */
7824 0 : for(ik=i0; ik<=i1; ik++)
7825 : {
7826 0 : for(jk=j0; jk<=j1; jk++)
7827 : {
7828 0 : if( k==0||ae_c_eq_d(alpha,(double)(0)) )
7829 : {
7830 0 : v = ae_complex_from_i(0);
7831 : }
7832 : else
7833 : {
7834 0 : v = ae_complex_from_d(0.0);
7835 0 : if( optypea==0&&optypeb==0 )
7836 : {
7837 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia+ik][ja], 1, "N", &b->ptr.pp_complex[ib][jb+jk], b->stride, "N", ae_v_len(ja,ja+k-1));
7838 : }
7839 0 : if( optypea==0&&optypeb==1 )
7840 : {
7841 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia+ik][ja], 1, "N", &b->ptr.pp_complex[ib+jk][jb], 1, "N", ae_v_len(ja,ja+k-1));
7842 : }
7843 0 : if( optypea==0&&optypeb==2 )
7844 : {
7845 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia+ik][ja], 1, "N", &b->ptr.pp_complex[ib+jk][jb], 1, "Conj", ae_v_len(ja,ja+k-1));
7846 : }
7847 0 : if( optypea==1&&optypeb==0 )
7848 : {
7849 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "N", &b->ptr.pp_complex[ib][jb+jk], b->stride, "N", ae_v_len(ia,ia+k-1));
7850 : }
7851 0 : if( optypea==1&&optypeb==1 )
7852 : {
7853 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "N", &b->ptr.pp_complex[ib+jk][jb], 1, "N", ae_v_len(ia,ia+k-1));
7854 : }
7855 0 : if( optypea==1&&optypeb==2 )
7856 : {
7857 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "N", &b->ptr.pp_complex[ib+jk][jb], 1, "Conj", ae_v_len(ia,ia+k-1));
7858 : }
7859 0 : if( optypea==2&&optypeb==0 )
7860 : {
7861 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "Conj", &b->ptr.pp_complex[ib][jb+jk], b->stride, "N", ae_v_len(ia,ia+k-1));
7862 : }
7863 0 : if( optypea==2&&optypeb==1 )
7864 : {
7865 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "Conj", &b->ptr.pp_complex[ib+jk][jb], 1, "N", ae_v_len(ia,ia+k-1));
7866 : }
7867 0 : if( optypea==2&&optypeb==2 )
7868 : {
7869 0 : v = ae_v_cdotproduct(&a->ptr.pp_complex[ia][ja+ik], a->stride, "Conj", &b->ptr.pp_complex[ib+jk][jb], 1, "Conj", ae_v_len(ia,ia+k-1));
7870 : }
7871 : }
7872 0 : if( ae_c_eq_d(beta,(double)(0)) )
7873 : {
7874 0 : c->ptr.pp_complex[ic+ik][jc+jk] = ae_c_mul(alpha,v);
7875 : }
7876 : else
7877 : {
7878 0 : c->ptr.pp_complex[ic+ik][jc+jk] = ae_c_add(ae_c_mul(beta,c->ptr.pp_complex[ic+ik][jc+jk]),ae_c_mul(alpha,v));
7879 : }
7880 : }
7881 : }
7882 : }
7883 0 : j = j+2;
7884 : }
7885 0 : i = i+2;
7886 : }
7887 : }
7888 :
7889 :
7890 : /*************************************************************************
7891 : RMatrixGEMM kernel, basecase code for RMatrixGEMM.
7892 :
7893 : This subroutine calculates C = alpha*op1(A)*op2(B) +beta*C where:
7894 : * C is MxN general matrix
7895 : * op1(A) is MxK matrix
7896 : * op2(B) is KxN matrix
7897 : * "op" may be identity transformation, transposition
7898 :
7899 : Additional info:
7900 : * multiplication result replaces C. If Beta=0, C elements are not used in
7901 : calculations (not multiplied by zero - just not referenced)
7902 : * if Alpha=0, A is not used (not multiplied by zero - just not referenced)
7903 : * if both Beta and Alpha are zero, C is filled by zeros.
7904 :
7905 : IMPORTANT:
7906 :
7907 : This function does NOT preallocate output matrix C, it MUST be preallocated
7908 : by caller prior to calling this function. In case C does not have enough
7909 : space to store result, exception will be generated.
7910 :
7911 : INPUT PARAMETERS
7912 : M - matrix size, M>0
7913 : N - matrix size, N>0
7914 : K - matrix size, K>0
7915 : Alpha - coefficient
7916 : A - matrix
7917 : IA - submatrix offset
7918 : JA - submatrix offset
7919 : OpTypeA - transformation type:
7920 : * 0 - no transformation
7921 : * 1 - transposition
7922 : B - matrix
7923 : IB - submatrix offset
7924 : JB - submatrix offset
7925 : OpTypeB - transformation type:
7926 : * 0 - no transformation
7927 : * 1 - transposition
7928 : Beta - coefficient
7929 : C - PREALLOCATED output matrix
7930 : IC - submatrix offset
7931 : JC - submatrix offset
7932 :
7933 : -- ALGLIB routine --
7934 : 27.03.2013
7935 : Bochkanov Sergey
7936 : *************************************************************************/
7937 0 : void rmatrixgemmk(ae_int_t m,
7938 : ae_int_t n,
7939 : ae_int_t k,
7940 : double alpha,
7941 : /* Real */ ae_matrix* a,
7942 : ae_int_t ia,
7943 : ae_int_t ja,
7944 : ae_int_t optypea,
7945 : /* Real */ ae_matrix* b,
7946 : ae_int_t ib,
7947 : ae_int_t jb,
7948 : ae_int_t optypeb,
7949 : double beta,
7950 : /* Real */ ae_matrix* c,
7951 : ae_int_t ic,
7952 : ae_int_t jc,
7953 : ae_state *_state)
7954 : {
7955 : ae_int_t i;
7956 : ae_int_t j;
7957 :
7958 :
7959 :
7960 : /*
7961 : * if matrix size is zero
7962 : */
7963 0 : if( m==0||n==0 )
7964 : {
7965 0 : return;
7966 : }
7967 :
7968 : /*
7969 : * Try optimized code
7970 : */
7971 0 : if( rmatrixgemmf(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state) )
7972 : {
7973 0 : return;
7974 : }
7975 :
7976 : /*
7977 : * if K=0 or Alpha=0, then C=Beta*C
7978 : */
7979 0 : if( k==0||ae_fp_eq(alpha,(double)(0)) )
7980 : {
7981 0 : if( ae_fp_neq(beta,(double)(1)) )
7982 : {
7983 0 : if( ae_fp_neq(beta,(double)(0)) )
7984 : {
7985 0 : for(i=0; i<=m-1; i++)
7986 : {
7987 0 : for(j=0; j<=n-1; j++)
7988 : {
7989 0 : c->ptr.pp_double[ic+i][jc+j] = beta*c->ptr.pp_double[ic+i][jc+j];
7990 : }
7991 : }
7992 : }
7993 : else
7994 : {
7995 0 : for(i=0; i<=m-1; i++)
7996 : {
7997 0 : for(j=0; j<=n-1; j++)
7998 : {
7999 0 : c->ptr.pp_double[ic+i][jc+j] = (double)(0);
8000 : }
8001 : }
8002 : }
8003 : }
8004 0 : return;
8005 : }
8006 :
8007 : /*
8008 : * Call specialized code.
8009 : *
8010 : * NOTE: specialized code was moved to separate function because of strange
8011 : * issues with instructions cache on some systems; Having too long
8012 : * functions significantly slows down internal loop of the algorithm.
8013 : */
8014 0 : if( optypea==0&&optypeb==0 )
8015 : {
8016 0 : rmatrixgemmk44v00(m, n, k, alpha, a, ia, ja, b, ib, jb, beta, c, ic, jc, _state);
8017 : }
8018 0 : if( optypea==0&&optypeb!=0 )
8019 : {
8020 0 : rmatrixgemmk44v01(m, n, k, alpha, a, ia, ja, b, ib, jb, beta, c, ic, jc, _state);
8021 : }
8022 0 : if( optypea!=0&&optypeb==0 )
8023 : {
8024 0 : rmatrixgemmk44v10(m, n, k, alpha, a, ia, ja, b, ib, jb, beta, c, ic, jc, _state);
8025 : }
8026 0 : if( optypea!=0&&optypeb!=0 )
8027 : {
8028 0 : rmatrixgemmk44v11(m, n, k, alpha, a, ia, ja, b, ib, jb, beta, c, ic, jc, _state);
8029 : }
8030 : }
8031 :
8032 :
8033 : /*************************************************************************
8034 : RMatrixGEMM kernel, basecase code for RMatrixGEMM, specialized for sitation
8035 : with OpTypeA=0 and OpTypeB=0.
8036 :
8037 : Additional info:
8038 : * this function requires that Alpha<>0 (assertion is thrown otherwise)
8039 :
8040 : INPUT PARAMETERS
8041 : M - matrix size, M>0
8042 : N - matrix size, N>0
8043 : K - matrix size, K>0
8044 : Alpha - coefficient
8045 : A - matrix
8046 : IA - submatrix offset
8047 : JA - submatrix offset
8048 : B - matrix
8049 : IB - submatrix offset
8050 : JB - submatrix offset
8051 : Beta - coefficient
8052 : C - PREALLOCATED output matrix
8053 : IC - submatrix offset
8054 : JC - submatrix offset
8055 :
8056 : -- ALGLIB routine --
8057 : 27.03.2013
8058 : Bochkanov Sergey
8059 : *************************************************************************/
8060 0 : void rmatrixgemmk44v00(ae_int_t m,
8061 : ae_int_t n,
8062 : ae_int_t k,
8063 : double alpha,
8064 : /* Real */ ae_matrix* a,
8065 : ae_int_t ia,
8066 : ae_int_t ja,
8067 : /* Real */ ae_matrix* b,
8068 : ae_int_t ib,
8069 : ae_int_t jb,
8070 : double beta,
8071 : /* Real */ ae_matrix* c,
8072 : ae_int_t ic,
8073 : ae_int_t jc,
8074 : ae_state *_state)
8075 : {
8076 : ae_int_t i;
8077 : ae_int_t j;
8078 : double v;
8079 : double v00;
8080 : double v01;
8081 : double v02;
8082 : double v03;
8083 : double v10;
8084 : double v11;
8085 : double v12;
8086 : double v13;
8087 : double v20;
8088 : double v21;
8089 : double v22;
8090 : double v23;
8091 : double v30;
8092 : double v31;
8093 : double v32;
8094 : double v33;
8095 : double a0;
8096 : double a1;
8097 : double a2;
8098 : double a3;
8099 : double b0;
8100 : double b1;
8101 : double b2;
8102 : double b3;
8103 : ae_int_t idxa0;
8104 : ae_int_t idxa1;
8105 : ae_int_t idxa2;
8106 : ae_int_t idxa3;
8107 : ae_int_t idxb0;
8108 : ae_int_t idxb1;
8109 : ae_int_t idxb2;
8110 : ae_int_t idxb3;
8111 : ae_int_t i0;
8112 : ae_int_t i1;
8113 : ae_int_t ik;
8114 : ae_int_t j0;
8115 : ae_int_t j1;
8116 : ae_int_t jk;
8117 : ae_int_t t;
8118 : ae_int_t offsa;
8119 : ae_int_t offsb;
8120 :
8121 :
8122 0 : ae_assert(ae_fp_neq(alpha,(double)(0)), "RMatrixGEMMK44V00: internal error (Alpha=0)", _state);
8123 :
8124 : /*
8125 : * if matrix size is zero
8126 : */
8127 0 : if( m==0||n==0 )
8128 : {
8129 0 : return;
8130 : }
8131 :
8132 : /*
8133 : * A*B
8134 : */
8135 0 : i = 0;
8136 0 : while(i<m)
8137 : {
8138 0 : j = 0;
8139 0 : while(j<n)
8140 : {
8141 :
8142 : /*
8143 : * Choose between specialized 4x4 code and general code
8144 : */
8145 0 : if( i+4<=m&&j+4<=n )
8146 : {
8147 :
8148 : /*
8149 : * Specialized 4x4 code for [I..I+3]x[J..J+3] submatrix of C.
8150 : *
8151 : * This submatrix is calculated as sum of K rank-1 products,
8152 : * with operands cached in local variables in order to speed
8153 : * up operations with arrays.
8154 : */
8155 0 : idxa0 = ia+i+0;
8156 0 : idxa1 = ia+i+1;
8157 0 : idxa2 = ia+i+2;
8158 0 : idxa3 = ia+i+3;
8159 0 : offsa = ja;
8160 0 : idxb0 = jb+j+0;
8161 0 : idxb1 = jb+j+1;
8162 0 : idxb2 = jb+j+2;
8163 0 : idxb3 = jb+j+3;
8164 0 : offsb = ib;
8165 0 : v00 = 0.0;
8166 0 : v01 = 0.0;
8167 0 : v02 = 0.0;
8168 0 : v03 = 0.0;
8169 0 : v10 = 0.0;
8170 0 : v11 = 0.0;
8171 0 : v12 = 0.0;
8172 0 : v13 = 0.0;
8173 0 : v20 = 0.0;
8174 0 : v21 = 0.0;
8175 0 : v22 = 0.0;
8176 0 : v23 = 0.0;
8177 0 : v30 = 0.0;
8178 0 : v31 = 0.0;
8179 0 : v32 = 0.0;
8180 0 : v33 = 0.0;
8181 :
8182 : /*
8183 : * Different variants of internal loop
8184 : */
8185 0 : for(t=0; t<=k-1; t++)
8186 : {
8187 0 : a0 = a->ptr.pp_double[idxa0][offsa];
8188 0 : a1 = a->ptr.pp_double[idxa1][offsa];
8189 0 : b0 = b->ptr.pp_double[offsb][idxb0];
8190 0 : b1 = b->ptr.pp_double[offsb][idxb1];
8191 0 : v00 = v00+a0*b0;
8192 0 : v01 = v01+a0*b1;
8193 0 : v10 = v10+a1*b0;
8194 0 : v11 = v11+a1*b1;
8195 0 : a2 = a->ptr.pp_double[idxa2][offsa];
8196 0 : a3 = a->ptr.pp_double[idxa3][offsa];
8197 0 : v20 = v20+a2*b0;
8198 0 : v21 = v21+a2*b1;
8199 0 : v30 = v30+a3*b0;
8200 0 : v31 = v31+a3*b1;
8201 0 : b2 = b->ptr.pp_double[offsb][idxb2];
8202 0 : b3 = b->ptr.pp_double[offsb][idxb3];
8203 0 : v22 = v22+a2*b2;
8204 0 : v23 = v23+a2*b3;
8205 0 : v32 = v32+a3*b2;
8206 0 : v33 = v33+a3*b3;
8207 0 : v02 = v02+a0*b2;
8208 0 : v03 = v03+a0*b3;
8209 0 : v12 = v12+a1*b2;
8210 0 : v13 = v13+a1*b3;
8211 0 : offsa = offsa+1;
8212 0 : offsb = offsb+1;
8213 : }
8214 0 : if( ae_fp_eq(beta,(double)(0)) )
8215 : {
8216 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = alpha*v00;
8217 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = alpha*v01;
8218 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = alpha*v02;
8219 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = alpha*v03;
8220 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = alpha*v10;
8221 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = alpha*v11;
8222 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = alpha*v12;
8223 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = alpha*v13;
8224 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = alpha*v20;
8225 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = alpha*v21;
8226 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = alpha*v22;
8227 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = alpha*v23;
8228 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = alpha*v30;
8229 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = alpha*v31;
8230 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = alpha*v32;
8231 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = alpha*v33;
8232 : }
8233 : else
8234 : {
8235 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = beta*c->ptr.pp_double[ic+i+0][jc+j+0]+alpha*v00;
8236 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = beta*c->ptr.pp_double[ic+i+0][jc+j+1]+alpha*v01;
8237 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = beta*c->ptr.pp_double[ic+i+0][jc+j+2]+alpha*v02;
8238 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = beta*c->ptr.pp_double[ic+i+0][jc+j+3]+alpha*v03;
8239 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = beta*c->ptr.pp_double[ic+i+1][jc+j+0]+alpha*v10;
8240 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = beta*c->ptr.pp_double[ic+i+1][jc+j+1]+alpha*v11;
8241 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = beta*c->ptr.pp_double[ic+i+1][jc+j+2]+alpha*v12;
8242 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = beta*c->ptr.pp_double[ic+i+1][jc+j+3]+alpha*v13;
8243 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = beta*c->ptr.pp_double[ic+i+2][jc+j+0]+alpha*v20;
8244 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = beta*c->ptr.pp_double[ic+i+2][jc+j+1]+alpha*v21;
8245 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = beta*c->ptr.pp_double[ic+i+2][jc+j+2]+alpha*v22;
8246 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = beta*c->ptr.pp_double[ic+i+2][jc+j+3]+alpha*v23;
8247 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = beta*c->ptr.pp_double[ic+i+3][jc+j+0]+alpha*v30;
8248 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = beta*c->ptr.pp_double[ic+i+3][jc+j+1]+alpha*v31;
8249 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = beta*c->ptr.pp_double[ic+i+3][jc+j+2]+alpha*v32;
8250 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = beta*c->ptr.pp_double[ic+i+3][jc+j+3]+alpha*v33;
8251 : }
8252 : }
8253 : else
8254 : {
8255 :
8256 : /*
8257 : * Determine submatrix [I0..I1]x[J0..J1] to process
8258 : */
8259 0 : i0 = i;
8260 0 : i1 = ae_minint(i+3, m-1, _state);
8261 0 : j0 = j;
8262 0 : j1 = ae_minint(j+3, n-1, _state);
8263 :
8264 : /*
8265 : * Process submatrix
8266 : */
8267 0 : for(ik=i0; ik<=i1; ik++)
8268 : {
8269 0 : for(jk=j0; jk<=j1; jk++)
8270 : {
8271 0 : if( k==0||ae_fp_eq(alpha,(double)(0)) )
8272 : {
8273 0 : v = (double)(0);
8274 : }
8275 : else
8276 : {
8277 0 : v = ae_v_dotproduct(&a->ptr.pp_double[ia+ik][ja], 1, &b->ptr.pp_double[ib][jb+jk], b->stride, ae_v_len(ja,ja+k-1));
8278 : }
8279 0 : if( ae_fp_eq(beta,(double)(0)) )
8280 : {
8281 0 : c->ptr.pp_double[ic+ik][jc+jk] = alpha*v;
8282 : }
8283 : else
8284 : {
8285 0 : c->ptr.pp_double[ic+ik][jc+jk] = beta*c->ptr.pp_double[ic+ik][jc+jk]+alpha*v;
8286 : }
8287 : }
8288 : }
8289 : }
8290 0 : j = j+4;
8291 : }
8292 0 : i = i+4;
8293 : }
8294 : }
8295 :
8296 :
8297 : /*************************************************************************
8298 : RMatrixGEMM kernel, basecase code for RMatrixGEMM, specialized for sitation
8299 : with OpTypeA=0 and OpTypeB=1.
8300 :
8301 : Additional info:
8302 : * this function requires that Alpha<>0 (assertion is thrown otherwise)
8303 :
8304 : INPUT PARAMETERS
8305 : M - matrix size, M>0
8306 : N - matrix size, N>0
8307 : K - matrix size, K>0
8308 : Alpha - coefficient
8309 : A - matrix
8310 : IA - submatrix offset
8311 : JA - submatrix offset
8312 : B - matrix
8313 : IB - submatrix offset
8314 : JB - submatrix offset
8315 : Beta - coefficient
8316 : C - PREALLOCATED output matrix
8317 : IC - submatrix offset
8318 : JC - submatrix offset
8319 :
8320 : -- ALGLIB routine --
8321 : 27.03.2013
8322 : Bochkanov Sergey
8323 : *************************************************************************/
8324 0 : void rmatrixgemmk44v01(ae_int_t m,
8325 : ae_int_t n,
8326 : ae_int_t k,
8327 : double alpha,
8328 : /* Real */ ae_matrix* a,
8329 : ae_int_t ia,
8330 : ae_int_t ja,
8331 : /* Real */ ae_matrix* b,
8332 : ae_int_t ib,
8333 : ae_int_t jb,
8334 : double beta,
8335 : /* Real */ ae_matrix* c,
8336 : ae_int_t ic,
8337 : ae_int_t jc,
8338 : ae_state *_state)
8339 : {
8340 : ae_int_t i;
8341 : ae_int_t j;
8342 : double v;
8343 : double v00;
8344 : double v01;
8345 : double v02;
8346 : double v03;
8347 : double v10;
8348 : double v11;
8349 : double v12;
8350 : double v13;
8351 : double v20;
8352 : double v21;
8353 : double v22;
8354 : double v23;
8355 : double v30;
8356 : double v31;
8357 : double v32;
8358 : double v33;
8359 : double a0;
8360 : double a1;
8361 : double a2;
8362 : double a3;
8363 : double b0;
8364 : double b1;
8365 : double b2;
8366 : double b3;
8367 : ae_int_t idxa0;
8368 : ae_int_t idxa1;
8369 : ae_int_t idxa2;
8370 : ae_int_t idxa3;
8371 : ae_int_t idxb0;
8372 : ae_int_t idxb1;
8373 : ae_int_t idxb2;
8374 : ae_int_t idxb3;
8375 : ae_int_t i0;
8376 : ae_int_t i1;
8377 : ae_int_t ik;
8378 : ae_int_t j0;
8379 : ae_int_t j1;
8380 : ae_int_t jk;
8381 : ae_int_t t;
8382 : ae_int_t offsa;
8383 : ae_int_t offsb;
8384 :
8385 :
8386 0 : ae_assert(ae_fp_neq(alpha,(double)(0)), "RMatrixGEMMK44V00: internal error (Alpha=0)", _state);
8387 :
8388 : /*
8389 : * if matrix size is zero
8390 : */
8391 0 : if( m==0||n==0 )
8392 : {
8393 0 : return;
8394 : }
8395 :
8396 : /*
8397 : * A*B'
8398 : */
8399 0 : i = 0;
8400 0 : while(i<m)
8401 : {
8402 0 : j = 0;
8403 0 : while(j<n)
8404 : {
8405 :
8406 : /*
8407 : * Choose between specialized 4x4 code and general code
8408 : */
8409 0 : if( i+4<=m&&j+4<=n )
8410 : {
8411 :
8412 : /*
8413 : * Specialized 4x4 code for [I..I+3]x[J..J+3] submatrix of C.
8414 : *
8415 : * This submatrix is calculated as sum of K rank-1 products,
8416 : * with operands cached in local variables in order to speed
8417 : * up operations with arrays.
8418 : */
8419 0 : idxa0 = ia+i+0;
8420 0 : idxa1 = ia+i+1;
8421 0 : idxa2 = ia+i+2;
8422 0 : idxa3 = ia+i+3;
8423 0 : offsa = ja;
8424 0 : idxb0 = ib+j+0;
8425 0 : idxb1 = ib+j+1;
8426 0 : idxb2 = ib+j+2;
8427 0 : idxb3 = ib+j+3;
8428 0 : offsb = jb;
8429 0 : v00 = 0.0;
8430 0 : v01 = 0.0;
8431 0 : v02 = 0.0;
8432 0 : v03 = 0.0;
8433 0 : v10 = 0.0;
8434 0 : v11 = 0.0;
8435 0 : v12 = 0.0;
8436 0 : v13 = 0.0;
8437 0 : v20 = 0.0;
8438 0 : v21 = 0.0;
8439 0 : v22 = 0.0;
8440 0 : v23 = 0.0;
8441 0 : v30 = 0.0;
8442 0 : v31 = 0.0;
8443 0 : v32 = 0.0;
8444 0 : v33 = 0.0;
8445 0 : for(t=0; t<=k-1; t++)
8446 : {
8447 0 : a0 = a->ptr.pp_double[idxa0][offsa];
8448 0 : a1 = a->ptr.pp_double[idxa1][offsa];
8449 0 : b0 = b->ptr.pp_double[idxb0][offsb];
8450 0 : b1 = b->ptr.pp_double[idxb1][offsb];
8451 0 : v00 = v00+a0*b0;
8452 0 : v01 = v01+a0*b1;
8453 0 : v10 = v10+a1*b0;
8454 0 : v11 = v11+a1*b1;
8455 0 : a2 = a->ptr.pp_double[idxa2][offsa];
8456 0 : a3 = a->ptr.pp_double[idxa3][offsa];
8457 0 : v20 = v20+a2*b0;
8458 0 : v21 = v21+a2*b1;
8459 0 : v30 = v30+a3*b0;
8460 0 : v31 = v31+a3*b1;
8461 0 : b2 = b->ptr.pp_double[idxb2][offsb];
8462 0 : b3 = b->ptr.pp_double[idxb3][offsb];
8463 0 : v22 = v22+a2*b2;
8464 0 : v23 = v23+a2*b3;
8465 0 : v32 = v32+a3*b2;
8466 0 : v33 = v33+a3*b3;
8467 0 : v02 = v02+a0*b2;
8468 0 : v03 = v03+a0*b3;
8469 0 : v12 = v12+a1*b2;
8470 0 : v13 = v13+a1*b3;
8471 0 : offsa = offsa+1;
8472 0 : offsb = offsb+1;
8473 : }
8474 0 : if( ae_fp_eq(beta,(double)(0)) )
8475 : {
8476 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = alpha*v00;
8477 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = alpha*v01;
8478 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = alpha*v02;
8479 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = alpha*v03;
8480 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = alpha*v10;
8481 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = alpha*v11;
8482 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = alpha*v12;
8483 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = alpha*v13;
8484 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = alpha*v20;
8485 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = alpha*v21;
8486 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = alpha*v22;
8487 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = alpha*v23;
8488 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = alpha*v30;
8489 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = alpha*v31;
8490 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = alpha*v32;
8491 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = alpha*v33;
8492 : }
8493 : else
8494 : {
8495 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = beta*c->ptr.pp_double[ic+i+0][jc+j+0]+alpha*v00;
8496 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = beta*c->ptr.pp_double[ic+i+0][jc+j+1]+alpha*v01;
8497 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = beta*c->ptr.pp_double[ic+i+0][jc+j+2]+alpha*v02;
8498 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = beta*c->ptr.pp_double[ic+i+0][jc+j+3]+alpha*v03;
8499 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = beta*c->ptr.pp_double[ic+i+1][jc+j+0]+alpha*v10;
8500 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = beta*c->ptr.pp_double[ic+i+1][jc+j+1]+alpha*v11;
8501 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = beta*c->ptr.pp_double[ic+i+1][jc+j+2]+alpha*v12;
8502 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = beta*c->ptr.pp_double[ic+i+1][jc+j+3]+alpha*v13;
8503 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = beta*c->ptr.pp_double[ic+i+2][jc+j+0]+alpha*v20;
8504 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = beta*c->ptr.pp_double[ic+i+2][jc+j+1]+alpha*v21;
8505 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = beta*c->ptr.pp_double[ic+i+2][jc+j+2]+alpha*v22;
8506 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = beta*c->ptr.pp_double[ic+i+2][jc+j+3]+alpha*v23;
8507 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = beta*c->ptr.pp_double[ic+i+3][jc+j+0]+alpha*v30;
8508 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = beta*c->ptr.pp_double[ic+i+3][jc+j+1]+alpha*v31;
8509 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = beta*c->ptr.pp_double[ic+i+3][jc+j+2]+alpha*v32;
8510 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = beta*c->ptr.pp_double[ic+i+3][jc+j+3]+alpha*v33;
8511 : }
8512 : }
8513 : else
8514 : {
8515 :
8516 : /*
8517 : * Determine submatrix [I0..I1]x[J0..J1] to process
8518 : */
8519 0 : i0 = i;
8520 0 : i1 = ae_minint(i+3, m-1, _state);
8521 0 : j0 = j;
8522 0 : j1 = ae_minint(j+3, n-1, _state);
8523 :
8524 : /*
8525 : * Process submatrix
8526 : */
8527 0 : for(ik=i0; ik<=i1; ik++)
8528 : {
8529 0 : for(jk=j0; jk<=j1; jk++)
8530 : {
8531 0 : if( k==0||ae_fp_eq(alpha,(double)(0)) )
8532 : {
8533 0 : v = (double)(0);
8534 : }
8535 : else
8536 : {
8537 0 : v = ae_v_dotproduct(&a->ptr.pp_double[ia+ik][ja], 1, &b->ptr.pp_double[ib+jk][jb], 1, ae_v_len(ja,ja+k-1));
8538 : }
8539 0 : if( ae_fp_eq(beta,(double)(0)) )
8540 : {
8541 0 : c->ptr.pp_double[ic+ik][jc+jk] = alpha*v;
8542 : }
8543 : else
8544 : {
8545 0 : c->ptr.pp_double[ic+ik][jc+jk] = beta*c->ptr.pp_double[ic+ik][jc+jk]+alpha*v;
8546 : }
8547 : }
8548 : }
8549 : }
8550 0 : j = j+4;
8551 : }
8552 0 : i = i+4;
8553 : }
8554 : }
8555 :
8556 :
8557 : /*************************************************************************
8558 : RMatrixGEMM kernel, basecase code for RMatrixGEMM, specialized for sitation
8559 : with OpTypeA=1 and OpTypeB=0.
8560 :
8561 : Additional info:
8562 : * this function requires that Alpha<>0 (assertion is thrown otherwise)
8563 :
8564 : INPUT PARAMETERS
8565 : M - matrix size, M>0
8566 : N - matrix size, N>0
8567 : K - matrix size, K>0
8568 : Alpha - coefficient
8569 : A - matrix
8570 : IA - submatrix offset
8571 : JA - submatrix offset
8572 : B - matrix
8573 : IB - submatrix offset
8574 : JB - submatrix offset
8575 : Beta - coefficient
8576 : C - PREALLOCATED output matrix
8577 : IC - submatrix offset
8578 : JC - submatrix offset
8579 :
8580 : -- ALGLIB routine --
8581 : 27.03.2013
8582 : Bochkanov Sergey
8583 : *************************************************************************/
8584 0 : void rmatrixgemmk44v10(ae_int_t m,
8585 : ae_int_t n,
8586 : ae_int_t k,
8587 : double alpha,
8588 : /* Real */ ae_matrix* a,
8589 : ae_int_t ia,
8590 : ae_int_t ja,
8591 : /* Real */ ae_matrix* b,
8592 : ae_int_t ib,
8593 : ae_int_t jb,
8594 : double beta,
8595 : /* Real */ ae_matrix* c,
8596 : ae_int_t ic,
8597 : ae_int_t jc,
8598 : ae_state *_state)
8599 : {
8600 : ae_int_t i;
8601 : ae_int_t j;
8602 : double v;
8603 : double v00;
8604 : double v01;
8605 : double v02;
8606 : double v03;
8607 : double v10;
8608 : double v11;
8609 : double v12;
8610 : double v13;
8611 : double v20;
8612 : double v21;
8613 : double v22;
8614 : double v23;
8615 : double v30;
8616 : double v31;
8617 : double v32;
8618 : double v33;
8619 : double a0;
8620 : double a1;
8621 : double a2;
8622 : double a3;
8623 : double b0;
8624 : double b1;
8625 : double b2;
8626 : double b3;
8627 : ae_int_t idxa0;
8628 : ae_int_t idxa1;
8629 : ae_int_t idxa2;
8630 : ae_int_t idxa3;
8631 : ae_int_t idxb0;
8632 : ae_int_t idxb1;
8633 : ae_int_t idxb2;
8634 : ae_int_t idxb3;
8635 : ae_int_t i0;
8636 : ae_int_t i1;
8637 : ae_int_t ik;
8638 : ae_int_t j0;
8639 : ae_int_t j1;
8640 : ae_int_t jk;
8641 : ae_int_t t;
8642 : ae_int_t offsa;
8643 : ae_int_t offsb;
8644 :
8645 :
8646 0 : ae_assert(ae_fp_neq(alpha,(double)(0)), "RMatrixGEMMK44V00: internal error (Alpha=0)", _state);
8647 :
8648 : /*
8649 : * if matrix size is zero
8650 : */
8651 0 : if( m==0||n==0 )
8652 : {
8653 0 : return;
8654 : }
8655 :
8656 : /*
8657 : * A'*B
8658 : */
8659 0 : i = 0;
8660 0 : while(i<m)
8661 : {
8662 0 : j = 0;
8663 0 : while(j<n)
8664 : {
8665 :
8666 : /*
8667 : * Choose between specialized 4x4 code and general code
8668 : */
8669 0 : if( i+4<=m&&j+4<=n )
8670 : {
8671 :
8672 : /*
8673 : * Specialized 4x4 code for [I..I+3]x[J..J+3] submatrix of C.
8674 : *
8675 : * This submatrix is calculated as sum of K rank-1 products,
8676 : * with operands cached in local variables in order to speed
8677 : * up operations with arrays.
8678 : */
8679 0 : idxa0 = ja+i+0;
8680 0 : idxa1 = ja+i+1;
8681 0 : idxa2 = ja+i+2;
8682 0 : idxa3 = ja+i+3;
8683 0 : offsa = ia;
8684 0 : idxb0 = jb+j+0;
8685 0 : idxb1 = jb+j+1;
8686 0 : idxb2 = jb+j+2;
8687 0 : idxb3 = jb+j+3;
8688 0 : offsb = ib;
8689 0 : v00 = 0.0;
8690 0 : v01 = 0.0;
8691 0 : v02 = 0.0;
8692 0 : v03 = 0.0;
8693 0 : v10 = 0.0;
8694 0 : v11 = 0.0;
8695 0 : v12 = 0.0;
8696 0 : v13 = 0.0;
8697 0 : v20 = 0.0;
8698 0 : v21 = 0.0;
8699 0 : v22 = 0.0;
8700 0 : v23 = 0.0;
8701 0 : v30 = 0.0;
8702 0 : v31 = 0.0;
8703 0 : v32 = 0.0;
8704 0 : v33 = 0.0;
8705 0 : for(t=0; t<=k-1; t++)
8706 : {
8707 0 : a0 = a->ptr.pp_double[offsa][idxa0];
8708 0 : a1 = a->ptr.pp_double[offsa][idxa1];
8709 0 : b0 = b->ptr.pp_double[offsb][idxb0];
8710 0 : b1 = b->ptr.pp_double[offsb][idxb1];
8711 0 : v00 = v00+a0*b0;
8712 0 : v01 = v01+a0*b1;
8713 0 : v10 = v10+a1*b0;
8714 0 : v11 = v11+a1*b1;
8715 0 : a2 = a->ptr.pp_double[offsa][idxa2];
8716 0 : a3 = a->ptr.pp_double[offsa][idxa3];
8717 0 : v20 = v20+a2*b0;
8718 0 : v21 = v21+a2*b1;
8719 0 : v30 = v30+a3*b0;
8720 0 : v31 = v31+a3*b1;
8721 0 : b2 = b->ptr.pp_double[offsb][idxb2];
8722 0 : b3 = b->ptr.pp_double[offsb][idxb3];
8723 0 : v22 = v22+a2*b2;
8724 0 : v23 = v23+a2*b3;
8725 0 : v32 = v32+a3*b2;
8726 0 : v33 = v33+a3*b3;
8727 0 : v02 = v02+a0*b2;
8728 0 : v03 = v03+a0*b3;
8729 0 : v12 = v12+a1*b2;
8730 0 : v13 = v13+a1*b3;
8731 0 : offsa = offsa+1;
8732 0 : offsb = offsb+1;
8733 : }
8734 0 : if( ae_fp_eq(beta,(double)(0)) )
8735 : {
8736 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = alpha*v00;
8737 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = alpha*v01;
8738 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = alpha*v02;
8739 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = alpha*v03;
8740 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = alpha*v10;
8741 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = alpha*v11;
8742 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = alpha*v12;
8743 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = alpha*v13;
8744 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = alpha*v20;
8745 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = alpha*v21;
8746 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = alpha*v22;
8747 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = alpha*v23;
8748 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = alpha*v30;
8749 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = alpha*v31;
8750 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = alpha*v32;
8751 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = alpha*v33;
8752 : }
8753 : else
8754 : {
8755 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = beta*c->ptr.pp_double[ic+i+0][jc+j+0]+alpha*v00;
8756 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = beta*c->ptr.pp_double[ic+i+0][jc+j+1]+alpha*v01;
8757 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = beta*c->ptr.pp_double[ic+i+0][jc+j+2]+alpha*v02;
8758 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = beta*c->ptr.pp_double[ic+i+0][jc+j+3]+alpha*v03;
8759 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = beta*c->ptr.pp_double[ic+i+1][jc+j+0]+alpha*v10;
8760 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = beta*c->ptr.pp_double[ic+i+1][jc+j+1]+alpha*v11;
8761 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = beta*c->ptr.pp_double[ic+i+1][jc+j+2]+alpha*v12;
8762 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = beta*c->ptr.pp_double[ic+i+1][jc+j+3]+alpha*v13;
8763 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = beta*c->ptr.pp_double[ic+i+2][jc+j+0]+alpha*v20;
8764 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = beta*c->ptr.pp_double[ic+i+2][jc+j+1]+alpha*v21;
8765 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = beta*c->ptr.pp_double[ic+i+2][jc+j+2]+alpha*v22;
8766 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = beta*c->ptr.pp_double[ic+i+2][jc+j+3]+alpha*v23;
8767 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = beta*c->ptr.pp_double[ic+i+3][jc+j+0]+alpha*v30;
8768 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = beta*c->ptr.pp_double[ic+i+3][jc+j+1]+alpha*v31;
8769 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = beta*c->ptr.pp_double[ic+i+3][jc+j+2]+alpha*v32;
8770 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = beta*c->ptr.pp_double[ic+i+3][jc+j+3]+alpha*v33;
8771 : }
8772 : }
8773 : else
8774 : {
8775 :
8776 : /*
8777 : * Determine submatrix [I0..I1]x[J0..J1] to process
8778 : */
8779 0 : i0 = i;
8780 0 : i1 = ae_minint(i+3, m-1, _state);
8781 0 : j0 = j;
8782 0 : j1 = ae_minint(j+3, n-1, _state);
8783 :
8784 : /*
8785 : * Process submatrix
8786 : */
8787 0 : for(ik=i0; ik<=i1; ik++)
8788 : {
8789 0 : for(jk=j0; jk<=j1; jk++)
8790 : {
8791 0 : if( k==0||ae_fp_eq(alpha,(double)(0)) )
8792 : {
8793 0 : v = (double)(0);
8794 : }
8795 : else
8796 : {
8797 0 : v = 0.0;
8798 0 : v = ae_v_dotproduct(&a->ptr.pp_double[ia][ja+ik], a->stride, &b->ptr.pp_double[ib][jb+jk], b->stride, ae_v_len(ia,ia+k-1));
8799 : }
8800 0 : if( ae_fp_eq(beta,(double)(0)) )
8801 : {
8802 0 : c->ptr.pp_double[ic+ik][jc+jk] = alpha*v;
8803 : }
8804 : else
8805 : {
8806 0 : c->ptr.pp_double[ic+ik][jc+jk] = beta*c->ptr.pp_double[ic+ik][jc+jk]+alpha*v;
8807 : }
8808 : }
8809 : }
8810 : }
8811 0 : j = j+4;
8812 : }
8813 0 : i = i+4;
8814 : }
8815 : }
8816 :
8817 :
8818 : /*************************************************************************
8819 : RMatrixGEMM kernel, basecase code for RMatrixGEMM, specialized for sitation
8820 : with OpTypeA=1 and OpTypeB=1.
8821 :
8822 : Additional info:
8823 : * this function requires that Alpha<>0 (assertion is thrown otherwise)
8824 :
8825 : INPUT PARAMETERS
8826 : M - matrix size, M>0
8827 : N - matrix size, N>0
8828 : K - matrix size, K>0
8829 : Alpha - coefficient
8830 : A - matrix
8831 : IA - submatrix offset
8832 : JA - submatrix offset
8833 : B - matrix
8834 : IB - submatrix offset
8835 : JB - submatrix offset
8836 : Beta - coefficient
8837 : C - PREALLOCATED output matrix
8838 : IC - submatrix offset
8839 : JC - submatrix offset
8840 :
8841 : -- ALGLIB routine --
8842 : 27.03.2013
8843 : Bochkanov Sergey
8844 : *************************************************************************/
8845 0 : void rmatrixgemmk44v11(ae_int_t m,
8846 : ae_int_t n,
8847 : ae_int_t k,
8848 : double alpha,
8849 : /* Real */ ae_matrix* a,
8850 : ae_int_t ia,
8851 : ae_int_t ja,
8852 : /* Real */ ae_matrix* b,
8853 : ae_int_t ib,
8854 : ae_int_t jb,
8855 : double beta,
8856 : /* Real */ ae_matrix* c,
8857 : ae_int_t ic,
8858 : ae_int_t jc,
8859 : ae_state *_state)
8860 : {
8861 : ae_int_t i;
8862 : ae_int_t j;
8863 : double v;
8864 : double v00;
8865 : double v01;
8866 : double v02;
8867 : double v03;
8868 : double v10;
8869 : double v11;
8870 : double v12;
8871 : double v13;
8872 : double v20;
8873 : double v21;
8874 : double v22;
8875 : double v23;
8876 : double v30;
8877 : double v31;
8878 : double v32;
8879 : double v33;
8880 : double a0;
8881 : double a1;
8882 : double a2;
8883 : double a3;
8884 : double b0;
8885 : double b1;
8886 : double b2;
8887 : double b3;
8888 : ae_int_t idxa0;
8889 : ae_int_t idxa1;
8890 : ae_int_t idxa2;
8891 : ae_int_t idxa3;
8892 : ae_int_t idxb0;
8893 : ae_int_t idxb1;
8894 : ae_int_t idxb2;
8895 : ae_int_t idxb3;
8896 : ae_int_t i0;
8897 : ae_int_t i1;
8898 : ae_int_t ik;
8899 : ae_int_t j0;
8900 : ae_int_t j1;
8901 : ae_int_t jk;
8902 : ae_int_t t;
8903 : ae_int_t offsa;
8904 : ae_int_t offsb;
8905 :
8906 :
8907 0 : ae_assert(ae_fp_neq(alpha,(double)(0)), "RMatrixGEMMK44V00: internal error (Alpha=0)", _state);
8908 :
8909 : /*
8910 : * if matrix size is zero
8911 : */
8912 0 : if( m==0||n==0 )
8913 : {
8914 0 : return;
8915 : }
8916 :
8917 : /*
8918 : * A'*B'
8919 : */
8920 0 : i = 0;
8921 0 : while(i<m)
8922 : {
8923 0 : j = 0;
8924 0 : while(j<n)
8925 : {
8926 :
8927 : /*
8928 : * Choose between specialized 4x4 code and general code
8929 : */
8930 0 : if( i+4<=m&&j+4<=n )
8931 : {
8932 :
8933 : /*
8934 : * Specialized 4x4 code for [I..I+3]x[J..J+3] submatrix of C.
8935 : *
8936 : * This submatrix is calculated as sum of K rank-1 products,
8937 : * with operands cached in local variables in order to speed
8938 : * up operations with arrays.
8939 : */
8940 0 : idxa0 = ja+i+0;
8941 0 : idxa1 = ja+i+1;
8942 0 : idxa2 = ja+i+2;
8943 0 : idxa3 = ja+i+3;
8944 0 : offsa = ia;
8945 0 : idxb0 = ib+j+0;
8946 0 : idxb1 = ib+j+1;
8947 0 : idxb2 = ib+j+2;
8948 0 : idxb3 = ib+j+3;
8949 0 : offsb = jb;
8950 0 : v00 = 0.0;
8951 0 : v01 = 0.0;
8952 0 : v02 = 0.0;
8953 0 : v03 = 0.0;
8954 0 : v10 = 0.0;
8955 0 : v11 = 0.0;
8956 0 : v12 = 0.0;
8957 0 : v13 = 0.0;
8958 0 : v20 = 0.0;
8959 0 : v21 = 0.0;
8960 0 : v22 = 0.0;
8961 0 : v23 = 0.0;
8962 0 : v30 = 0.0;
8963 0 : v31 = 0.0;
8964 0 : v32 = 0.0;
8965 0 : v33 = 0.0;
8966 0 : for(t=0; t<=k-1; t++)
8967 : {
8968 0 : a0 = a->ptr.pp_double[offsa][idxa0];
8969 0 : a1 = a->ptr.pp_double[offsa][idxa1];
8970 0 : b0 = b->ptr.pp_double[idxb0][offsb];
8971 0 : b1 = b->ptr.pp_double[idxb1][offsb];
8972 0 : v00 = v00+a0*b0;
8973 0 : v01 = v01+a0*b1;
8974 0 : v10 = v10+a1*b0;
8975 0 : v11 = v11+a1*b1;
8976 0 : a2 = a->ptr.pp_double[offsa][idxa2];
8977 0 : a3 = a->ptr.pp_double[offsa][idxa3];
8978 0 : v20 = v20+a2*b0;
8979 0 : v21 = v21+a2*b1;
8980 0 : v30 = v30+a3*b0;
8981 0 : v31 = v31+a3*b1;
8982 0 : b2 = b->ptr.pp_double[idxb2][offsb];
8983 0 : b3 = b->ptr.pp_double[idxb3][offsb];
8984 0 : v22 = v22+a2*b2;
8985 0 : v23 = v23+a2*b3;
8986 0 : v32 = v32+a3*b2;
8987 0 : v33 = v33+a3*b3;
8988 0 : v02 = v02+a0*b2;
8989 0 : v03 = v03+a0*b3;
8990 0 : v12 = v12+a1*b2;
8991 0 : v13 = v13+a1*b3;
8992 0 : offsa = offsa+1;
8993 0 : offsb = offsb+1;
8994 : }
8995 0 : if( ae_fp_eq(beta,(double)(0)) )
8996 : {
8997 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = alpha*v00;
8998 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = alpha*v01;
8999 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = alpha*v02;
9000 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = alpha*v03;
9001 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = alpha*v10;
9002 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = alpha*v11;
9003 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = alpha*v12;
9004 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = alpha*v13;
9005 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = alpha*v20;
9006 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = alpha*v21;
9007 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = alpha*v22;
9008 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = alpha*v23;
9009 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = alpha*v30;
9010 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = alpha*v31;
9011 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = alpha*v32;
9012 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = alpha*v33;
9013 : }
9014 : else
9015 : {
9016 0 : c->ptr.pp_double[ic+i+0][jc+j+0] = beta*c->ptr.pp_double[ic+i+0][jc+j+0]+alpha*v00;
9017 0 : c->ptr.pp_double[ic+i+0][jc+j+1] = beta*c->ptr.pp_double[ic+i+0][jc+j+1]+alpha*v01;
9018 0 : c->ptr.pp_double[ic+i+0][jc+j+2] = beta*c->ptr.pp_double[ic+i+0][jc+j+2]+alpha*v02;
9019 0 : c->ptr.pp_double[ic+i+0][jc+j+3] = beta*c->ptr.pp_double[ic+i+0][jc+j+3]+alpha*v03;
9020 0 : c->ptr.pp_double[ic+i+1][jc+j+0] = beta*c->ptr.pp_double[ic+i+1][jc+j+0]+alpha*v10;
9021 0 : c->ptr.pp_double[ic+i+1][jc+j+1] = beta*c->ptr.pp_double[ic+i+1][jc+j+1]+alpha*v11;
9022 0 : c->ptr.pp_double[ic+i+1][jc+j+2] = beta*c->ptr.pp_double[ic+i+1][jc+j+2]+alpha*v12;
9023 0 : c->ptr.pp_double[ic+i+1][jc+j+3] = beta*c->ptr.pp_double[ic+i+1][jc+j+3]+alpha*v13;
9024 0 : c->ptr.pp_double[ic+i+2][jc+j+0] = beta*c->ptr.pp_double[ic+i+2][jc+j+0]+alpha*v20;
9025 0 : c->ptr.pp_double[ic+i+2][jc+j+1] = beta*c->ptr.pp_double[ic+i+2][jc+j+1]+alpha*v21;
9026 0 : c->ptr.pp_double[ic+i+2][jc+j+2] = beta*c->ptr.pp_double[ic+i+2][jc+j+2]+alpha*v22;
9027 0 : c->ptr.pp_double[ic+i+2][jc+j+3] = beta*c->ptr.pp_double[ic+i+2][jc+j+3]+alpha*v23;
9028 0 : c->ptr.pp_double[ic+i+3][jc+j+0] = beta*c->ptr.pp_double[ic+i+3][jc+j+0]+alpha*v30;
9029 0 : c->ptr.pp_double[ic+i+3][jc+j+1] = beta*c->ptr.pp_double[ic+i+3][jc+j+1]+alpha*v31;
9030 0 : c->ptr.pp_double[ic+i+3][jc+j+2] = beta*c->ptr.pp_double[ic+i+3][jc+j+2]+alpha*v32;
9031 0 : c->ptr.pp_double[ic+i+3][jc+j+3] = beta*c->ptr.pp_double[ic+i+3][jc+j+3]+alpha*v33;
9032 : }
9033 : }
9034 : else
9035 : {
9036 :
9037 : /*
9038 : * Determine submatrix [I0..I1]x[J0..J1] to process
9039 : */
9040 0 : i0 = i;
9041 0 : i1 = ae_minint(i+3, m-1, _state);
9042 0 : j0 = j;
9043 0 : j1 = ae_minint(j+3, n-1, _state);
9044 :
9045 : /*
9046 : * Process submatrix
9047 : */
9048 0 : for(ik=i0; ik<=i1; ik++)
9049 : {
9050 0 : for(jk=j0; jk<=j1; jk++)
9051 : {
9052 0 : if( k==0||ae_fp_eq(alpha,(double)(0)) )
9053 : {
9054 0 : v = (double)(0);
9055 : }
9056 : else
9057 : {
9058 0 : v = 0.0;
9059 0 : v = ae_v_dotproduct(&a->ptr.pp_double[ia][ja+ik], a->stride, &b->ptr.pp_double[ib+jk][jb], 1, ae_v_len(ia,ia+k-1));
9060 : }
9061 0 : if( ae_fp_eq(beta,(double)(0)) )
9062 : {
9063 0 : c->ptr.pp_double[ic+ik][jc+jk] = alpha*v;
9064 : }
9065 : else
9066 : {
9067 0 : c->ptr.pp_double[ic+ik][jc+jk] = beta*c->ptr.pp_double[ic+ik][jc+jk]+alpha*v;
9068 : }
9069 : }
9070 : }
9071 : }
9072 0 : j = j+4;
9073 : }
9074 0 : i = i+4;
9075 : }
9076 : }
9077 :
9078 :
9079 : #endif
9080 : #if defined(AE_COMPILE_ABLASMKL) || !defined(AE_PARTIAL_BUILD)
9081 :
9082 :
9083 : /*************************************************************************
9084 : MKL-based kernel
9085 :
9086 : -- ALGLIB routine --
9087 : 12.10.2017
9088 : Bochkanov Sergey
9089 : *************************************************************************/
9090 0 : ae_bool rmatrixgermkl(ae_int_t m,
9091 : ae_int_t n,
9092 : /* Real */ ae_matrix* a,
9093 : ae_int_t ia,
9094 : ae_int_t ja,
9095 : double alpha,
9096 : /* Real */ ae_vector* u,
9097 : ae_int_t iu,
9098 : /* Real */ ae_vector* v,
9099 : ae_int_t iv,
9100 : ae_state *_state)
9101 : {
9102 : #ifndef ALGLIB_INTERCEPTS_MKL
9103 : ae_bool result;
9104 :
9105 :
9106 0 : result = ae_false;
9107 0 : return result;
9108 : #else
9109 : return _ialglib_i_rmatrixgermkl(m, n, a, ia, ja, alpha, u, iu, v, iv);
9110 : #endif
9111 : }
9112 :
9113 :
9114 : /*************************************************************************
9115 : MKL-based kernel
9116 :
9117 : -- ALGLIB routine --
9118 : 12.10.2017
9119 : Bochkanov Sergey
9120 : *************************************************************************/
9121 0 : ae_bool cmatrixrank1mkl(ae_int_t m,
9122 : ae_int_t n,
9123 : /* Complex */ ae_matrix* a,
9124 : ae_int_t ia,
9125 : ae_int_t ja,
9126 : /* Complex */ ae_vector* u,
9127 : ae_int_t iu,
9128 : /* Complex */ ae_vector* v,
9129 : ae_int_t iv,
9130 : ae_state *_state)
9131 : {
9132 : #ifndef ALGLIB_INTERCEPTS_MKL
9133 : ae_bool result;
9134 :
9135 :
9136 0 : result = ae_false;
9137 0 : return result;
9138 : #else
9139 : return _ialglib_i_cmatrixrank1mkl(m, n, a, ia, ja, u, iu, v, iv);
9140 : #endif
9141 : }
9142 :
9143 :
9144 : /*************************************************************************
9145 : MKL-based kernel
9146 :
9147 : -- ALGLIB routine --
9148 : 12.10.2017
9149 : Bochkanov Sergey
9150 : *************************************************************************/
9151 0 : ae_bool rmatrixrank1mkl(ae_int_t m,
9152 : ae_int_t n,
9153 : /* Real */ ae_matrix* a,
9154 : ae_int_t ia,
9155 : ae_int_t ja,
9156 : /* Real */ ae_vector* u,
9157 : ae_int_t iu,
9158 : /* Real */ ae_vector* v,
9159 : ae_int_t iv,
9160 : ae_state *_state)
9161 : {
9162 : #ifndef ALGLIB_INTERCEPTS_MKL
9163 : ae_bool result;
9164 :
9165 :
9166 0 : result = ae_false;
9167 0 : return result;
9168 : #else
9169 : return _ialglib_i_rmatrixrank1mkl(m, n, a, ia, ja, u, iu, v, iv);
9170 : #endif
9171 : }
9172 :
9173 :
9174 : /*************************************************************************
9175 : MKL-based kernel
9176 :
9177 : -- ALGLIB routine --
9178 : 12.10.2017
9179 : Bochkanov Sergey
9180 : *************************************************************************/
9181 0 : ae_bool cmatrixmvmkl(ae_int_t m,
9182 : ae_int_t n,
9183 : /* Complex */ ae_matrix* a,
9184 : ae_int_t ia,
9185 : ae_int_t ja,
9186 : ae_int_t opa,
9187 : /* Complex */ ae_vector* x,
9188 : ae_int_t ix,
9189 : /* Complex */ ae_vector* y,
9190 : ae_int_t iy,
9191 : ae_state *_state)
9192 : {
9193 : #ifndef ALGLIB_INTERCEPTS_MKL
9194 : ae_bool result;
9195 :
9196 :
9197 0 : result = ae_false;
9198 0 : return result;
9199 : #else
9200 : return _ialglib_i_cmatrixmvmkl(m, n, a, ia, ja, opa, x, ix, y, iy);
9201 : #endif
9202 : }
9203 :
9204 :
9205 : /*************************************************************************
9206 : MKL-based kernel
9207 :
9208 : -- ALGLIB routine --
9209 : 12.10.2017
9210 : Bochkanov Sergey
9211 : *************************************************************************/
9212 0 : ae_bool rmatrixmvmkl(ae_int_t m,
9213 : ae_int_t n,
9214 : /* Real */ ae_matrix* a,
9215 : ae_int_t ia,
9216 : ae_int_t ja,
9217 : ae_int_t opa,
9218 : /* Real */ ae_vector* x,
9219 : ae_int_t ix,
9220 : /* Real */ ae_vector* y,
9221 : ae_int_t iy,
9222 : ae_state *_state)
9223 : {
9224 : #ifndef ALGLIB_INTERCEPTS_MKL
9225 : ae_bool result;
9226 :
9227 :
9228 0 : result = ae_false;
9229 0 : return result;
9230 : #else
9231 : return _ialglib_i_rmatrixmvmkl(m, n, a, ia, ja, opa, x, ix, y, iy);
9232 : #endif
9233 : }
9234 :
9235 :
9236 : /*************************************************************************
9237 : MKL-based kernel
9238 :
9239 : -- ALGLIB routine --
9240 : 12.10.2017
9241 : Bochkanov Sergey
9242 : *************************************************************************/
9243 0 : ae_bool rmatrixgemvmkl(ae_int_t m,
9244 : ae_int_t n,
9245 : double alpha,
9246 : /* Real */ ae_matrix* a,
9247 : ae_int_t ia,
9248 : ae_int_t ja,
9249 : ae_int_t opa,
9250 : /* Real */ ae_vector* x,
9251 : ae_int_t ix,
9252 : double beta,
9253 : /* Real */ ae_vector* y,
9254 : ae_int_t iy,
9255 : ae_state *_state)
9256 : {
9257 : #ifndef ALGLIB_INTERCEPTS_MKL
9258 : ae_bool result;
9259 :
9260 :
9261 0 : result = ae_false;
9262 0 : return result;
9263 : #else
9264 : return _ialglib_i_rmatrixgemvmkl(m, n, alpha, a, ia, ja, opa, x, ix, beta, y, iy);
9265 : #endif
9266 : }
9267 :
9268 :
9269 : /*************************************************************************
9270 : MKL-based kernel
9271 :
9272 : -- ALGLIB routine --
9273 : 12.10.2017
9274 : Bochkanov Sergey
9275 : *************************************************************************/
9276 0 : ae_bool rmatrixtrsvmkl(ae_int_t n,
9277 : /* Real */ ae_matrix* a,
9278 : ae_int_t ia,
9279 : ae_int_t ja,
9280 : ae_bool isupper,
9281 : ae_bool isunit,
9282 : ae_int_t optype,
9283 : /* Real */ ae_vector* x,
9284 : ae_int_t ix,
9285 : ae_state *_state)
9286 : {
9287 : #ifndef ALGLIB_INTERCEPTS_MKL
9288 : ae_bool result;
9289 :
9290 :
9291 0 : result = ae_false;
9292 0 : return result;
9293 : #else
9294 : return _ialglib_i_rmatrixtrsvmkl(n, a, ia, ja, isupper, isunit, optype, x, ix);
9295 : #endif
9296 : }
9297 :
9298 :
9299 : /*************************************************************************
9300 : MKL-based kernel
9301 :
9302 : -- ALGLIB routine --
9303 : 01.10.2013
9304 : Bochkanov Sergey
9305 : *************************************************************************/
9306 0 : ae_bool rmatrixsyrkmkl(ae_int_t n,
9307 : ae_int_t k,
9308 : double alpha,
9309 : /* Real */ ae_matrix* a,
9310 : ae_int_t ia,
9311 : ae_int_t ja,
9312 : ae_int_t optypea,
9313 : double beta,
9314 : /* Real */ ae_matrix* c,
9315 : ae_int_t ic,
9316 : ae_int_t jc,
9317 : ae_bool isupper,
9318 : ae_state *_state)
9319 : {
9320 : #ifndef ALGLIB_INTERCEPTS_MKL
9321 : ae_bool result;
9322 :
9323 :
9324 0 : result = ae_false;
9325 0 : return result;
9326 : #else
9327 : return _ialglib_i_rmatrixsyrkmkl(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper);
9328 : #endif
9329 : }
9330 :
9331 :
9332 : /*************************************************************************
9333 : MKL-based kernel
9334 :
9335 : -- ALGLIB routine --
9336 : 01.10.2013
9337 : Bochkanov Sergey
9338 : *************************************************************************/
9339 0 : ae_bool cmatrixherkmkl(ae_int_t n,
9340 : ae_int_t k,
9341 : double alpha,
9342 : /* Complex */ ae_matrix* a,
9343 : ae_int_t ia,
9344 : ae_int_t ja,
9345 : ae_int_t optypea,
9346 : double beta,
9347 : /* Complex */ ae_matrix* c,
9348 : ae_int_t ic,
9349 : ae_int_t jc,
9350 : ae_bool isupper,
9351 : ae_state *_state)
9352 : {
9353 : #ifndef ALGLIB_INTERCEPTS_MKL
9354 : ae_bool result;
9355 :
9356 :
9357 0 : result = ae_false;
9358 0 : return result;
9359 : #else
9360 : return _ialglib_i_cmatrixherkmkl(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper);
9361 : #endif
9362 : }
9363 :
9364 :
9365 : /*************************************************************************
9366 : MKL-based kernel
9367 :
9368 : -- ALGLIB routine --
9369 : 01.10.2013
9370 : Bochkanov Sergey
9371 : *************************************************************************/
9372 0 : ae_bool rmatrixgemmmkl(ae_int_t m,
9373 : ae_int_t n,
9374 : ae_int_t k,
9375 : double alpha,
9376 : /* Real */ ae_matrix* a,
9377 : ae_int_t ia,
9378 : ae_int_t ja,
9379 : ae_int_t optypea,
9380 : /* Real */ ae_matrix* b,
9381 : ae_int_t ib,
9382 : ae_int_t jb,
9383 : ae_int_t optypeb,
9384 : double beta,
9385 : /* Real */ ae_matrix* c,
9386 : ae_int_t ic,
9387 : ae_int_t jc,
9388 : ae_state *_state)
9389 : {
9390 : #ifndef ALGLIB_INTERCEPTS_MKL
9391 : ae_bool result;
9392 :
9393 :
9394 0 : result = ae_false;
9395 0 : return result;
9396 : #else
9397 : return _ialglib_i_rmatrixgemmmkl(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc);
9398 : #endif
9399 : }
9400 :
9401 :
9402 : /*************************************************************************
9403 : MKL-based kernel
9404 :
9405 : -- ALGLIB routine --
9406 : 01.10.2017
9407 : Bochkanov Sergey
9408 : *************************************************************************/
9409 0 : ae_bool rmatrixsymvmkl(ae_int_t n,
9410 : double alpha,
9411 : /* Real */ ae_matrix* a,
9412 : ae_int_t ia,
9413 : ae_int_t ja,
9414 : ae_bool isupper,
9415 : /* Real */ ae_vector* x,
9416 : ae_int_t ix,
9417 : double beta,
9418 : /* Real */ ae_vector* y,
9419 : ae_int_t iy,
9420 : ae_state *_state)
9421 : {
9422 : #ifndef ALGLIB_INTERCEPTS_MKL
9423 : ae_bool result;
9424 :
9425 :
9426 0 : result = ae_false;
9427 0 : return result;
9428 : #else
9429 : return _ialglib_i_rmatrixsymvmkl(n, alpha, a, ia, ja, isupper, x, ix, beta, y, iy);
9430 : #endif
9431 : }
9432 :
9433 :
9434 : /*************************************************************************
9435 : MKL-based kernel
9436 :
9437 : -- ALGLIB routine --
9438 : 16.10.2014
9439 : Bochkanov Sergey
9440 : *************************************************************************/
9441 0 : ae_bool cmatrixgemmmkl(ae_int_t m,
9442 : ae_int_t n,
9443 : ae_int_t k,
9444 : ae_complex alpha,
9445 : /* Complex */ ae_matrix* a,
9446 : ae_int_t ia,
9447 : ae_int_t ja,
9448 : ae_int_t optypea,
9449 : /* Complex */ ae_matrix* b,
9450 : ae_int_t ib,
9451 : ae_int_t jb,
9452 : ae_int_t optypeb,
9453 : ae_complex beta,
9454 : /* Complex */ ae_matrix* c,
9455 : ae_int_t ic,
9456 : ae_int_t jc,
9457 : ae_state *_state)
9458 : {
9459 : #ifndef ALGLIB_INTERCEPTS_MKL
9460 : ae_bool result;
9461 :
9462 :
9463 0 : result = ae_false;
9464 0 : return result;
9465 : #else
9466 : return _ialglib_i_cmatrixgemmmkl(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc);
9467 : #endif
9468 : }
9469 :
9470 :
9471 : /*************************************************************************
9472 : MKL-based kernel
9473 :
9474 : -- ALGLIB routine --
9475 : 16.10.2014
9476 : Bochkanov Sergey
9477 : *************************************************************************/
9478 0 : ae_bool cmatrixlefttrsmmkl(ae_int_t m,
9479 : ae_int_t n,
9480 : /* Complex */ ae_matrix* a,
9481 : ae_int_t i1,
9482 : ae_int_t j1,
9483 : ae_bool isupper,
9484 : ae_bool isunit,
9485 : ae_int_t optype,
9486 : /* Complex */ ae_matrix* x,
9487 : ae_int_t i2,
9488 : ae_int_t j2,
9489 : ae_state *_state)
9490 : {
9491 : #ifndef ALGLIB_INTERCEPTS_MKL
9492 : ae_bool result;
9493 :
9494 :
9495 0 : result = ae_false;
9496 0 : return result;
9497 : #else
9498 : return _ialglib_i_cmatrixlefttrsmmkl(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
9499 : #endif
9500 : }
9501 :
9502 :
9503 : /*************************************************************************
9504 : MKL-based kernel
9505 :
9506 : -- ALGLIB routine --
9507 : 16.10.2014
9508 : Bochkanov Sergey
9509 : *************************************************************************/
9510 0 : ae_bool cmatrixrighttrsmmkl(ae_int_t m,
9511 : ae_int_t n,
9512 : /* Complex */ ae_matrix* a,
9513 : ae_int_t i1,
9514 : ae_int_t j1,
9515 : ae_bool isupper,
9516 : ae_bool isunit,
9517 : ae_int_t optype,
9518 : /* Complex */ ae_matrix* x,
9519 : ae_int_t i2,
9520 : ae_int_t j2,
9521 : ae_state *_state)
9522 : {
9523 : #ifndef ALGLIB_INTERCEPTS_MKL
9524 : ae_bool result;
9525 :
9526 :
9527 0 : result = ae_false;
9528 0 : return result;
9529 : #else
9530 : return _ialglib_i_cmatrixrighttrsmmkl(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
9531 : #endif
9532 : }
9533 :
9534 :
9535 : /*************************************************************************
9536 : MKL-based kernel
9537 :
9538 : -- ALGLIB routine --
9539 : 16.10.2014
9540 : Bochkanov Sergey
9541 : *************************************************************************/
9542 0 : ae_bool rmatrixlefttrsmmkl(ae_int_t m,
9543 : ae_int_t n,
9544 : /* Real */ ae_matrix* a,
9545 : ae_int_t i1,
9546 : ae_int_t j1,
9547 : ae_bool isupper,
9548 : ae_bool isunit,
9549 : ae_int_t optype,
9550 : /* Real */ ae_matrix* x,
9551 : ae_int_t i2,
9552 : ae_int_t j2,
9553 : ae_state *_state)
9554 : {
9555 : #ifndef ALGLIB_INTERCEPTS_MKL
9556 : ae_bool result;
9557 :
9558 :
9559 0 : result = ae_false;
9560 0 : return result;
9561 : #else
9562 : return _ialglib_i_rmatrixlefttrsmmkl(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
9563 : #endif
9564 : }
9565 :
9566 :
9567 : /*************************************************************************
9568 : MKL-based kernel
9569 :
9570 : -- ALGLIB routine --
9571 : 16.10.2014
9572 : Bochkanov Sergey
9573 : *************************************************************************/
9574 0 : ae_bool rmatrixrighttrsmmkl(ae_int_t m,
9575 : ae_int_t n,
9576 : /* Real */ ae_matrix* a,
9577 : ae_int_t i1,
9578 : ae_int_t j1,
9579 : ae_bool isupper,
9580 : ae_bool isunit,
9581 : ae_int_t optype,
9582 : /* Real */ ae_matrix* x,
9583 : ae_int_t i2,
9584 : ae_int_t j2,
9585 : ae_state *_state)
9586 : {
9587 : #ifndef ALGLIB_INTERCEPTS_MKL
9588 : ae_bool result;
9589 :
9590 :
9591 0 : result = ae_false;
9592 0 : return result;
9593 : #else
9594 : return _ialglib_i_rmatrixrighttrsmmkl(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2);
9595 : #endif
9596 : }
9597 :
9598 :
9599 : /*************************************************************************
9600 : MKL-based kernel.
9601 :
9602 : NOTE:
9603 :
9604 : if function returned False, CholResult is NOT modified. Not ever referenced!
9605 : if function returned True, CholResult is set to status of Cholesky decomposition
9606 : (True on succeess).
9607 :
9608 : -- ALGLIB routine --
9609 : 16.10.2014
9610 : Bochkanov Sergey
9611 : *************************************************************************/
9612 0 : ae_bool spdmatrixcholeskymkl(/* Real */ ae_matrix* a,
9613 : ae_int_t offs,
9614 : ae_int_t n,
9615 : ae_bool isupper,
9616 : ae_bool* cholresult,
9617 : ae_state *_state)
9618 : {
9619 : #ifndef ALGLIB_INTERCEPTS_MKL
9620 : ae_bool result;
9621 :
9622 :
9623 0 : result = ae_false;
9624 0 : return result;
9625 : #else
9626 : return _ialglib_i_spdmatrixcholeskymkl(a, offs, n, isupper, cholresult);
9627 : #endif
9628 : }
9629 :
9630 :
9631 : /*************************************************************************
9632 : MKL-based kernel.
9633 :
9634 : -- ALGLIB routine --
9635 : 20.10.2014
9636 : Bochkanov Sergey
9637 : *************************************************************************/
9638 0 : ae_bool rmatrixplumkl(/* Real */ ae_matrix* a,
9639 : ae_int_t offs,
9640 : ae_int_t m,
9641 : ae_int_t n,
9642 : /* Integer */ ae_vector* pivots,
9643 : ae_state *_state)
9644 : {
9645 : #ifndef ALGLIB_INTERCEPTS_MKL
9646 : ae_bool result;
9647 :
9648 :
9649 0 : result = ae_false;
9650 0 : return result;
9651 : #else
9652 : return _ialglib_i_rmatrixplumkl(a, offs, m, n, pivots);
9653 : #endif
9654 : }
9655 :
9656 :
9657 : /*************************************************************************
9658 : MKL-based kernel.
9659 :
9660 : NOTE: this function needs preallocated output/temporary arrays.
9661 : D and E must be at least max(M,N)-wide.
9662 :
9663 : -- ALGLIB routine --
9664 : 20.10.2014
9665 : Bochkanov Sergey
9666 : *************************************************************************/
9667 0 : ae_bool rmatrixbdmkl(/* Real */ ae_matrix* a,
9668 : ae_int_t m,
9669 : ae_int_t n,
9670 : /* Real */ ae_vector* d,
9671 : /* Real */ ae_vector* e,
9672 : /* Real */ ae_vector* tauq,
9673 : /* Real */ ae_vector* taup,
9674 : ae_state *_state)
9675 : {
9676 : #ifndef ALGLIB_INTERCEPTS_MKL
9677 : ae_bool result;
9678 :
9679 :
9680 0 : result = ae_false;
9681 0 : return result;
9682 : #else
9683 : return _ialglib_i_rmatrixbdmkl(a, m, n, d, e, tauq, taup);
9684 : #endif
9685 : }
9686 :
9687 :
9688 : /*************************************************************************
9689 : MKL-based kernel.
9690 :
9691 : If ByQ is True, TauP is not used (can be empty array).
9692 : If ByQ is False, TauQ is not used (can be empty array).
9693 :
9694 : -- ALGLIB routine --
9695 : 20.10.2014
9696 : Bochkanov Sergey
9697 : *************************************************************************/
9698 0 : ae_bool rmatrixbdmultiplybymkl(/* Real */ ae_matrix* qp,
9699 : ae_int_t m,
9700 : ae_int_t n,
9701 : /* Real */ ae_vector* tauq,
9702 : /* Real */ ae_vector* taup,
9703 : /* Real */ ae_matrix* z,
9704 : ae_int_t zrows,
9705 : ae_int_t zcolumns,
9706 : ae_bool byq,
9707 : ae_bool fromtheright,
9708 : ae_bool dotranspose,
9709 : ae_state *_state)
9710 : {
9711 : #ifndef ALGLIB_INTERCEPTS_MKL
9712 : ae_bool result;
9713 :
9714 :
9715 0 : result = ae_false;
9716 0 : return result;
9717 : #else
9718 : return _ialglib_i_rmatrixbdmultiplybymkl(qp, m, n, tauq, taup, z, zrows, zcolumns, byq, fromtheright, dotranspose);
9719 : #endif
9720 : }
9721 :
9722 :
9723 : /*************************************************************************
9724 : MKL-based kernel.
9725 :
9726 : NOTE: Tau must be preallocated array with at least N-1 elements.
9727 :
9728 : -- ALGLIB routine --
9729 : 20.10.2014
9730 : Bochkanov Sergey
9731 : *************************************************************************/
9732 0 : ae_bool rmatrixhessenbergmkl(/* Real */ ae_matrix* a,
9733 : ae_int_t n,
9734 : /* Real */ ae_vector* tau,
9735 : ae_state *_state)
9736 : {
9737 : #ifndef ALGLIB_INTERCEPTS_MKL
9738 : ae_bool result;
9739 :
9740 :
9741 0 : result = ae_false;
9742 0 : return result;
9743 : #else
9744 : return _ialglib_i_rmatrixhessenbergmkl(a, n, tau);
9745 : #endif
9746 : }
9747 :
9748 :
9749 : /*************************************************************************
9750 : MKL-based kernel.
9751 :
9752 : NOTE: Q must be preallocated N*N array
9753 :
9754 : -- ALGLIB routine --
9755 : 20.10.2014
9756 : Bochkanov Sergey
9757 : *************************************************************************/
9758 0 : ae_bool rmatrixhessenbergunpackqmkl(/* Real */ ae_matrix* a,
9759 : ae_int_t n,
9760 : /* Real */ ae_vector* tau,
9761 : /* Real */ ae_matrix* q,
9762 : ae_state *_state)
9763 : {
9764 : #ifndef ALGLIB_INTERCEPTS_MKL
9765 : ae_bool result;
9766 :
9767 :
9768 0 : result = ae_false;
9769 0 : return result;
9770 : #else
9771 : return _ialglib_i_rmatrixhessenbergunpackqmkl(a, n, tau, q);
9772 : #endif
9773 : }
9774 :
9775 :
9776 : /*************************************************************************
9777 : MKL-based kernel.
9778 :
9779 : NOTE: Tau, D, E must be preallocated arrays;
9780 : length(E)=length(Tau)=N-1 (or larger)
9781 : length(D)=N (or larger)
9782 :
9783 : -- ALGLIB routine --
9784 : 20.10.2014
9785 : Bochkanov Sergey
9786 : *************************************************************************/
9787 0 : ae_bool smatrixtdmkl(/* Real */ ae_matrix* a,
9788 : ae_int_t n,
9789 : ae_bool isupper,
9790 : /* Real */ ae_vector* tau,
9791 : /* Real */ ae_vector* d,
9792 : /* Real */ ae_vector* e,
9793 : ae_state *_state)
9794 : {
9795 : #ifndef ALGLIB_INTERCEPTS_MKL
9796 : ae_bool result;
9797 :
9798 :
9799 0 : result = ae_false;
9800 0 : return result;
9801 : #else
9802 : return _ialglib_i_smatrixtdmkl(a, n, isupper, tau, d, e);
9803 : #endif
9804 : }
9805 :
9806 :
9807 : /*************************************************************************
9808 : MKL-based kernel.
9809 :
9810 : NOTE: Q must be preallocated N*N array
9811 :
9812 : -- ALGLIB routine --
9813 : 20.10.2014
9814 : Bochkanov Sergey
9815 : *************************************************************************/
9816 0 : ae_bool smatrixtdunpackqmkl(/* Real */ ae_matrix* a,
9817 : ae_int_t n,
9818 : ae_bool isupper,
9819 : /* Real */ ae_vector* tau,
9820 : /* Real */ ae_matrix* q,
9821 : ae_state *_state)
9822 : {
9823 : #ifndef ALGLIB_INTERCEPTS_MKL
9824 : ae_bool result;
9825 :
9826 :
9827 0 : result = ae_false;
9828 0 : return result;
9829 : #else
9830 : return _ialglib_i_smatrixtdunpackqmkl(a, n, isupper, tau, q);
9831 : #endif
9832 : }
9833 :
9834 :
9835 : /*************************************************************************
9836 : MKL-based kernel.
9837 :
9838 : NOTE: Tau, D, E must be preallocated arrays;
9839 : length(E)=length(Tau)=N-1 (or larger)
9840 : length(D)=N (or larger)
9841 :
9842 : -- ALGLIB routine --
9843 : 20.10.2014
9844 : Bochkanov Sergey
9845 : *************************************************************************/
9846 0 : ae_bool hmatrixtdmkl(/* Complex */ ae_matrix* a,
9847 : ae_int_t n,
9848 : ae_bool isupper,
9849 : /* Complex */ ae_vector* tau,
9850 : /* Real */ ae_vector* d,
9851 : /* Real */ ae_vector* e,
9852 : ae_state *_state)
9853 : {
9854 : #ifndef ALGLIB_INTERCEPTS_MKL
9855 : ae_bool result;
9856 :
9857 :
9858 0 : result = ae_false;
9859 0 : return result;
9860 : #else
9861 : return _ialglib_i_hmatrixtdmkl(a, n, isupper, tau, d, e);
9862 : #endif
9863 : }
9864 :
9865 :
9866 : /*************************************************************************
9867 : MKL-based kernel.
9868 :
9869 : NOTE: Q must be preallocated N*N array
9870 :
9871 : -- ALGLIB routine --
9872 : 20.10.2014
9873 : Bochkanov Sergey
9874 : *************************************************************************/
9875 0 : ae_bool hmatrixtdunpackqmkl(/* Complex */ ae_matrix* a,
9876 : ae_int_t n,
9877 : ae_bool isupper,
9878 : /* Complex */ ae_vector* tau,
9879 : /* Complex */ ae_matrix* q,
9880 : ae_state *_state)
9881 : {
9882 : #ifndef ALGLIB_INTERCEPTS_MKL
9883 : ae_bool result;
9884 :
9885 :
9886 0 : result = ae_false;
9887 0 : return result;
9888 : #else
9889 : return _ialglib_i_hmatrixtdunpackqmkl(a, n, isupper, tau, q);
9890 : #endif
9891 : }
9892 :
9893 :
9894 : /*************************************************************************
9895 : MKL-based kernel.
9896 :
9897 : Returns True if MKL was present and handled request (MKL completion code
9898 : is returned as separate output parameter).
9899 :
9900 : D and E are pre-allocated arrays with length N (both of them!). On output,
9901 : D constraints singular values, and E is destroyed.
9902 :
9903 : SVDResult is modified if and only if MKL is present.
9904 :
9905 : -- ALGLIB routine --
9906 : 20.10.2014
9907 : Bochkanov Sergey
9908 : *************************************************************************/
9909 0 : ae_bool rmatrixbdsvdmkl(/* Real */ ae_vector* d,
9910 : /* Real */ ae_vector* e,
9911 : ae_int_t n,
9912 : ae_bool isupper,
9913 : /* Real */ ae_matrix* u,
9914 : ae_int_t nru,
9915 : /* Real */ ae_matrix* c,
9916 : ae_int_t ncc,
9917 : /* Real */ ae_matrix* vt,
9918 : ae_int_t ncvt,
9919 : ae_bool* svdresult,
9920 : ae_state *_state)
9921 : {
9922 : #ifndef ALGLIB_INTERCEPTS_MKL
9923 : ae_bool result;
9924 :
9925 :
9926 0 : result = ae_false;
9927 0 : return result;
9928 : #else
9929 : return _ialglib_i_rmatrixbdsvdmkl(d, e, n, isupper, u, nru, c, ncc, vt, ncvt, svdresult);
9930 : #endif
9931 : }
9932 :
9933 :
9934 : /*************************************************************************
9935 : MKL-based DHSEQR kernel.
9936 :
9937 : Returns True if MKL was present and handled request.
9938 :
9939 : WR and WI are pre-allocated arrays with length N.
9940 : Z is pre-allocated array[N,N].
9941 :
9942 : -- ALGLIB routine --
9943 : 20.10.2014
9944 : Bochkanov Sergey
9945 : *************************************************************************/
9946 0 : ae_bool rmatrixinternalschurdecompositionmkl(/* Real */ ae_matrix* h,
9947 : ae_int_t n,
9948 : ae_int_t tneeded,
9949 : ae_int_t zneeded,
9950 : /* Real */ ae_vector* wr,
9951 : /* Real */ ae_vector* wi,
9952 : /* Real */ ae_matrix* z,
9953 : ae_int_t* info,
9954 : ae_state *_state)
9955 : {
9956 : #ifndef ALGLIB_INTERCEPTS_MKL
9957 : ae_bool result;
9958 :
9959 :
9960 0 : result = ae_false;
9961 0 : return result;
9962 : #else
9963 : return _ialglib_i_rmatrixinternalschurdecompositionmkl(h, n, tneeded, zneeded, wr, wi, z, info);
9964 : #endif
9965 : }
9966 :
9967 :
9968 : /*************************************************************************
9969 : MKL-based DTREVC kernel.
9970 :
9971 : Returns True if MKL was present and handled request.
9972 :
9973 : NOTE: this function does NOT support HOWMNY=3!!!!
9974 :
9975 : VL and VR are pre-allocated arrays with length N*N, if required. If particalar
9976 : variables is not required, it can be dummy (empty) array.
9977 :
9978 : -- ALGLIB routine --
9979 : 20.10.2014
9980 : Bochkanov Sergey
9981 : *************************************************************************/
9982 0 : ae_bool rmatrixinternaltrevcmkl(/* Real */ ae_matrix* t,
9983 : ae_int_t n,
9984 : ae_int_t side,
9985 : ae_int_t howmny,
9986 : /* Real */ ae_matrix* vl,
9987 : /* Real */ ae_matrix* vr,
9988 : ae_int_t* m,
9989 : ae_int_t* info,
9990 : ae_state *_state)
9991 : {
9992 : #ifndef ALGLIB_INTERCEPTS_MKL
9993 : ae_bool result;
9994 :
9995 :
9996 0 : result = ae_false;
9997 0 : return result;
9998 : #else
9999 : return _ialglib_i_rmatrixinternaltrevcmkl(t, n, side, howmny, vl, vr, m, info);
10000 : #endif
10001 : }
10002 :
10003 :
10004 : /*************************************************************************
10005 : MKL-based kernel.
10006 :
10007 : Returns True if MKL was present and handled request (MKL completion code
10008 : is returned as separate output parameter).
10009 :
10010 : D and E are pre-allocated arrays with length N (both of them!). On output,
10011 : D constraints eigenvalues, and E is destroyed.
10012 :
10013 : Z is preallocated array[N,N] for ZNeeded<>0; ignored for ZNeeded=0.
10014 :
10015 : EVDResult is modified if and only if MKL is present.
10016 :
10017 : -- ALGLIB routine --
10018 : 20.10.2014
10019 : Bochkanov Sergey
10020 : *************************************************************************/
10021 0 : ae_bool smatrixtdevdmkl(/* Real */ ae_vector* d,
10022 : /* Real */ ae_vector* e,
10023 : ae_int_t n,
10024 : ae_int_t zneeded,
10025 : /* Real */ ae_matrix* z,
10026 : ae_bool* evdresult,
10027 : ae_state *_state)
10028 : {
10029 : #ifndef ALGLIB_INTERCEPTS_MKL
10030 : ae_bool result;
10031 :
10032 :
10033 0 : result = ae_false;
10034 0 : return result;
10035 : #else
10036 : return _ialglib_i_smatrixtdevdmkl(d, e, n, zneeded, z, evdresult);
10037 : #endif
10038 : }
10039 :
10040 :
10041 : /*************************************************************************
10042 : MKL-based kernel.
10043 :
10044 : Returns True if MKL was present and handled request (MKL completion code
10045 : is returned as separate output parameter).
10046 :
10047 : D and E are pre-allocated arrays with length N (both of them!). On output,
10048 : D constraints eigenvalues, and E is destroyed.
10049 :
10050 : Z is preallocated array[N,N] for ZNeeded<>0; ignored for ZNeeded=0.
10051 :
10052 : EVDResult is modified if and only if MKL is present.
10053 :
10054 : -- ALGLIB routine --
10055 : 20.10.2014
10056 : Bochkanov Sergey
10057 : *************************************************************************/
10058 0 : ae_bool sparsegemvcrsmkl(ae_int_t opa,
10059 : ae_int_t arows,
10060 : ae_int_t acols,
10061 : double alpha,
10062 : /* Real */ ae_vector* vals,
10063 : /* Integer */ ae_vector* cidx,
10064 : /* Integer */ ae_vector* ridx,
10065 : /* Real */ ae_vector* x,
10066 : ae_int_t ix,
10067 : double beta,
10068 : /* Real */ ae_vector* y,
10069 : ae_int_t iy,
10070 : ae_state *_state)
10071 : {
10072 : #ifndef ALGLIB_INTERCEPTS_MKL
10073 : ae_bool result;
10074 :
10075 :
10076 0 : result = ae_false;
10077 0 : return result;
10078 : #else
10079 : return _ialglib_i_sparsegemvcrsmkl(opa, arows, acols, alpha, vals, cidx, ridx, x, ix, beta, y, iy);
10080 : #endif
10081 : }
10082 :
10083 :
10084 : #endif
10085 : #if defined(AE_COMPILE_CREFLECTIONS) || !defined(AE_PARTIAL_BUILD)
10086 :
10087 :
10088 : /*************************************************************************
10089 : Generation of an elementary complex reflection transformation
10090 :
10091 : The subroutine generates elementary complex reflection H of order N, so
10092 : that, for a given X, the following equality holds true:
10093 :
10094 : ( X(1) ) ( Beta )
10095 : H' * ( .. ) = ( 0 ), H'*H = I, Beta is a real number
10096 : ( X(n) ) ( 0 )
10097 :
10098 : where
10099 :
10100 : ( V(1) )
10101 : H = 1 - Tau * ( .. ) * ( conj(V(1)), ..., conj(V(n)) )
10102 : ( V(n) )
10103 :
10104 : where the first component of vector V equals 1.
10105 :
10106 : Input parameters:
10107 : X - vector. Array with elements [1..N].
10108 : N - reflection order.
10109 :
10110 : Output parameters:
10111 : X - components from 2 to N are replaced by vector V.
10112 : The first component is replaced with parameter Beta.
10113 : Tau - scalar value Tau.
10114 :
10115 : This subroutine is the modification of CLARFG subroutines from the LAPACK
10116 : library. It has similar functionality except for the fact that it doesn't
10117 : handle errors when intermediate results cause an overflow.
10118 :
10119 : -- LAPACK auxiliary routine (version 3.0) --
10120 : Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10121 : Courant Institute, Argonne National Lab, and Rice University
10122 : September 30, 1994
10123 : *************************************************************************/
10124 0 : void complexgeneratereflection(/* Complex */ ae_vector* x,
10125 : ae_int_t n,
10126 : ae_complex* tau,
10127 : ae_state *_state)
10128 : {
10129 : ae_int_t j;
10130 : ae_complex alpha;
10131 : double alphi;
10132 : double alphr;
10133 : double beta;
10134 : double xnorm;
10135 : double mx;
10136 : ae_complex t;
10137 : double s;
10138 : ae_complex v;
10139 :
10140 0 : tau->x = 0;
10141 0 : tau->y = 0;
10142 :
10143 0 : if( n<=0 )
10144 : {
10145 0 : *tau = ae_complex_from_i(0);
10146 0 : return;
10147 : }
10148 :
10149 : /*
10150 : * Scale if needed (to avoid overflow/underflow during intermediate
10151 : * calculations).
10152 : */
10153 0 : mx = (double)(0);
10154 0 : for(j=1; j<=n; j++)
10155 : {
10156 0 : mx = ae_maxreal(ae_c_abs(x->ptr.p_complex[j], _state), mx, _state);
10157 : }
10158 0 : s = (double)(1);
10159 0 : if( ae_fp_neq(mx,(double)(0)) )
10160 : {
10161 0 : if( ae_fp_less(mx,(double)(1)) )
10162 : {
10163 0 : s = ae_sqrt(ae_minrealnumber, _state);
10164 0 : v = ae_complex_from_d(1/s);
10165 0 : ae_v_cmulc(&x->ptr.p_complex[1], 1, ae_v_len(1,n), v);
10166 : }
10167 : else
10168 : {
10169 0 : s = ae_sqrt(ae_maxrealnumber, _state);
10170 0 : v = ae_complex_from_d(1/s);
10171 0 : ae_v_cmulc(&x->ptr.p_complex[1], 1, ae_v_len(1,n), v);
10172 : }
10173 : }
10174 :
10175 : /*
10176 : * calculate
10177 : */
10178 0 : alpha = x->ptr.p_complex[1];
10179 0 : mx = (double)(0);
10180 0 : for(j=2; j<=n; j++)
10181 : {
10182 0 : mx = ae_maxreal(ae_c_abs(x->ptr.p_complex[j], _state), mx, _state);
10183 : }
10184 0 : xnorm = (double)(0);
10185 0 : if( ae_fp_neq(mx,(double)(0)) )
10186 : {
10187 0 : for(j=2; j<=n; j++)
10188 : {
10189 0 : t = ae_c_div_d(x->ptr.p_complex[j],mx);
10190 0 : xnorm = xnorm+ae_c_mul(t,ae_c_conj(t, _state)).x;
10191 : }
10192 0 : xnorm = ae_sqrt(xnorm, _state)*mx;
10193 : }
10194 0 : alphr = alpha.x;
10195 0 : alphi = alpha.y;
10196 0 : if( ae_fp_eq(xnorm,(double)(0))&&ae_fp_eq(alphi,(double)(0)) )
10197 : {
10198 0 : *tau = ae_complex_from_i(0);
10199 0 : x->ptr.p_complex[1] = ae_c_mul_d(x->ptr.p_complex[1],s);
10200 0 : return;
10201 : }
10202 0 : mx = ae_maxreal(ae_fabs(alphr, _state), ae_fabs(alphi, _state), _state);
10203 0 : mx = ae_maxreal(mx, ae_fabs(xnorm, _state), _state);
10204 0 : beta = -mx*ae_sqrt(ae_sqr(alphr/mx, _state)+ae_sqr(alphi/mx, _state)+ae_sqr(xnorm/mx, _state), _state);
10205 0 : if( ae_fp_less(alphr,(double)(0)) )
10206 : {
10207 0 : beta = -beta;
10208 : }
10209 0 : tau->x = (beta-alphr)/beta;
10210 0 : tau->y = -alphi/beta;
10211 0 : alpha = ae_c_d_div(1,ae_c_sub_d(alpha,beta));
10212 0 : if( n>1 )
10213 : {
10214 0 : ae_v_cmulc(&x->ptr.p_complex[2], 1, ae_v_len(2,n), alpha);
10215 : }
10216 0 : alpha = ae_complex_from_d(beta);
10217 0 : x->ptr.p_complex[1] = alpha;
10218 :
10219 : /*
10220 : * Scale back
10221 : */
10222 0 : x->ptr.p_complex[1] = ae_c_mul_d(x->ptr.p_complex[1],s);
10223 : }
10224 :
10225 :
10226 : /*************************************************************************
10227 : Application of an elementary reflection to a rectangular matrix of size MxN
10228 :
10229 : The algorithm pre-multiplies the matrix by an elementary reflection
10230 : transformation which is given by column V and scalar Tau (see the
10231 : description of the GenerateReflection). Not the whole matrix but only a
10232 : part of it is transformed (rows from M1 to M2, columns from N1 to N2). Only
10233 : the elements of this submatrix are changed.
10234 :
10235 : Note: the matrix is multiplied by H, not by H'. If it is required to
10236 : multiply the matrix by H', it is necessary to pass Conj(Tau) instead of Tau.
10237 :
10238 : Input parameters:
10239 : C - matrix to be transformed.
10240 : Tau - scalar defining transformation.
10241 : V - column defining transformation.
10242 : Array whose index ranges within [1..M2-M1+1]
10243 : M1, M2 - range of rows to be transformed.
10244 : N1, N2 - range of columns to be transformed.
10245 : WORK - working array whose index goes from N1 to N2.
10246 :
10247 : Output parameters:
10248 : C - the result of multiplying the input matrix C by the
10249 : transformation matrix which is given by Tau and V.
10250 : If N1>N2 or M1>M2, C is not modified.
10251 :
10252 : -- LAPACK auxiliary routine (version 3.0) --
10253 : Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10254 : Courant Institute, Argonne National Lab, and Rice University
10255 : September 30, 1994
10256 : *************************************************************************/
10257 0 : void complexapplyreflectionfromtheleft(/* Complex */ ae_matrix* c,
10258 : ae_complex tau,
10259 : /* Complex */ ae_vector* v,
10260 : ae_int_t m1,
10261 : ae_int_t m2,
10262 : ae_int_t n1,
10263 : ae_int_t n2,
10264 : /* Complex */ ae_vector* work,
10265 : ae_state *_state)
10266 : {
10267 : ae_complex t;
10268 : ae_int_t i;
10269 :
10270 :
10271 0 : if( (ae_c_eq_d(tau,(double)(0))||n1>n2)||m1>m2 )
10272 : {
10273 0 : return;
10274 : }
10275 :
10276 : /*
10277 : * w := C^T * conj(v)
10278 : */
10279 0 : for(i=n1; i<=n2; i++)
10280 : {
10281 0 : work->ptr.p_complex[i] = ae_complex_from_i(0);
10282 : }
10283 0 : for(i=m1; i<=m2; i++)
10284 : {
10285 0 : t = ae_c_conj(v->ptr.p_complex[i+1-m1], _state);
10286 0 : ae_v_caddc(&work->ptr.p_complex[n1], 1, &c->ptr.pp_complex[i][n1], 1, "N", ae_v_len(n1,n2), t);
10287 : }
10288 :
10289 : /*
10290 : * C := C - tau * v * w^T
10291 : */
10292 0 : for(i=m1; i<=m2; i++)
10293 : {
10294 0 : t = ae_c_mul(v->ptr.p_complex[i-m1+1],tau);
10295 0 : ae_v_csubc(&c->ptr.pp_complex[i][n1], 1, &work->ptr.p_complex[n1], 1, "N", ae_v_len(n1,n2), t);
10296 : }
10297 : }
10298 :
10299 :
10300 : /*************************************************************************
10301 : Application of an elementary reflection to a rectangular matrix of size MxN
10302 :
10303 : The algorithm post-multiplies the matrix by an elementary reflection
10304 : transformation which is given by column V and scalar Tau (see the
10305 : description of the GenerateReflection). Not the whole matrix but only a
10306 : part of it is transformed (rows from M1 to M2, columns from N1 to N2).
10307 : Only the elements of this submatrix are changed.
10308 :
10309 : Input parameters:
10310 : C - matrix to be transformed.
10311 : Tau - scalar defining transformation.
10312 : V - column defining transformation.
10313 : Array whose index ranges within [1..N2-N1+1]
10314 : M1, M2 - range of rows to be transformed.
10315 : N1, N2 - range of columns to be transformed.
10316 : WORK - working array whose index goes from M1 to M2.
10317 :
10318 : Output parameters:
10319 : C - the result of multiplying the input matrix C by the
10320 : transformation matrix which is given by Tau and V.
10321 : If N1>N2 or M1>M2, C is not modified.
10322 :
10323 : -- LAPACK auxiliary routine (version 3.0) --
10324 : Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10325 : Courant Institute, Argonne National Lab, and Rice University
10326 : September 30, 1994
10327 : *************************************************************************/
10328 0 : void complexapplyreflectionfromtheright(/* Complex */ ae_matrix* c,
10329 : ae_complex tau,
10330 : /* Complex */ ae_vector* v,
10331 : ae_int_t m1,
10332 : ae_int_t m2,
10333 : ae_int_t n1,
10334 : ae_int_t n2,
10335 : /* Complex */ ae_vector* work,
10336 : ae_state *_state)
10337 : {
10338 : ae_complex t;
10339 : ae_int_t i;
10340 : ae_int_t vm;
10341 :
10342 :
10343 0 : if( (ae_c_eq_d(tau,(double)(0))||n1>n2)||m1>m2 )
10344 : {
10345 0 : return;
10346 : }
10347 :
10348 : /*
10349 : * w := C * v
10350 : */
10351 0 : vm = n2-n1+1;
10352 0 : for(i=m1; i<=m2; i++)
10353 : {
10354 0 : t = ae_v_cdotproduct(&c->ptr.pp_complex[i][n1], 1, "N", &v->ptr.p_complex[1], 1, "N", ae_v_len(n1,n2));
10355 0 : work->ptr.p_complex[i] = t;
10356 : }
10357 :
10358 : /*
10359 : * C := C - w * conj(v^T)
10360 : */
10361 0 : ae_v_cmove(&v->ptr.p_complex[1], 1, &v->ptr.p_complex[1], 1, "Conj", ae_v_len(1,vm));
10362 0 : for(i=m1; i<=m2; i++)
10363 : {
10364 0 : t = ae_c_mul(work->ptr.p_complex[i],tau);
10365 0 : ae_v_csubc(&c->ptr.pp_complex[i][n1], 1, &v->ptr.p_complex[1], 1, "N", ae_v_len(n1,n2), t);
10366 : }
10367 0 : ae_v_cmove(&v->ptr.p_complex[1], 1, &v->ptr.p_complex[1], 1, "Conj", ae_v_len(1,vm));
10368 : }
10369 :
10370 :
10371 : #endif
10372 : #if defined(AE_COMPILE_ROTATIONS) || !defined(AE_PARTIAL_BUILD)
10373 :
10374 :
10375 : /*************************************************************************
10376 : Application of a sequence of elementary rotations to a matrix
10377 :
10378 : The algorithm pre-multiplies the matrix by a sequence of rotation
10379 : transformations which is given by arrays C and S. Depending on the value
10380 : of the IsForward parameter either 1 and 2, 3 and 4 and so on (if IsForward=true)
10381 : rows are rotated, or the rows N and N-1, N-2 and N-3 and so on, are rotated.
10382 :
10383 : Not the whole matrix but only a part of it is transformed (rows from M1 to
10384 : M2, columns from N1 to N2). Only the elements of this submatrix are changed.
10385 :
10386 : Input parameters:
10387 : IsForward - the sequence of the rotation application.
10388 : M1,M2 - the range of rows to be transformed.
10389 : N1, N2 - the range of columns to be transformed.
10390 : C,S - transformation coefficients.
10391 : Array whose index ranges within [1..M2-M1].
10392 : A - processed matrix.
10393 : WORK - working array whose index ranges within [N1..N2].
10394 :
10395 : Output parameters:
10396 : A - transformed matrix.
10397 :
10398 : Utility subroutine.
10399 : *************************************************************************/
10400 0 : void applyrotationsfromtheleft(ae_bool isforward,
10401 : ae_int_t m1,
10402 : ae_int_t m2,
10403 : ae_int_t n1,
10404 : ae_int_t n2,
10405 : /* Real */ ae_vector* c,
10406 : /* Real */ ae_vector* s,
10407 : /* Real */ ae_matrix* a,
10408 : /* Real */ ae_vector* work,
10409 : ae_state *_state)
10410 : {
10411 : ae_int_t j;
10412 : ae_int_t jp1;
10413 : double ctemp;
10414 : double stemp;
10415 : double temp;
10416 :
10417 :
10418 0 : if( m1>m2||n1>n2 )
10419 : {
10420 0 : return;
10421 : }
10422 :
10423 : /*
10424 : * Form P * A
10425 : */
10426 0 : if( isforward )
10427 : {
10428 0 : if( n1!=n2 )
10429 : {
10430 :
10431 : /*
10432 : * Common case: N1<>N2
10433 : */
10434 0 : for(j=m1; j<=m2-1; j++)
10435 : {
10436 0 : ctemp = c->ptr.p_double[j-m1+1];
10437 0 : stemp = s->ptr.p_double[j-m1+1];
10438 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10439 : {
10440 0 : jp1 = j+1;
10441 0 : ae_v_moved(&work->ptr.p_double[n1], 1, &a->ptr.pp_double[jp1][n1], 1, ae_v_len(n1,n2), ctemp);
10442 0 : ae_v_subd(&work->ptr.p_double[n1], 1, &a->ptr.pp_double[j][n1], 1, ae_v_len(n1,n2), stemp);
10443 0 : ae_v_muld(&a->ptr.pp_double[j][n1], 1, ae_v_len(n1,n2), ctemp);
10444 0 : ae_v_addd(&a->ptr.pp_double[j][n1], 1, &a->ptr.pp_double[jp1][n1], 1, ae_v_len(n1,n2), stemp);
10445 0 : ae_v_move(&a->ptr.pp_double[jp1][n1], 1, &work->ptr.p_double[n1], 1, ae_v_len(n1,n2));
10446 : }
10447 : }
10448 : }
10449 : else
10450 : {
10451 :
10452 : /*
10453 : * Special case: N1=N2
10454 : */
10455 0 : for(j=m1; j<=m2-1; j++)
10456 : {
10457 0 : ctemp = c->ptr.p_double[j-m1+1];
10458 0 : stemp = s->ptr.p_double[j-m1+1];
10459 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10460 : {
10461 0 : temp = a->ptr.pp_double[j+1][n1];
10462 0 : a->ptr.pp_double[j+1][n1] = ctemp*temp-stemp*a->ptr.pp_double[j][n1];
10463 0 : a->ptr.pp_double[j][n1] = stemp*temp+ctemp*a->ptr.pp_double[j][n1];
10464 : }
10465 : }
10466 : }
10467 : }
10468 : else
10469 : {
10470 0 : if( n1!=n2 )
10471 : {
10472 :
10473 : /*
10474 : * Common case: N1<>N2
10475 : */
10476 0 : for(j=m2-1; j>=m1; j--)
10477 : {
10478 0 : ctemp = c->ptr.p_double[j-m1+1];
10479 0 : stemp = s->ptr.p_double[j-m1+1];
10480 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10481 : {
10482 0 : jp1 = j+1;
10483 0 : ae_v_moved(&work->ptr.p_double[n1], 1, &a->ptr.pp_double[jp1][n1], 1, ae_v_len(n1,n2), ctemp);
10484 0 : ae_v_subd(&work->ptr.p_double[n1], 1, &a->ptr.pp_double[j][n1], 1, ae_v_len(n1,n2), stemp);
10485 0 : ae_v_muld(&a->ptr.pp_double[j][n1], 1, ae_v_len(n1,n2), ctemp);
10486 0 : ae_v_addd(&a->ptr.pp_double[j][n1], 1, &a->ptr.pp_double[jp1][n1], 1, ae_v_len(n1,n2), stemp);
10487 0 : ae_v_move(&a->ptr.pp_double[jp1][n1], 1, &work->ptr.p_double[n1], 1, ae_v_len(n1,n2));
10488 : }
10489 : }
10490 : }
10491 : else
10492 : {
10493 :
10494 : /*
10495 : * Special case: N1=N2
10496 : */
10497 0 : for(j=m2-1; j>=m1; j--)
10498 : {
10499 0 : ctemp = c->ptr.p_double[j-m1+1];
10500 0 : stemp = s->ptr.p_double[j-m1+1];
10501 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10502 : {
10503 0 : temp = a->ptr.pp_double[j+1][n1];
10504 0 : a->ptr.pp_double[j+1][n1] = ctemp*temp-stemp*a->ptr.pp_double[j][n1];
10505 0 : a->ptr.pp_double[j][n1] = stemp*temp+ctemp*a->ptr.pp_double[j][n1];
10506 : }
10507 : }
10508 : }
10509 : }
10510 : }
10511 :
10512 :
10513 : /*************************************************************************
10514 : Application of a sequence of elementary rotations to a matrix
10515 :
10516 : The algorithm post-multiplies the matrix by a sequence of rotation
10517 : transformations which is given by arrays C and S. Depending on the value
10518 : of the IsForward parameter either 1 and 2, 3 and 4 and so on (if IsForward=true)
10519 : rows are rotated, or the rows N and N-1, N-2 and N-3 and so on are rotated.
10520 :
10521 : Not the whole matrix but only a part of it is transformed (rows from M1
10522 : to M2, columns from N1 to N2). Only the elements of this submatrix are changed.
10523 :
10524 : Input parameters:
10525 : IsForward - the sequence of the rotation application.
10526 : M1,M2 - the range of rows to be transformed.
10527 : N1, N2 - the range of columns to be transformed.
10528 : C,S - transformation coefficients.
10529 : Array whose index ranges within [1..N2-N1].
10530 : A - processed matrix.
10531 : WORK - working array whose index ranges within [M1..M2].
10532 :
10533 : Output parameters:
10534 : A - transformed matrix.
10535 :
10536 : Utility subroutine.
10537 : *************************************************************************/
10538 0 : void applyrotationsfromtheright(ae_bool isforward,
10539 : ae_int_t m1,
10540 : ae_int_t m2,
10541 : ae_int_t n1,
10542 : ae_int_t n2,
10543 : /* Real */ ae_vector* c,
10544 : /* Real */ ae_vector* s,
10545 : /* Real */ ae_matrix* a,
10546 : /* Real */ ae_vector* work,
10547 : ae_state *_state)
10548 : {
10549 : ae_int_t j;
10550 : ae_int_t jp1;
10551 : double ctemp;
10552 : double stemp;
10553 : double temp;
10554 :
10555 :
10556 :
10557 : /*
10558 : * Form A * P'
10559 : */
10560 0 : if( isforward )
10561 : {
10562 0 : if( m1!=m2 )
10563 : {
10564 :
10565 : /*
10566 : * Common case: M1<>M2
10567 : */
10568 0 : for(j=n1; j<=n2-1; j++)
10569 : {
10570 0 : ctemp = c->ptr.p_double[j-n1+1];
10571 0 : stemp = s->ptr.p_double[j-n1+1];
10572 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10573 : {
10574 0 : jp1 = j+1;
10575 0 : ae_v_moved(&work->ptr.p_double[m1], 1, &a->ptr.pp_double[m1][jp1], a->stride, ae_v_len(m1,m2), ctemp);
10576 0 : ae_v_subd(&work->ptr.p_double[m1], 1, &a->ptr.pp_double[m1][j], a->stride, ae_v_len(m1,m2), stemp);
10577 0 : ae_v_muld(&a->ptr.pp_double[m1][j], a->stride, ae_v_len(m1,m2), ctemp);
10578 0 : ae_v_addd(&a->ptr.pp_double[m1][j], a->stride, &a->ptr.pp_double[m1][jp1], a->stride, ae_v_len(m1,m2), stemp);
10579 0 : ae_v_move(&a->ptr.pp_double[m1][jp1], a->stride, &work->ptr.p_double[m1], 1, ae_v_len(m1,m2));
10580 : }
10581 : }
10582 : }
10583 : else
10584 : {
10585 :
10586 : /*
10587 : * Special case: M1=M2
10588 : */
10589 0 : for(j=n1; j<=n2-1; j++)
10590 : {
10591 0 : ctemp = c->ptr.p_double[j-n1+1];
10592 0 : stemp = s->ptr.p_double[j-n1+1];
10593 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10594 : {
10595 0 : temp = a->ptr.pp_double[m1][j+1];
10596 0 : a->ptr.pp_double[m1][j+1] = ctemp*temp-stemp*a->ptr.pp_double[m1][j];
10597 0 : a->ptr.pp_double[m1][j] = stemp*temp+ctemp*a->ptr.pp_double[m1][j];
10598 : }
10599 : }
10600 : }
10601 : }
10602 : else
10603 : {
10604 0 : if( m1!=m2 )
10605 : {
10606 :
10607 : /*
10608 : * Common case: M1<>M2
10609 : */
10610 0 : for(j=n2-1; j>=n1; j--)
10611 : {
10612 0 : ctemp = c->ptr.p_double[j-n1+1];
10613 0 : stemp = s->ptr.p_double[j-n1+1];
10614 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10615 : {
10616 0 : jp1 = j+1;
10617 0 : ae_v_moved(&work->ptr.p_double[m1], 1, &a->ptr.pp_double[m1][jp1], a->stride, ae_v_len(m1,m2), ctemp);
10618 0 : ae_v_subd(&work->ptr.p_double[m1], 1, &a->ptr.pp_double[m1][j], a->stride, ae_v_len(m1,m2), stemp);
10619 0 : ae_v_muld(&a->ptr.pp_double[m1][j], a->stride, ae_v_len(m1,m2), ctemp);
10620 0 : ae_v_addd(&a->ptr.pp_double[m1][j], a->stride, &a->ptr.pp_double[m1][jp1], a->stride, ae_v_len(m1,m2), stemp);
10621 0 : ae_v_move(&a->ptr.pp_double[m1][jp1], a->stride, &work->ptr.p_double[m1], 1, ae_v_len(m1,m2));
10622 : }
10623 : }
10624 : }
10625 : else
10626 : {
10627 :
10628 : /*
10629 : * Special case: M1=M2
10630 : */
10631 0 : for(j=n2-1; j>=n1; j--)
10632 : {
10633 0 : ctemp = c->ptr.p_double[j-n1+1];
10634 0 : stemp = s->ptr.p_double[j-n1+1];
10635 0 : if( ae_fp_neq(ctemp,(double)(1))||ae_fp_neq(stemp,(double)(0)) )
10636 : {
10637 0 : temp = a->ptr.pp_double[m1][j+1];
10638 0 : a->ptr.pp_double[m1][j+1] = ctemp*temp-stemp*a->ptr.pp_double[m1][j];
10639 0 : a->ptr.pp_double[m1][j] = stemp*temp+ctemp*a->ptr.pp_double[m1][j];
10640 : }
10641 : }
10642 : }
10643 : }
10644 0 : }
10645 :
10646 :
10647 : /*************************************************************************
10648 : The subroutine generates the elementary rotation, so that:
10649 :
10650 : [ CS SN ] . [ F ] = [ R ]
10651 : [ -SN CS ] [ G ] [ 0 ]
10652 :
10653 : CS**2 + SN**2 = 1
10654 : *************************************************************************/
10655 0 : void generaterotation(double f,
10656 : double g,
10657 : double* cs,
10658 : double* sn,
10659 : double* r,
10660 : ae_state *_state)
10661 : {
10662 : double f1;
10663 : double g1;
10664 :
10665 0 : *cs = 0;
10666 0 : *sn = 0;
10667 0 : *r = 0;
10668 :
10669 0 : if( ae_fp_eq(g,(double)(0)) )
10670 : {
10671 0 : *cs = (double)(1);
10672 0 : *sn = (double)(0);
10673 0 : *r = f;
10674 : }
10675 : else
10676 : {
10677 0 : if( ae_fp_eq(f,(double)(0)) )
10678 : {
10679 0 : *cs = (double)(0);
10680 0 : *sn = (double)(1);
10681 0 : *r = g;
10682 : }
10683 : else
10684 : {
10685 0 : f1 = f;
10686 0 : g1 = g;
10687 0 : if( ae_fp_greater(ae_fabs(f1, _state),ae_fabs(g1, _state)) )
10688 : {
10689 0 : *r = ae_fabs(f1, _state)*ae_sqrt(1+ae_sqr(g1/f1, _state), _state);
10690 : }
10691 : else
10692 : {
10693 0 : *r = ae_fabs(g1, _state)*ae_sqrt(1+ae_sqr(f1/g1, _state), _state);
10694 : }
10695 0 : *cs = f1/(*r);
10696 0 : *sn = g1/(*r);
10697 0 : if( ae_fp_greater(ae_fabs(f, _state),ae_fabs(g, _state))&&ae_fp_less(*cs,(double)(0)) )
10698 : {
10699 0 : *cs = -*cs;
10700 0 : *sn = -*sn;
10701 0 : *r = -*r;
10702 : }
10703 : }
10704 : }
10705 0 : }
10706 :
10707 :
10708 : #endif
10709 : #if defined(AE_COMPILE_TRLINSOLVE) || !defined(AE_PARTIAL_BUILD)
10710 :
10711 :
10712 : /*************************************************************************
10713 : Utility subroutine performing the "safe" solution of system of linear
10714 : equations with triangular coefficient matrices.
10715 :
10716 : The subroutine uses scaling and solves the scaled system A*x=s*b (where s
10717 : is a scalar value) instead of A*x=b, choosing s so that x can be
10718 : represented by a floating-point number. The closer the system gets to a
10719 : singular, the less s is. If the system is singular, s=0 and x contains the
10720 : non-trivial solution of equation A*x=0.
10721 :
10722 : The feature of an algorithm is that it could not cause an overflow or a
10723 : division by zero regardless of the matrix used as the input.
10724 :
10725 : The algorithm can solve systems of equations with upper/lower triangular
10726 : matrices, with/without unit diagonal, and systems of type A*x=b or A'*x=b
10727 : (where A' is a transposed matrix A).
10728 :
10729 : Input parameters:
10730 : A - system matrix. Array whose indexes range within [0..N-1, 0..N-1].
10731 : N - size of matrix A.
10732 : X - right-hand member of a system.
10733 : Array whose index ranges within [0..N-1].
10734 : IsUpper - matrix type. If it is True, the system matrix is the upper
10735 : triangular and is located in the corresponding part of
10736 : matrix A.
10737 : Trans - problem type. If it is True, the problem to be solved is
10738 : A'*x=b, otherwise it is A*x=b.
10739 : Isunit - matrix type. If it is True, the system matrix has a unit
10740 : diagonal (the elements on the main diagonal are not used
10741 : in the calculation process), otherwise the matrix is considered
10742 : to be a general triangular matrix.
10743 :
10744 : Output parameters:
10745 : X - solution. Array whose index ranges within [0..N-1].
10746 : S - scaling factor.
10747 :
10748 : -- LAPACK auxiliary routine (version 3.0) --
10749 : Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10750 : Courant Institute, Argonne National Lab, and Rice University
10751 : June 30, 1992
10752 : *************************************************************************/
10753 0 : void rmatrixtrsafesolve(/* Real */ ae_matrix* a,
10754 : ae_int_t n,
10755 : /* Real */ ae_vector* x,
10756 : double* s,
10757 : ae_bool isupper,
10758 : ae_bool istrans,
10759 : ae_bool isunit,
10760 : ae_state *_state)
10761 : {
10762 : ae_frame _frame_block;
10763 : ae_bool normin;
10764 : ae_vector cnorm;
10765 : ae_matrix a1;
10766 : ae_vector x1;
10767 : ae_int_t i;
10768 :
10769 0 : ae_frame_make(_state, &_frame_block);
10770 0 : memset(&cnorm, 0, sizeof(cnorm));
10771 0 : memset(&a1, 0, sizeof(a1));
10772 0 : memset(&x1, 0, sizeof(x1));
10773 0 : *s = 0;
10774 0 : ae_vector_init(&cnorm, 0, DT_REAL, _state, ae_true);
10775 0 : ae_matrix_init(&a1, 0, 0, DT_REAL, _state, ae_true);
10776 0 : ae_vector_init(&x1, 0, DT_REAL, _state, ae_true);
10777 :
10778 :
10779 : /*
10780 : * From 0-based to 1-based
10781 : */
10782 0 : normin = ae_false;
10783 0 : ae_matrix_set_length(&a1, n+1, n+1, _state);
10784 0 : ae_vector_set_length(&x1, n+1, _state);
10785 0 : for(i=1; i<=n; i++)
10786 : {
10787 0 : ae_v_move(&a1.ptr.pp_double[i][1], 1, &a->ptr.pp_double[i-1][0], 1, ae_v_len(1,n));
10788 : }
10789 0 : ae_v_move(&x1.ptr.p_double[1], 1, &x->ptr.p_double[0], 1, ae_v_len(1,n));
10790 :
10791 : /*
10792 : * Solve 1-based
10793 : */
10794 0 : safesolvetriangular(&a1, n, &x1, s, isupper, istrans, isunit, normin, &cnorm, _state);
10795 :
10796 : /*
10797 : * From 1-based to 0-based
10798 : */
10799 0 : ae_v_move(&x->ptr.p_double[0], 1, &x1.ptr.p_double[1], 1, ae_v_len(0,n-1));
10800 0 : ae_frame_leave(_state);
10801 0 : }
10802 :
10803 :
10804 : /*************************************************************************
10805 : Obsolete 1-based subroutine.
10806 : See RMatrixTRSafeSolve for 0-based replacement.
10807 : *************************************************************************/
10808 0 : void safesolvetriangular(/* Real */ ae_matrix* a,
10809 : ae_int_t n,
10810 : /* Real */ ae_vector* x,
10811 : double* s,
10812 : ae_bool isupper,
10813 : ae_bool istrans,
10814 : ae_bool isunit,
10815 : ae_bool normin,
10816 : /* Real */ ae_vector* cnorm,
10817 : ae_state *_state)
10818 : {
10819 : ae_int_t i;
10820 : ae_int_t imax;
10821 : ae_int_t j;
10822 : ae_int_t jfirst;
10823 : ae_int_t jinc;
10824 : ae_int_t jlast;
10825 : ae_int_t jm1;
10826 : ae_int_t jp1;
10827 : ae_int_t ip1;
10828 : ae_int_t im1;
10829 : ae_int_t k;
10830 : ae_int_t flg;
10831 : double v;
10832 : double vd;
10833 : double bignum;
10834 : double grow;
10835 : double rec;
10836 : double smlnum;
10837 : double sumj;
10838 : double tjj;
10839 : double tjjs;
10840 : double tmax;
10841 : double tscal;
10842 : double uscal;
10843 : double xbnd;
10844 : double xj;
10845 : double xmax;
10846 : ae_bool notran;
10847 : ae_bool upper;
10848 : ae_bool nounit;
10849 :
10850 0 : *s = 0;
10851 :
10852 0 : upper = isupper;
10853 0 : notran = !istrans;
10854 0 : nounit = !isunit;
10855 :
10856 : /*
10857 : * these initializers are not really necessary,
10858 : * but without them compiler complains about uninitialized locals
10859 : */
10860 0 : tjjs = (double)(0);
10861 :
10862 : /*
10863 : * Quick return if possible
10864 : */
10865 0 : if( n==0 )
10866 : {
10867 0 : return;
10868 : }
10869 :
10870 : /*
10871 : * Determine machine dependent parameters to control overflow.
10872 : */
10873 0 : smlnum = ae_minrealnumber/(ae_machineepsilon*2);
10874 0 : bignum = 1/smlnum;
10875 0 : *s = (double)(1);
10876 0 : if( !normin )
10877 : {
10878 0 : ae_vector_set_length(cnorm, n+1, _state);
10879 :
10880 : /*
10881 : * Compute the 1-norm of each column, not including the diagonal.
10882 : */
10883 0 : if( upper )
10884 : {
10885 :
10886 : /*
10887 : * A is upper triangular.
10888 : */
10889 0 : for(j=1; j<=n; j++)
10890 : {
10891 0 : v = (double)(0);
10892 0 : for(k=1; k<=j-1; k++)
10893 : {
10894 0 : v = v+ae_fabs(a->ptr.pp_double[k][j], _state);
10895 : }
10896 0 : cnorm->ptr.p_double[j] = v;
10897 : }
10898 : }
10899 : else
10900 : {
10901 :
10902 : /*
10903 : * A is lower triangular.
10904 : */
10905 0 : for(j=1; j<=n-1; j++)
10906 : {
10907 0 : v = (double)(0);
10908 0 : for(k=j+1; k<=n; k++)
10909 : {
10910 0 : v = v+ae_fabs(a->ptr.pp_double[k][j], _state);
10911 : }
10912 0 : cnorm->ptr.p_double[j] = v;
10913 : }
10914 0 : cnorm->ptr.p_double[n] = (double)(0);
10915 : }
10916 : }
10917 :
10918 : /*
10919 : * Scale the column norms by TSCAL if the maximum element in CNORM is
10920 : * greater than BIGNUM.
10921 : */
10922 0 : imax = 1;
10923 0 : for(k=2; k<=n; k++)
10924 : {
10925 0 : if( ae_fp_greater(cnorm->ptr.p_double[k],cnorm->ptr.p_double[imax]) )
10926 : {
10927 0 : imax = k;
10928 : }
10929 : }
10930 0 : tmax = cnorm->ptr.p_double[imax];
10931 0 : if( ae_fp_less_eq(tmax,bignum) )
10932 : {
10933 0 : tscal = (double)(1);
10934 : }
10935 : else
10936 : {
10937 0 : tscal = 1/(smlnum*tmax);
10938 0 : ae_v_muld(&cnorm->ptr.p_double[1], 1, ae_v_len(1,n), tscal);
10939 : }
10940 :
10941 : /*
10942 : * Compute a bound on the computed solution vector to see if the
10943 : * Level 2 BLAS routine DTRSV can be used.
10944 : */
10945 0 : j = 1;
10946 0 : for(k=2; k<=n; k++)
10947 : {
10948 0 : if( ae_fp_greater(ae_fabs(x->ptr.p_double[k], _state),ae_fabs(x->ptr.p_double[j], _state)) )
10949 : {
10950 0 : j = k;
10951 : }
10952 : }
10953 0 : xmax = ae_fabs(x->ptr.p_double[j], _state);
10954 0 : xbnd = xmax;
10955 0 : if( notran )
10956 : {
10957 :
10958 : /*
10959 : * Compute the growth in A * x = b.
10960 : */
10961 0 : if( upper )
10962 : {
10963 0 : jfirst = n;
10964 0 : jlast = 1;
10965 0 : jinc = -1;
10966 : }
10967 : else
10968 : {
10969 0 : jfirst = 1;
10970 0 : jlast = n;
10971 0 : jinc = 1;
10972 : }
10973 0 : if( ae_fp_neq(tscal,(double)(1)) )
10974 : {
10975 0 : grow = (double)(0);
10976 : }
10977 : else
10978 : {
10979 0 : if( nounit )
10980 : {
10981 :
10982 : /*
10983 : * A is non-unit triangular.
10984 : *
10985 : * Compute GROW = 1/G(j) and XBND = 1/M(j).
10986 : * Initially, G(0) = max{x(i), i=1,...,n}.
10987 : */
10988 0 : grow = 1/ae_maxreal(xbnd, smlnum, _state);
10989 0 : xbnd = grow;
10990 0 : j = jfirst;
10991 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
10992 : {
10993 :
10994 : /*
10995 : * Exit the loop if the growth factor is too small.
10996 : */
10997 0 : if( ae_fp_less_eq(grow,smlnum) )
10998 : {
10999 0 : break;
11000 : }
11001 :
11002 : /*
11003 : * M(j) = G(j-1) / abs(A(j,j))
11004 : */
11005 0 : tjj = ae_fabs(a->ptr.pp_double[j][j], _state);
11006 0 : xbnd = ae_minreal(xbnd, ae_minreal((double)(1), tjj, _state)*grow, _state);
11007 0 : if( ae_fp_greater_eq(tjj+cnorm->ptr.p_double[j],smlnum) )
11008 : {
11009 :
11010 : /*
11011 : * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
11012 : */
11013 0 : grow = grow*(tjj/(tjj+cnorm->ptr.p_double[j]));
11014 : }
11015 : else
11016 : {
11017 :
11018 : /*
11019 : * G(j) could overflow, set GROW to 0.
11020 : */
11021 0 : grow = (double)(0);
11022 : }
11023 0 : if( j==jlast )
11024 : {
11025 0 : grow = xbnd;
11026 : }
11027 0 : j = j+jinc;
11028 : }
11029 : }
11030 : else
11031 : {
11032 :
11033 : /*
11034 : * A is unit triangular.
11035 : *
11036 : * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
11037 : */
11038 0 : grow = ae_minreal((double)(1), 1/ae_maxreal(xbnd, smlnum, _state), _state);
11039 0 : j = jfirst;
11040 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
11041 : {
11042 :
11043 : /*
11044 : * Exit the loop if the growth factor is too small.
11045 : */
11046 0 : if( ae_fp_less_eq(grow,smlnum) )
11047 : {
11048 0 : break;
11049 : }
11050 :
11051 : /*
11052 : * G(j) = G(j-1)*( 1 + CNORM(j) )
11053 : */
11054 0 : grow = grow*(1/(1+cnorm->ptr.p_double[j]));
11055 0 : j = j+jinc;
11056 : }
11057 : }
11058 : }
11059 : }
11060 : else
11061 : {
11062 :
11063 : /*
11064 : * Compute the growth in A' * x = b.
11065 : */
11066 0 : if( upper )
11067 : {
11068 0 : jfirst = 1;
11069 0 : jlast = n;
11070 0 : jinc = 1;
11071 : }
11072 : else
11073 : {
11074 0 : jfirst = n;
11075 0 : jlast = 1;
11076 0 : jinc = -1;
11077 : }
11078 0 : if( ae_fp_neq(tscal,(double)(1)) )
11079 : {
11080 0 : grow = (double)(0);
11081 : }
11082 : else
11083 : {
11084 0 : if( nounit )
11085 : {
11086 :
11087 : /*
11088 : * A is non-unit triangular.
11089 : *
11090 : * Compute GROW = 1/G(j) and XBND = 1/M(j).
11091 : * Initially, M(0) = max{x(i), i=1,...,n}.
11092 : */
11093 0 : grow = 1/ae_maxreal(xbnd, smlnum, _state);
11094 0 : xbnd = grow;
11095 0 : j = jfirst;
11096 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
11097 : {
11098 :
11099 : /*
11100 : * Exit the loop if the growth factor is too small.
11101 : */
11102 0 : if( ae_fp_less_eq(grow,smlnum) )
11103 : {
11104 0 : break;
11105 : }
11106 :
11107 : /*
11108 : * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
11109 : */
11110 0 : xj = 1+cnorm->ptr.p_double[j];
11111 0 : grow = ae_minreal(grow, xbnd/xj, _state);
11112 :
11113 : /*
11114 : * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
11115 : */
11116 0 : tjj = ae_fabs(a->ptr.pp_double[j][j], _state);
11117 0 : if( ae_fp_greater(xj,tjj) )
11118 : {
11119 0 : xbnd = xbnd*(tjj/xj);
11120 : }
11121 0 : if( j==jlast )
11122 : {
11123 0 : grow = ae_minreal(grow, xbnd, _state);
11124 : }
11125 0 : j = j+jinc;
11126 : }
11127 : }
11128 : else
11129 : {
11130 :
11131 : /*
11132 : * A is unit triangular.
11133 : *
11134 : * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
11135 : */
11136 0 : grow = ae_minreal((double)(1), 1/ae_maxreal(xbnd, smlnum, _state), _state);
11137 0 : j = jfirst;
11138 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
11139 : {
11140 :
11141 : /*
11142 : * Exit the loop if the growth factor is too small.
11143 : */
11144 0 : if( ae_fp_less_eq(grow,smlnum) )
11145 : {
11146 0 : break;
11147 : }
11148 :
11149 : /*
11150 : * G(j) = ( 1 + CNORM(j) )*G(j-1)
11151 : */
11152 0 : xj = 1+cnorm->ptr.p_double[j];
11153 0 : grow = grow/xj;
11154 0 : j = j+jinc;
11155 : }
11156 : }
11157 : }
11158 : }
11159 0 : if( ae_fp_greater(grow*tscal,smlnum) )
11160 : {
11161 :
11162 : /*
11163 : * Use the Level 2 BLAS solve if the reciprocal of the bound on
11164 : * elements of X is not too small.
11165 : */
11166 0 : if( (upper&¬ran)||(!upper&&!notran) )
11167 : {
11168 0 : if( nounit )
11169 : {
11170 0 : vd = a->ptr.pp_double[n][n];
11171 : }
11172 : else
11173 : {
11174 0 : vd = (double)(1);
11175 : }
11176 0 : x->ptr.p_double[n] = x->ptr.p_double[n]/vd;
11177 0 : for(i=n-1; i>=1; i--)
11178 : {
11179 0 : ip1 = i+1;
11180 0 : if( upper )
11181 : {
11182 0 : v = ae_v_dotproduct(&a->ptr.pp_double[i][ip1], 1, &x->ptr.p_double[ip1], 1, ae_v_len(ip1,n));
11183 : }
11184 : else
11185 : {
11186 0 : v = ae_v_dotproduct(&a->ptr.pp_double[ip1][i], a->stride, &x->ptr.p_double[ip1], 1, ae_v_len(ip1,n));
11187 : }
11188 0 : if( nounit )
11189 : {
11190 0 : vd = a->ptr.pp_double[i][i];
11191 : }
11192 : else
11193 : {
11194 0 : vd = (double)(1);
11195 : }
11196 0 : x->ptr.p_double[i] = (x->ptr.p_double[i]-v)/vd;
11197 : }
11198 : }
11199 : else
11200 : {
11201 0 : if( nounit )
11202 : {
11203 0 : vd = a->ptr.pp_double[1][1];
11204 : }
11205 : else
11206 : {
11207 0 : vd = (double)(1);
11208 : }
11209 0 : x->ptr.p_double[1] = x->ptr.p_double[1]/vd;
11210 0 : for(i=2; i<=n; i++)
11211 : {
11212 0 : im1 = i-1;
11213 0 : if( upper )
11214 : {
11215 0 : v = ae_v_dotproduct(&a->ptr.pp_double[1][i], a->stride, &x->ptr.p_double[1], 1, ae_v_len(1,im1));
11216 : }
11217 : else
11218 : {
11219 0 : v = ae_v_dotproduct(&a->ptr.pp_double[i][1], 1, &x->ptr.p_double[1], 1, ae_v_len(1,im1));
11220 : }
11221 0 : if( nounit )
11222 : {
11223 0 : vd = a->ptr.pp_double[i][i];
11224 : }
11225 : else
11226 : {
11227 0 : vd = (double)(1);
11228 : }
11229 0 : x->ptr.p_double[i] = (x->ptr.p_double[i]-v)/vd;
11230 : }
11231 : }
11232 : }
11233 : else
11234 : {
11235 :
11236 : /*
11237 : * Use a Level 1 BLAS solve, scaling intermediate results.
11238 : */
11239 0 : if( ae_fp_greater(xmax,bignum) )
11240 : {
11241 :
11242 : /*
11243 : * Scale X so that its components are less than or equal to
11244 : * BIGNUM in absolute value.
11245 : */
11246 0 : *s = bignum/xmax;
11247 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), *s);
11248 0 : xmax = bignum;
11249 : }
11250 0 : if( notran )
11251 : {
11252 :
11253 : /*
11254 : * Solve A * x = b
11255 : */
11256 0 : j = jfirst;
11257 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
11258 : {
11259 :
11260 : /*
11261 : * Compute x(j) = b(j) / A(j,j), scaling x if necessary.
11262 : */
11263 0 : xj = ae_fabs(x->ptr.p_double[j], _state);
11264 0 : flg = 0;
11265 0 : if( nounit )
11266 : {
11267 0 : tjjs = a->ptr.pp_double[j][j]*tscal;
11268 : }
11269 : else
11270 : {
11271 0 : tjjs = tscal;
11272 0 : if( ae_fp_eq(tscal,(double)(1)) )
11273 : {
11274 0 : flg = 100;
11275 : }
11276 : }
11277 0 : if( flg!=100 )
11278 : {
11279 0 : tjj = ae_fabs(tjjs, _state);
11280 0 : if( ae_fp_greater(tjj,smlnum) )
11281 : {
11282 :
11283 : /*
11284 : * abs(A(j,j)) > SMLNUM:
11285 : */
11286 0 : if( ae_fp_less(tjj,(double)(1)) )
11287 : {
11288 0 : if( ae_fp_greater(xj,tjj*bignum) )
11289 : {
11290 :
11291 : /*
11292 : * Scale x by 1/b(j).
11293 : */
11294 0 : rec = 1/xj;
11295 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11296 0 : *s = *s*rec;
11297 0 : xmax = xmax*rec;
11298 : }
11299 : }
11300 0 : x->ptr.p_double[j] = x->ptr.p_double[j]/tjjs;
11301 0 : xj = ae_fabs(x->ptr.p_double[j], _state);
11302 : }
11303 : else
11304 : {
11305 0 : if( ae_fp_greater(tjj,(double)(0)) )
11306 : {
11307 :
11308 : /*
11309 : * 0 < abs(A(j,j)) <= SMLNUM:
11310 : */
11311 0 : if( ae_fp_greater(xj,tjj*bignum) )
11312 : {
11313 :
11314 : /*
11315 : * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
11316 : * to avoid overflow when dividing by A(j,j).
11317 : */
11318 0 : rec = tjj*bignum/xj;
11319 0 : if( ae_fp_greater(cnorm->ptr.p_double[j],(double)(1)) )
11320 : {
11321 :
11322 : /*
11323 : * Scale by 1/CNORM(j) to avoid overflow when
11324 : * multiplying x(j) times column j.
11325 : */
11326 0 : rec = rec/cnorm->ptr.p_double[j];
11327 : }
11328 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11329 0 : *s = *s*rec;
11330 0 : xmax = xmax*rec;
11331 : }
11332 0 : x->ptr.p_double[j] = x->ptr.p_double[j]/tjjs;
11333 0 : xj = ae_fabs(x->ptr.p_double[j], _state);
11334 : }
11335 : else
11336 : {
11337 :
11338 : /*
11339 : * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
11340 : * scale = 0, and compute a solution to A*x = 0.
11341 : */
11342 0 : for(i=1; i<=n; i++)
11343 : {
11344 0 : x->ptr.p_double[i] = (double)(0);
11345 : }
11346 0 : x->ptr.p_double[j] = (double)(1);
11347 0 : xj = (double)(1);
11348 0 : *s = (double)(0);
11349 0 : xmax = (double)(0);
11350 : }
11351 : }
11352 : }
11353 :
11354 : /*
11355 : * Scale x if necessary to avoid overflow when adding a
11356 : * multiple of column j of A.
11357 : */
11358 0 : if( ae_fp_greater(xj,(double)(1)) )
11359 : {
11360 0 : rec = 1/xj;
11361 0 : if( ae_fp_greater(cnorm->ptr.p_double[j],(bignum-xmax)*rec) )
11362 : {
11363 :
11364 : /*
11365 : * Scale x by 1/(2*abs(x(j))).
11366 : */
11367 0 : rec = rec*0.5;
11368 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11369 0 : *s = *s*rec;
11370 : }
11371 : }
11372 : else
11373 : {
11374 0 : if( ae_fp_greater(xj*cnorm->ptr.p_double[j],bignum-xmax) )
11375 : {
11376 :
11377 : /*
11378 : * Scale x by 1/2.
11379 : */
11380 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), 0.5);
11381 0 : *s = *s*0.5;
11382 : }
11383 : }
11384 0 : if( upper )
11385 : {
11386 0 : if( j>1 )
11387 : {
11388 :
11389 : /*
11390 : * Compute the update
11391 : * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
11392 : */
11393 0 : v = x->ptr.p_double[j]*tscal;
11394 0 : jm1 = j-1;
11395 0 : ae_v_subd(&x->ptr.p_double[1], 1, &a->ptr.pp_double[1][j], a->stride, ae_v_len(1,jm1), v);
11396 0 : i = 1;
11397 0 : for(k=2; k<=j-1; k++)
11398 : {
11399 0 : if( ae_fp_greater(ae_fabs(x->ptr.p_double[k], _state),ae_fabs(x->ptr.p_double[i], _state)) )
11400 : {
11401 0 : i = k;
11402 : }
11403 : }
11404 0 : xmax = ae_fabs(x->ptr.p_double[i], _state);
11405 : }
11406 : }
11407 : else
11408 : {
11409 0 : if( j<n )
11410 : {
11411 :
11412 : /*
11413 : * Compute the update
11414 : * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
11415 : */
11416 0 : jp1 = j+1;
11417 0 : v = x->ptr.p_double[j]*tscal;
11418 0 : ae_v_subd(&x->ptr.p_double[jp1], 1, &a->ptr.pp_double[jp1][j], a->stride, ae_v_len(jp1,n), v);
11419 0 : i = j+1;
11420 0 : for(k=j+2; k<=n; k++)
11421 : {
11422 0 : if( ae_fp_greater(ae_fabs(x->ptr.p_double[k], _state),ae_fabs(x->ptr.p_double[i], _state)) )
11423 : {
11424 0 : i = k;
11425 : }
11426 : }
11427 0 : xmax = ae_fabs(x->ptr.p_double[i], _state);
11428 : }
11429 : }
11430 0 : j = j+jinc;
11431 : }
11432 : }
11433 : else
11434 : {
11435 :
11436 : /*
11437 : * Solve A' * x = b
11438 : */
11439 0 : j = jfirst;
11440 0 : while((jinc>0&&j<=jlast)||(jinc<0&&j>=jlast))
11441 : {
11442 :
11443 : /*
11444 : * Compute x(j) = b(j) - sum A(k,j)*x(k).
11445 : * k<>j
11446 : */
11447 0 : xj = ae_fabs(x->ptr.p_double[j], _state);
11448 0 : uscal = tscal;
11449 0 : rec = 1/ae_maxreal(xmax, (double)(1), _state);
11450 0 : if( ae_fp_greater(cnorm->ptr.p_double[j],(bignum-xj)*rec) )
11451 : {
11452 :
11453 : /*
11454 : * If x(j) could overflow, scale x by 1/(2*XMAX).
11455 : */
11456 0 : rec = rec*0.5;
11457 0 : if( nounit )
11458 : {
11459 0 : tjjs = a->ptr.pp_double[j][j]*tscal;
11460 : }
11461 : else
11462 : {
11463 0 : tjjs = tscal;
11464 : }
11465 0 : tjj = ae_fabs(tjjs, _state);
11466 0 : if( ae_fp_greater(tjj,(double)(1)) )
11467 : {
11468 :
11469 : /*
11470 : * Divide by A(j,j) when scaling x if A(j,j) > 1.
11471 : */
11472 0 : rec = ae_minreal((double)(1), rec*tjj, _state);
11473 0 : uscal = uscal/tjjs;
11474 : }
11475 0 : if( ae_fp_less(rec,(double)(1)) )
11476 : {
11477 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11478 0 : *s = *s*rec;
11479 0 : xmax = xmax*rec;
11480 : }
11481 : }
11482 0 : sumj = (double)(0);
11483 0 : if( ae_fp_eq(uscal,(double)(1)) )
11484 : {
11485 :
11486 : /*
11487 : * If the scaling needed for A in the dot product is 1,
11488 : * call DDOT to perform the dot product.
11489 : */
11490 0 : if( upper )
11491 : {
11492 0 : if( j>1 )
11493 : {
11494 0 : jm1 = j-1;
11495 0 : sumj = ae_v_dotproduct(&a->ptr.pp_double[1][j], a->stride, &x->ptr.p_double[1], 1, ae_v_len(1,jm1));
11496 : }
11497 : else
11498 : {
11499 0 : sumj = (double)(0);
11500 : }
11501 : }
11502 : else
11503 : {
11504 0 : if( j<n )
11505 : {
11506 0 : jp1 = j+1;
11507 0 : sumj = ae_v_dotproduct(&a->ptr.pp_double[jp1][j], a->stride, &x->ptr.p_double[jp1], 1, ae_v_len(jp1,n));
11508 : }
11509 : }
11510 : }
11511 : else
11512 : {
11513 :
11514 : /*
11515 : * Otherwise, use in-line code for the dot product.
11516 : */
11517 0 : if( upper )
11518 : {
11519 0 : for(i=1; i<=j-1; i++)
11520 : {
11521 0 : v = a->ptr.pp_double[i][j]*uscal;
11522 0 : sumj = sumj+v*x->ptr.p_double[i];
11523 : }
11524 : }
11525 : else
11526 : {
11527 0 : if( j<n )
11528 : {
11529 0 : for(i=j+1; i<=n; i++)
11530 : {
11531 0 : v = a->ptr.pp_double[i][j]*uscal;
11532 0 : sumj = sumj+v*x->ptr.p_double[i];
11533 : }
11534 : }
11535 : }
11536 : }
11537 0 : if( ae_fp_eq(uscal,tscal) )
11538 : {
11539 :
11540 : /*
11541 : * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
11542 : * was not used to scale the dotproduct.
11543 : */
11544 0 : x->ptr.p_double[j] = x->ptr.p_double[j]-sumj;
11545 0 : xj = ae_fabs(x->ptr.p_double[j], _state);
11546 0 : flg = 0;
11547 0 : if( nounit )
11548 : {
11549 0 : tjjs = a->ptr.pp_double[j][j]*tscal;
11550 : }
11551 : else
11552 : {
11553 0 : tjjs = tscal;
11554 0 : if( ae_fp_eq(tscal,(double)(1)) )
11555 : {
11556 0 : flg = 150;
11557 : }
11558 : }
11559 :
11560 : /*
11561 : * Compute x(j) = x(j) / A(j,j), scaling if necessary.
11562 : */
11563 0 : if( flg!=150 )
11564 : {
11565 0 : tjj = ae_fabs(tjjs, _state);
11566 0 : if( ae_fp_greater(tjj,smlnum) )
11567 : {
11568 :
11569 : /*
11570 : * abs(A(j,j)) > SMLNUM:
11571 : */
11572 0 : if( ae_fp_less(tjj,(double)(1)) )
11573 : {
11574 0 : if( ae_fp_greater(xj,tjj*bignum) )
11575 : {
11576 :
11577 : /*
11578 : * Scale X by 1/abs(x(j)).
11579 : */
11580 0 : rec = 1/xj;
11581 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11582 0 : *s = *s*rec;
11583 0 : xmax = xmax*rec;
11584 : }
11585 : }
11586 0 : x->ptr.p_double[j] = x->ptr.p_double[j]/tjjs;
11587 : }
11588 : else
11589 : {
11590 0 : if( ae_fp_greater(tjj,(double)(0)) )
11591 : {
11592 :
11593 : /*
11594 : * 0 < abs(A(j,j)) <= SMLNUM:
11595 : */
11596 0 : if( ae_fp_greater(xj,tjj*bignum) )
11597 : {
11598 :
11599 : /*
11600 : * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
11601 : */
11602 0 : rec = tjj*bignum/xj;
11603 0 : ae_v_muld(&x->ptr.p_double[1], 1, ae_v_len(1,n), rec);
11604 0 : *s = *s*rec;
11605 0 : xmax = xmax*rec;
11606 : }
11607 0 : x->ptr.p_double[j] = x->ptr.p_double[j]/tjjs;
11608 : }
11609 : else
11610 : {
11611 :
11612 : /*
11613 : * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
11614 : * scale = 0, and compute a solution to A'*x = 0.
11615 : */
11616 0 : for(i=1; i<=n; i++)
11617 : {
11618 0 : x->ptr.p_double[i] = (double)(0);
11619 : }
11620 0 : x->ptr.p_double[j] = (double)(1);
11621 0 : *s = (double)(0);
11622 0 : xmax = (double)(0);
11623 : }
11624 : }
11625 : }
11626 : }
11627 : else
11628 : {
11629 :
11630 : /*
11631 : * Compute x(j) := x(j) / A(j,j) - sumj if the dot
11632 : * product has already been divided by 1/A(j,j).
11633 : */
11634 0 : x->ptr.p_double[j] = x->ptr.p_double[j]/tjjs-sumj;
11635 : }
11636 0 : xmax = ae_maxreal(xmax, ae_fabs(x->ptr.p_double[j], _state), _state);
11637 0 : j = j+jinc;
11638 : }
11639 : }
11640 0 : *s = *s/tscal;
11641 : }
11642 :
11643 : /*
11644 : * Scale the column norms by 1/TSCAL for return.
11645 : */
11646 0 : if( ae_fp_neq(tscal,(double)(1)) )
11647 : {
11648 0 : v = 1/tscal;
11649 0 : ae_v_muld(&cnorm->ptr.p_double[1], 1, ae_v_len(1,n), v);
11650 : }
11651 : }
11652 :
11653 :
11654 : #endif
11655 : #if defined(AE_COMPILE_SAFESOLVE) || !defined(AE_PARTIAL_BUILD)
11656 :
11657 :
11658 : /*************************************************************************
11659 : Real implementation of CMatrixScaledTRSafeSolve
11660 :
11661 : -- ALGLIB routine --
11662 : 21.01.2010
11663 : Bochkanov Sergey
11664 : *************************************************************************/
11665 0 : ae_bool rmatrixscaledtrsafesolve(/* Real */ ae_matrix* a,
11666 : double sa,
11667 : ae_int_t n,
11668 : /* Real */ ae_vector* x,
11669 : ae_bool isupper,
11670 : ae_int_t trans,
11671 : ae_bool isunit,
11672 : double maxgrowth,
11673 : ae_state *_state)
11674 : {
11675 : ae_frame _frame_block;
11676 : double lnmax;
11677 : double nrmb;
11678 : double nrmx;
11679 : ae_int_t i;
11680 : ae_complex alpha;
11681 : ae_complex beta;
11682 : double vr;
11683 : ae_complex cx;
11684 : ae_vector tmp;
11685 : ae_bool result;
11686 :
11687 0 : ae_frame_make(_state, &_frame_block);
11688 0 : memset(&tmp, 0, sizeof(tmp));
11689 0 : ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
11690 :
11691 0 : ae_assert(n>0, "RMatrixTRSafeSolve: incorrect N!", _state);
11692 0 : ae_assert(trans==0||trans==1, "RMatrixTRSafeSolve: incorrect Trans!", _state);
11693 0 : result = ae_true;
11694 0 : lnmax = ae_log(ae_maxrealnumber, _state);
11695 :
11696 : /*
11697 : * Quick return if possible
11698 : */
11699 0 : if( n<=0 )
11700 : {
11701 0 : ae_frame_leave(_state);
11702 0 : return result;
11703 : }
11704 :
11705 : /*
11706 : * Load norms: right part and X
11707 : */
11708 0 : nrmb = (double)(0);
11709 0 : for(i=0; i<=n-1; i++)
11710 : {
11711 0 : nrmb = ae_maxreal(nrmb, ae_fabs(x->ptr.p_double[i], _state), _state);
11712 : }
11713 0 : nrmx = (double)(0);
11714 :
11715 : /*
11716 : * Solve
11717 : */
11718 0 : ae_vector_set_length(&tmp, n, _state);
11719 0 : result = ae_true;
11720 0 : if( isupper&&trans==0 )
11721 : {
11722 :
11723 : /*
11724 : * U*x = b
11725 : */
11726 0 : for(i=n-1; i>=0; i--)
11727 : {
11728 :
11729 : /*
11730 : * Task is reduced to alpha*x[i] = beta
11731 : */
11732 0 : if( isunit )
11733 : {
11734 0 : alpha = ae_complex_from_d(sa);
11735 : }
11736 : else
11737 : {
11738 0 : alpha = ae_complex_from_d(a->ptr.pp_double[i][i]*sa);
11739 : }
11740 0 : if( i<n-1 )
11741 : {
11742 0 : ae_v_moved(&tmp.ptr.p_double[i+1], 1, &a->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sa);
11743 0 : vr = ae_v_dotproduct(&tmp.ptr.p_double[i+1], 1, &x->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1));
11744 0 : beta = ae_complex_from_d(x->ptr.p_double[i]-vr);
11745 : }
11746 : else
11747 : {
11748 0 : beta = ae_complex_from_d(x->ptr.p_double[i]);
11749 : }
11750 :
11751 : /*
11752 : * solve alpha*x[i] = beta
11753 : */
11754 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &cx, _state);
11755 0 : if( !result )
11756 : {
11757 0 : ae_frame_leave(_state);
11758 0 : return result;
11759 : }
11760 0 : x->ptr.p_double[i] = cx.x;
11761 : }
11762 0 : ae_frame_leave(_state);
11763 0 : return result;
11764 : }
11765 0 : if( !isupper&&trans==0 )
11766 : {
11767 :
11768 : /*
11769 : * L*x = b
11770 : */
11771 0 : for(i=0; i<=n-1; i++)
11772 : {
11773 :
11774 : /*
11775 : * Task is reduced to alpha*x[i] = beta
11776 : */
11777 0 : if( isunit )
11778 : {
11779 0 : alpha = ae_complex_from_d(sa);
11780 : }
11781 : else
11782 : {
11783 0 : alpha = ae_complex_from_d(a->ptr.pp_double[i][i]*sa);
11784 : }
11785 0 : if( i>0 )
11786 : {
11787 0 : ae_v_moved(&tmp.ptr.p_double[0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sa);
11788 0 : vr = ae_v_dotproduct(&tmp.ptr.p_double[0], 1, &x->ptr.p_double[0], 1, ae_v_len(0,i-1));
11789 0 : beta = ae_complex_from_d(x->ptr.p_double[i]-vr);
11790 : }
11791 : else
11792 : {
11793 0 : beta = ae_complex_from_d(x->ptr.p_double[i]);
11794 : }
11795 :
11796 : /*
11797 : * solve alpha*x[i] = beta
11798 : */
11799 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &cx, _state);
11800 0 : if( !result )
11801 : {
11802 0 : ae_frame_leave(_state);
11803 0 : return result;
11804 : }
11805 0 : x->ptr.p_double[i] = cx.x;
11806 : }
11807 0 : ae_frame_leave(_state);
11808 0 : return result;
11809 : }
11810 0 : if( isupper&&trans==1 )
11811 : {
11812 :
11813 : /*
11814 : * U^T*x = b
11815 : */
11816 0 : for(i=0; i<=n-1; i++)
11817 : {
11818 :
11819 : /*
11820 : * Task is reduced to alpha*x[i] = beta
11821 : */
11822 0 : if( isunit )
11823 : {
11824 0 : alpha = ae_complex_from_d(sa);
11825 : }
11826 : else
11827 : {
11828 0 : alpha = ae_complex_from_d(a->ptr.pp_double[i][i]*sa);
11829 : }
11830 0 : beta = ae_complex_from_d(x->ptr.p_double[i]);
11831 :
11832 : /*
11833 : * solve alpha*x[i] = beta
11834 : */
11835 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &cx, _state);
11836 0 : if( !result )
11837 : {
11838 0 : ae_frame_leave(_state);
11839 0 : return result;
11840 : }
11841 0 : x->ptr.p_double[i] = cx.x;
11842 :
11843 : /*
11844 : * update the rest of right part
11845 : */
11846 0 : if( i<n-1 )
11847 : {
11848 0 : vr = cx.x;
11849 0 : ae_v_moved(&tmp.ptr.p_double[i+1], 1, &a->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sa);
11850 0 : ae_v_subd(&x->ptr.p_double[i+1], 1, &tmp.ptr.p_double[i+1], 1, ae_v_len(i+1,n-1), vr);
11851 : }
11852 : }
11853 0 : ae_frame_leave(_state);
11854 0 : return result;
11855 : }
11856 0 : if( !isupper&&trans==1 )
11857 : {
11858 :
11859 : /*
11860 : * L^T*x = b
11861 : */
11862 0 : for(i=n-1; i>=0; i--)
11863 : {
11864 :
11865 : /*
11866 : * Task is reduced to alpha*x[i] = beta
11867 : */
11868 0 : if( isunit )
11869 : {
11870 0 : alpha = ae_complex_from_d(sa);
11871 : }
11872 : else
11873 : {
11874 0 : alpha = ae_complex_from_d(a->ptr.pp_double[i][i]*sa);
11875 : }
11876 0 : beta = ae_complex_from_d(x->ptr.p_double[i]);
11877 :
11878 : /*
11879 : * solve alpha*x[i] = beta
11880 : */
11881 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &cx, _state);
11882 0 : if( !result )
11883 : {
11884 0 : ae_frame_leave(_state);
11885 0 : return result;
11886 : }
11887 0 : x->ptr.p_double[i] = cx.x;
11888 :
11889 : /*
11890 : * update the rest of right part
11891 : */
11892 0 : if( i>0 )
11893 : {
11894 0 : vr = cx.x;
11895 0 : ae_v_moved(&tmp.ptr.p_double[0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sa);
11896 0 : ae_v_subd(&x->ptr.p_double[0], 1, &tmp.ptr.p_double[0], 1, ae_v_len(0,i-1), vr);
11897 : }
11898 : }
11899 0 : ae_frame_leave(_state);
11900 0 : return result;
11901 : }
11902 0 : result = ae_false;
11903 0 : ae_frame_leave(_state);
11904 0 : return result;
11905 : }
11906 :
11907 :
11908 : /*************************************************************************
11909 : Internal subroutine for safe solution of
11910 :
11911 : SA*op(A)=b
11912 :
11913 : where A is NxN upper/lower triangular/unitriangular matrix, op(A) is
11914 : either identity transform, transposition or Hermitian transposition, SA is
11915 : a scaling factor such that max(|SA*A[i,j]|) is close to 1.0 in magnutude.
11916 :
11917 : This subroutine limits relative growth of solution (in inf-norm) by
11918 : MaxGrowth, returning False if growth exceeds MaxGrowth. Degenerate or
11919 : near-degenerate matrices are handled correctly (False is returned) as long
11920 : as MaxGrowth is significantly less than MaxRealNumber/norm(b).
11921 :
11922 : -- ALGLIB routine --
11923 : 21.01.2010
11924 : Bochkanov Sergey
11925 : *************************************************************************/
11926 0 : ae_bool cmatrixscaledtrsafesolve(/* Complex */ ae_matrix* a,
11927 : double sa,
11928 : ae_int_t n,
11929 : /* Complex */ ae_vector* x,
11930 : ae_bool isupper,
11931 : ae_int_t trans,
11932 : ae_bool isunit,
11933 : double maxgrowth,
11934 : ae_state *_state)
11935 : {
11936 : ae_frame _frame_block;
11937 : double lnmax;
11938 : double nrmb;
11939 : double nrmx;
11940 : ae_int_t i;
11941 : ae_complex alpha;
11942 : ae_complex beta;
11943 : ae_complex vc;
11944 : ae_vector tmp;
11945 : ae_bool result;
11946 :
11947 0 : ae_frame_make(_state, &_frame_block);
11948 0 : memset(&tmp, 0, sizeof(tmp));
11949 0 : ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
11950 :
11951 0 : ae_assert(n>0, "CMatrixTRSafeSolve: incorrect N!", _state);
11952 0 : ae_assert((trans==0||trans==1)||trans==2, "CMatrixTRSafeSolve: incorrect Trans!", _state);
11953 0 : result = ae_true;
11954 0 : lnmax = ae_log(ae_maxrealnumber, _state);
11955 :
11956 : /*
11957 : * Quick return if possible
11958 : */
11959 0 : if( n<=0 )
11960 : {
11961 0 : ae_frame_leave(_state);
11962 0 : return result;
11963 : }
11964 :
11965 : /*
11966 : * Load norms: right part and X
11967 : */
11968 0 : nrmb = (double)(0);
11969 0 : for(i=0; i<=n-1; i++)
11970 : {
11971 0 : nrmb = ae_maxreal(nrmb, ae_c_abs(x->ptr.p_complex[i], _state), _state);
11972 : }
11973 0 : nrmx = (double)(0);
11974 :
11975 : /*
11976 : * Solve
11977 : */
11978 0 : ae_vector_set_length(&tmp, n, _state);
11979 0 : result = ae_true;
11980 0 : if( isupper&&trans==0 )
11981 : {
11982 :
11983 : /*
11984 : * U*x = b
11985 : */
11986 0 : for(i=n-1; i>=0; i--)
11987 : {
11988 :
11989 : /*
11990 : * Task is reduced to alpha*x[i] = beta
11991 : */
11992 0 : if( isunit )
11993 : {
11994 0 : alpha = ae_complex_from_d(sa);
11995 : }
11996 : else
11997 : {
11998 0 : alpha = ae_c_mul_d(a->ptr.pp_complex[i][i],sa);
11999 : }
12000 0 : if( i<n-1 )
12001 : {
12002 0 : ae_v_cmoved(&tmp.ptr.p_complex[i+1], 1, &a->ptr.pp_complex[i][i+1], 1, "N", ae_v_len(i+1,n-1), sa);
12003 0 : vc = ae_v_cdotproduct(&tmp.ptr.p_complex[i+1], 1, "N", &x->ptr.p_complex[i+1], 1, "N", ae_v_len(i+1,n-1));
12004 0 : beta = ae_c_sub(x->ptr.p_complex[i],vc);
12005 : }
12006 : else
12007 : {
12008 0 : beta = x->ptr.p_complex[i];
12009 : }
12010 :
12011 : /*
12012 : * solve alpha*x[i] = beta
12013 : */
12014 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12015 0 : if( !result )
12016 : {
12017 0 : ae_frame_leave(_state);
12018 0 : return result;
12019 : }
12020 0 : x->ptr.p_complex[i] = vc;
12021 : }
12022 0 : ae_frame_leave(_state);
12023 0 : return result;
12024 : }
12025 0 : if( !isupper&&trans==0 )
12026 : {
12027 :
12028 : /*
12029 : * L*x = b
12030 : */
12031 0 : for(i=0; i<=n-1; i++)
12032 : {
12033 :
12034 : /*
12035 : * Task is reduced to alpha*x[i] = beta
12036 : */
12037 0 : if( isunit )
12038 : {
12039 0 : alpha = ae_complex_from_d(sa);
12040 : }
12041 : else
12042 : {
12043 0 : alpha = ae_c_mul_d(a->ptr.pp_complex[i][i],sa);
12044 : }
12045 0 : if( i>0 )
12046 : {
12047 0 : ae_v_cmoved(&tmp.ptr.p_complex[0], 1, &a->ptr.pp_complex[i][0], 1, "N", ae_v_len(0,i-1), sa);
12048 0 : vc = ae_v_cdotproduct(&tmp.ptr.p_complex[0], 1, "N", &x->ptr.p_complex[0], 1, "N", ae_v_len(0,i-1));
12049 0 : beta = ae_c_sub(x->ptr.p_complex[i],vc);
12050 : }
12051 : else
12052 : {
12053 0 : beta = x->ptr.p_complex[i];
12054 : }
12055 :
12056 : /*
12057 : * solve alpha*x[i] = beta
12058 : */
12059 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12060 0 : if( !result )
12061 : {
12062 0 : ae_frame_leave(_state);
12063 0 : return result;
12064 : }
12065 0 : x->ptr.p_complex[i] = vc;
12066 : }
12067 0 : ae_frame_leave(_state);
12068 0 : return result;
12069 : }
12070 0 : if( isupper&&trans==1 )
12071 : {
12072 :
12073 : /*
12074 : * U^T*x = b
12075 : */
12076 0 : for(i=0; i<=n-1; i++)
12077 : {
12078 :
12079 : /*
12080 : * Task is reduced to alpha*x[i] = beta
12081 : */
12082 0 : if( isunit )
12083 : {
12084 0 : alpha = ae_complex_from_d(sa);
12085 : }
12086 : else
12087 : {
12088 0 : alpha = ae_c_mul_d(a->ptr.pp_complex[i][i],sa);
12089 : }
12090 0 : beta = x->ptr.p_complex[i];
12091 :
12092 : /*
12093 : * solve alpha*x[i] = beta
12094 : */
12095 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12096 0 : if( !result )
12097 : {
12098 0 : ae_frame_leave(_state);
12099 0 : return result;
12100 : }
12101 0 : x->ptr.p_complex[i] = vc;
12102 :
12103 : /*
12104 : * update the rest of right part
12105 : */
12106 0 : if( i<n-1 )
12107 : {
12108 0 : ae_v_cmoved(&tmp.ptr.p_complex[i+1], 1, &a->ptr.pp_complex[i][i+1], 1, "N", ae_v_len(i+1,n-1), sa);
12109 0 : ae_v_csubc(&x->ptr.p_complex[i+1], 1, &tmp.ptr.p_complex[i+1], 1, "N", ae_v_len(i+1,n-1), vc);
12110 : }
12111 : }
12112 0 : ae_frame_leave(_state);
12113 0 : return result;
12114 : }
12115 0 : if( !isupper&&trans==1 )
12116 : {
12117 :
12118 : /*
12119 : * L^T*x = b
12120 : */
12121 0 : for(i=n-1; i>=0; i--)
12122 : {
12123 :
12124 : /*
12125 : * Task is reduced to alpha*x[i] = beta
12126 : */
12127 0 : if( isunit )
12128 : {
12129 0 : alpha = ae_complex_from_d(sa);
12130 : }
12131 : else
12132 : {
12133 0 : alpha = ae_c_mul_d(a->ptr.pp_complex[i][i],sa);
12134 : }
12135 0 : beta = x->ptr.p_complex[i];
12136 :
12137 : /*
12138 : * solve alpha*x[i] = beta
12139 : */
12140 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12141 0 : if( !result )
12142 : {
12143 0 : ae_frame_leave(_state);
12144 0 : return result;
12145 : }
12146 0 : x->ptr.p_complex[i] = vc;
12147 :
12148 : /*
12149 : * update the rest of right part
12150 : */
12151 0 : if( i>0 )
12152 : {
12153 0 : ae_v_cmoved(&tmp.ptr.p_complex[0], 1, &a->ptr.pp_complex[i][0], 1, "N", ae_v_len(0,i-1), sa);
12154 0 : ae_v_csubc(&x->ptr.p_complex[0], 1, &tmp.ptr.p_complex[0], 1, "N", ae_v_len(0,i-1), vc);
12155 : }
12156 : }
12157 0 : ae_frame_leave(_state);
12158 0 : return result;
12159 : }
12160 0 : if( isupper&&trans==2 )
12161 : {
12162 :
12163 : /*
12164 : * U^H*x = b
12165 : */
12166 0 : for(i=0; i<=n-1; i++)
12167 : {
12168 :
12169 : /*
12170 : * Task is reduced to alpha*x[i] = beta
12171 : */
12172 0 : if( isunit )
12173 : {
12174 0 : alpha = ae_complex_from_d(sa);
12175 : }
12176 : else
12177 : {
12178 0 : alpha = ae_c_mul_d(ae_c_conj(a->ptr.pp_complex[i][i], _state),sa);
12179 : }
12180 0 : beta = x->ptr.p_complex[i];
12181 :
12182 : /*
12183 : * solve alpha*x[i] = beta
12184 : */
12185 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12186 0 : if( !result )
12187 : {
12188 0 : ae_frame_leave(_state);
12189 0 : return result;
12190 : }
12191 0 : x->ptr.p_complex[i] = vc;
12192 :
12193 : /*
12194 : * update the rest of right part
12195 : */
12196 0 : if( i<n-1 )
12197 : {
12198 0 : ae_v_cmoved(&tmp.ptr.p_complex[i+1], 1, &a->ptr.pp_complex[i][i+1], 1, "Conj", ae_v_len(i+1,n-1), sa);
12199 0 : ae_v_csubc(&x->ptr.p_complex[i+1], 1, &tmp.ptr.p_complex[i+1], 1, "N", ae_v_len(i+1,n-1), vc);
12200 : }
12201 : }
12202 0 : ae_frame_leave(_state);
12203 0 : return result;
12204 : }
12205 0 : if( !isupper&&trans==2 )
12206 : {
12207 :
12208 : /*
12209 : * L^T*x = b
12210 : */
12211 0 : for(i=n-1; i>=0; i--)
12212 : {
12213 :
12214 : /*
12215 : * Task is reduced to alpha*x[i] = beta
12216 : */
12217 0 : if( isunit )
12218 : {
12219 0 : alpha = ae_complex_from_d(sa);
12220 : }
12221 : else
12222 : {
12223 0 : alpha = ae_c_mul_d(ae_c_conj(a->ptr.pp_complex[i][i], _state),sa);
12224 : }
12225 0 : beta = x->ptr.p_complex[i];
12226 :
12227 : /*
12228 : * solve alpha*x[i] = beta
12229 : */
12230 0 : result = safesolve_cbasicsolveandupdate(alpha, beta, lnmax, nrmb, maxgrowth, &nrmx, &vc, _state);
12231 0 : if( !result )
12232 : {
12233 0 : ae_frame_leave(_state);
12234 0 : return result;
12235 : }
12236 0 : x->ptr.p_complex[i] = vc;
12237 :
12238 : /*
12239 : * update the rest of right part
12240 : */
12241 0 : if( i>0 )
12242 : {
12243 0 : ae_v_cmoved(&tmp.ptr.p_complex[0], 1, &a->ptr.pp_complex[i][0], 1, "Conj", ae_v_len(0,i-1), sa);
12244 0 : ae_v_csubc(&x->ptr.p_complex[0], 1, &tmp.ptr.p_complex[0], 1, "N", ae_v_len(0,i-1), vc);
12245 : }
12246 : }
12247 0 : ae_frame_leave(_state);
12248 0 : return result;
12249 : }
12250 0 : result = ae_false;
12251 0 : ae_frame_leave(_state);
12252 0 : return result;
12253 : }
12254 :
12255 :
12256 : /*************************************************************************
12257 : complex basic solver-updater for reduced linear system
12258 :
12259 : alpha*x[i] = beta
12260 :
12261 : solves this equation and updates it in overlfow-safe manner (keeping track
12262 : of relative growth of solution).
12263 :
12264 : Parameters:
12265 : Alpha - alpha
12266 : Beta - beta
12267 : LnMax - precomputed Ln(MaxRealNumber)
12268 : BNorm - inf-norm of b (right part of original system)
12269 : MaxGrowth- maximum growth of norm(x) relative to norm(b)
12270 : XNorm - inf-norm of other components of X (which are already processed)
12271 : it is updated by CBasicSolveAndUpdate.
12272 : X - solution
12273 :
12274 : -- ALGLIB routine --
12275 : 26.01.2009
12276 : Bochkanov Sergey
12277 : *************************************************************************/
12278 0 : static ae_bool safesolve_cbasicsolveandupdate(ae_complex alpha,
12279 : ae_complex beta,
12280 : double lnmax,
12281 : double bnorm,
12282 : double maxgrowth,
12283 : double* xnorm,
12284 : ae_complex* x,
12285 : ae_state *_state)
12286 : {
12287 : double v;
12288 : ae_bool result;
12289 :
12290 0 : x->x = 0;
12291 0 : x->y = 0;
12292 :
12293 0 : result = ae_false;
12294 0 : if( ae_c_eq_d(alpha,(double)(0)) )
12295 : {
12296 0 : return result;
12297 : }
12298 0 : if( ae_c_neq_d(beta,(double)(0)) )
12299 : {
12300 :
12301 : /*
12302 : * alpha*x[i]=beta
12303 : */
12304 0 : v = ae_log(ae_c_abs(beta, _state), _state)-ae_log(ae_c_abs(alpha, _state), _state);
12305 0 : if( ae_fp_greater(v,lnmax) )
12306 : {
12307 0 : return result;
12308 : }
12309 0 : *x = ae_c_div(beta,alpha);
12310 : }
12311 : else
12312 : {
12313 :
12314 : /*
12315 : * alpha*x[i]=0
12316 : */
12317 0 : *x = ae_complex_from_i(0);
12318 : }
12319 :
12320 : /*
12321 : * update NrmX, test growth limit
12322 : */
12323 0 : *xnorm = ae_maxreal(*xnorm, ae_c_abs(*x, _state), _state);
12324 0 : if( ae_fp_greater(*xnorm,maxgrowth*bnorm) )
12325 : {
12326 0 : return result;
12327 : }
12328 0 : result = ae_true;
12329 0 : return result;
12330 : }
12331 :
12332 :
12333 : #endif
12334 : #if defined(AE_COMPILE_HBLAS) || !defined(AE_PARTIAL_BUILD)
12335 :
12336 :
12337 0 : void hermitianmatrixvectormultiply(/* Complex */ ae_matrix* a,
12338 : ae_bool isupper,
12339 : ae_int_t i1,
12340 : ae_int_t i2,
12341 : /* Complex */ ae_vector* x,
12342 : ae_complex alpha,
12343 : /* Complex */ ae_vector* y,
12344 : ae_state *_state)
12345 : {
12346 : ae_int_t i;
12347 : ae_int_t ba1;
12348 : ae_int_t by1;
12349 : ae_int_t by2;
12350 : ae_int_t bx1;
12351 : ae_int_t bx2;
12352 : ae_int_t n;
12353 : ae_complex v;
12354 :
12355 :
12356 0 : n = i2-i1+1;
12357 0 : if( n<=0 )
12358 : {
12359 0 : return;
12360 : }
12361 :
12362 : /*
12363 : * Let A = L + D + U, where
12364 : * L is strictly lower triangular (main diagonal is zero)
12365 : * D is diagonal
12366 : * U is strictly upper triangular (main diagonal is zero)
12367 : *
12368 : * A*x = L*x + D*x + U*x
12369 : *
12370 : * Calculate D*x first
12371 : */
12372 0 : for(i=i1; i<=i2; i++)
12373 : {
12374 0 : y->ptr.p_complex[i-i1+1] = ae_c_mul(a->ptr.pp_complex[i][i],x->ptr.p_complex[i-i1+1]);
12375 : }
12376 :
12377 : /*
12378 : * Add L*x + U*x
12379 : */
12380 0 : if( isupper )
12381 : {
12382 0 : for(i=i1; i<=i2-1; i++)
12383 : {
12384 :
12385 : /*
12386 : * Add L*x to the result
12387 : */
12388 0 : v = x->ptr.p_complex[i-i1+1];
12389 0 : by1 = i-i1+2;
12390 0 : by2 = n;
12391 0 : ba1 = i+1;
12392 0 : ae_v_caddc(&y->ptr.p_complex[by1], 1, &a->ptr.pp_complex[i][ba1], 1, "Conj", ae_v_len(by1,by2), v);
12393 :
12394 : /*
12395 : * Add U*x to the result
12396 : */
12397 0 : bx1 = i-i1+2;
12398 0 : bx2 = n;
12399 0 : ba1 = i+1;
12400 0 : v = ae_v_cdotproduct(&x->ptr.p_complex[bx1], 1, "N", &a->ptr.pp_complex[i][ba1], 1, "N", ae_v_len(bx1,bx2));
12401 0 : y->ptr.p_complex[i-i1+1] = ae_c_add(y->ptr.p_complex[i-i1+1],v);
12402 : }
12403 : }
12404 : else
12405 : {
12406 0 : for(i=i1+1; i<=i2; i++)
12407 : {
12408 :
12409 : /*
12410 : * Add L*x to the result
12411 : */
12412 0 : bx1 = 1;
12413 0 : bx2 = i-i1;
12414 0 : ba1 = i1;
12415 0 : v = ae_v_cdotproduct(&x->ptr.p_complex[bx1], 1, "N", &a->ptr.pp_complex[i][ba1], 1, "N", ae_v_len(bx1,bx2));
12416 0 : y->ptr.p_complex[i-i1+1] = ae_c_add(y->ptr.p_complex[i-i1+1],v);
12417 :
12418 : /*
12419 : * Add U*x to the result
12420 : */
12421 0 : v = x->ptr.p_complex[i-i1+1];
12422 0 : by1 = 1;
12423 0 : by2 = i-i1;
12424 0 : ba1 = i1;
12425 0 : ae_v_caddc(&y->ptr.p_complex[by1], 1, &a->ptr.pp_complex[i][ba1], 1, "Conj", ae_v_len(by1,by2), v);
12426 : }
12427 : }
12428 0 : ae_v_cmulc(&y->ptr.p_complex[1], 1, ae_v_len(1,n), alpha);
12429 : }
12430 :
12431 :
12432 0 : void hermitianrank2update(/* Complex */ ae_matrix* a,
12433 : ae_bool isupper,
12434 : ae_int_t i1,
12435 : ae_int_t i2,
12436 : /* Complex */ ae_vector* x,
12437 : /* Complex */ ae_vector* y,
12438 : /* Complex */ ae_vector* t,
12439 : ae_complex alpha,
12440 : ae_state *_state)
12441 : {
12442 : ae_int_t i;
12443 : ae_int_t tp1;
12444 : ae_int_t tp2;
12445 : ae_complex v;
12446 :
12447 :
12448 0 : if( isupper )
12449 : {
12450 0 : for(i=i1; i<=i2; i++)
12451 : {
12452 0 : tp1 = i+1-i1;
12453 0 : tp2 = i2-i1+1;
12454 0 : v = ae_c_mul(alpha,x->ptr.p_complex[i+1-i1]);
12455 0 : ae_v_cmovec(&t->ptr.p_complex[tp1], 1, &y->ptr.p_complex[tp1], 1, "Conj", ae_v_len(tp1,tp2), v);
12456 0 : v = ae_c_mul(ae_c_conj(alpha, _state),y->ptr.p_complex[i+1-i1]);
12457 0 : ae_v_caddc(&t->ptr.p_complex[tp1], 1, &x->ptr.p_complex[tp1], 1, "Conj", ae_v_len(tp1,tp2), v);
12458 0 : ae_v_cadd(&a->ptr.pp_complex[i][i], 1, &t->ptr.p_complex[tp1], 1, "N", ae_v_len(i,i2));
12459 : }
12460 : }
12461 : else
12462 : {
12463 0 : for(i=i1; i<=i2; i++)
12464 : {
12465 0 : tp1 = 1;
12466 0 : tp2 = i+1-i1;
12467 0 : v = ae_c_mul(alpha,x->ptr.p_complex[i+1-i1]);
12468 0 : ae_v_cmovec(&t->ptr.p_complex[tp1], 1, &y->ptr.p_complex[tp1], 1, "Conj", ae_v_len(tp1,tp2), v);
12469 0 : v = ae_c_mul(ae_c_conj(alpha, _state),y->ptr.p_complex[i+1-i1]);
12470 0 : ae_v_caddc(&t->ptr.p_complex[tp1], 1, &x->ptr.p_complex[tp1], 1, "Conj", ae_v_len(tp1,tp2), v);
12471 0 : ae_v_cadd(&a->ptr.pp_complex[i][i1], 1, &t->ptr.p_complex[tp1], 1, "N", ae_v_len(i1,i));
12472 : }
12473 : }
12474 0 : }
12475 :
12476 :
12477 : #endif
12478 : #if defined(AE_COMPILE_SBLAS) || !defined(AE_PARTIAL_BUILD)
12479 :
12480 :
12481 0 : void symmetricmatrixvectormultiply(/* Real */ ae_matrix* a,
12482 : ae_bool isupper,
12483 : ae_int_t i1,
12484 : ae_int_t i2,
12485 : /* Real */ ae_vector* x,
12486 : double alpha,
12487 : /* Real */ ae_vector* y,
12488 : ae_state *_state)
12489 : {
12490 : ae_int_t i;
12491 : ae_int_t ba1;
12492 : ae_int_t ba2;
12493 : ae_int_t by1;
12494 : ae_int_t by2;
12495 : ae_int_t bx1;
12496 : ae_int_t bx2;
12497 : ae_int_t n;
12498 : double v;
12499 :
12500 :
12501 0 : n = i2-i1+1;
12502 0 : if( n<=0 )
12503 : {
12504 0 : return;
12505 : }
12506 :
12507 : /*
12508 : * Let A = L + D + U, where
12509 : * L is strictly lower triangular (main diagonal is zero)
12510 : * D is diagonal
12511 : * U is strictly upper triangular (main diagonal is zero)
12512 : *
12513 : * A*x = L*x + D*x + U*x
12514 : *
12515 : * Calculate D*x first
12516 : */
12517 0 : for(i=i1; i<=i2; i++)
12518 : {
12519 0 : y->ptr.p_double[i-i1+1] = a->ptr.pp_double[i][i]*x->ptr.p_double[i-i1+1];
12520 : }
12521 :
12522 : /*
12523 : * Add L*x + U*x
12524 : */
12525 0 : if( isupper )
12526 : {
12527 0 : for(i=i1; i<=i2-1; i++)
12528 : {
12529 :
12530 : /*
12531 : * Add L*x to the result
12532 : */
12533 0 : v = x->ptr.p_double[i-i1+1];
12534 0 : by1 = i-i1+2;
12535 0 : by2 = n;
12536 0 : ba1 = i+1;
12537 0 : ba2 = i2;
12538 0 : ae_v_addd(&y->ptr.p_double[by1], 1, &a->ptr.pp_double[i][ba1], 1, ae_v_len(by1,by2), v);
12539 :
12540 : /*
12541 : * Add U*x to the result
12542 : */
12543 0 : bx1 = i-i1+2;
12544 0 : bx2 = n;
12545 0 : ba1 = i+1;
12546 0 : ba2 = i2;
12547 0 : v = ae_v_dotproduct(&x->ptr.p_double[bx1], 1, &a->ptr.pp_double[i][ba1], 1, ae_v_len(bx1,bx2));
12548 0 : y->ptr.p_double[i-i1+1] = y->ptr.p_double[i-i1+1]+v;
12549 : }
12550 : }
12551 : else
12552 : {
12553 0 : for(i=i1+1; i<=i2; i++)
12554 : {
12555 :
12556 : /*
12557 : * Add L*x to the result
12558 : */
12559 0 : bx1 = 1;
12560 0 : bx2 = i-i1;
12561 0 : ba1 = i1;
12562 0 : ba2 = i-1;
12563 0 : v = ae_v_dotproduct(&x->ptr.p_double[bx1], 1, &a->ptr.pp_double[i][ba1], 1, ae_v_len(bx1,bx2));
12564 0 : y->ptr.p_double[i-i1+1] = y->ptr.p_double[i-i1+1]+v;
12565 :
12566 : /*
12567 : * Add U*x to the result
12568 : */
12569 0 : v = x->ptr.p_double[i-i1+1];
12570 0 : by1 = 1;
12571 0 : by2 = i-i1;
12572 0 : ba1 = i1;
12573 0 : ba2 = i-1;
12574 0 : ae_v_addd(&y->ptr.p_double[by1], 1, &a->ptr.pp_double[i][ba1], 1, ae_v_len(by1,by2), v);
12575 : }
12576 : }
12577 0 : ae_v_muld(&y->ptr.p_double[1], 1, ae_v_len(1,n), alpha);
12578 0 : touchint(&ba2, _state);
12579 : }
12580 :
12581 :
12582 0 : void symmetricrank2update(/* Real */ ae_matrix* a,
12583 : ae_bool isupper,
12584 : ae_int_t i1,
12585 : ae_int_t i2,
12586 : /* Real */ ae_vector* x,
12587 : /* Real */ ae_vector* y,
12588 : /* Real */ ae_vector* t,
12589 : double alpha,
12590 : ae_state *_state)
12591 : {
12592 : ae_int_t i;
12593 : ae_int_t tp1;
12594 : ae_int_t tp2;
12595 : double v;
12596 :
12597 :
12598 0 : if( isupper )
12599 : {
12600 0 : for(i=i1; i<=i2; i++)
12601 : {
12602 0 : tp1 = i+1-i1;
12603 0 : tp2 = i2-i1+1;
12604 0 : v = x->ptr.p_double[i+1-i1];
12605 0 : ae_v_moved(&t->ptr.p_double[tp1], 1, &y->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), v);
12606 0 : v = y->ptr.p_double[i+1-i1];
12607 0 : ae_v_addd(&t->ptr.p_double[tp1], 1, &x->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), v);
12608 0 : ae_v_muld(&t->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), alpha);
12609 0 : ae_v_add(&a->ptr.pp_double[i][i], 1, &t->ptr.p_double[tp1], 1, ae_v_len(i,i2));
12610 : }
12611 : }
12612 : else
12613 : {
12614 0 : for(i=i1; i<=i2; i++)
12615 : {
12616 0 : tp1 = 1;
12617 0 : tp2 = i+1-i1;
12618 0 : v = x->ptr.p_double[i+1-i1];
12619 0 : ae_v_moved(&t->ptr.p_double[tp1], 1, &y->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), v);
12620 0 : v = y->ptr.p_double[i+1-i1];
12621 0 : ae_v_addd(&t->ptr.p_double[tp1], 1, &x->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), v);
12622 0 : ae_v_muld(&t->ptr.p_double[tp1], 1, ae_v_len(tp1,tp2), alpha);
12623 0 : ae_v_add(&a->ptr.pp_double[i][i1], 1, &t->ptr.p_double[tp1], 1, ae_v_len(i1,i));
12624 : }
12625 : }
12626 0 : }
12627 :
12628 :
12629 : #endif
12630 : #if defined(AE_COMPILE_BLAS) || !defined(AE_PARTIAL_BUILD)
12631 :
12632 :
12633 0 : double vectornorm2(/* Real */ ae_vector* x,
12634 : ae_int_t i1,
12635 : ae_int_t i2,
12636 : ae_state *_state)
12637 : {
12638 : ae_int_t n;
12639 : ae_int_t ix;
12640 : double absxi;
12641 : double scl;
12642 : double ssq;
12643 : double result;
12644 :
12645 :
12646 0 : n = i2-i1+1;
12647 0 : if( n<1 )
12648 : {
12649 0 : result = (double)(0);
12650 0 : return result;
12651 : }
12652 0 : if( n==1 )
12653 : {
12654 0 : result = ae_fabs(x->ptr.p_double[i1], _state);
12655 0 : return result;
12656 : }
12657 0 : scl = (double)(0);
12658 0 : ssq = (double)(1);
12659 0 : for(ix=i1; ix<=i2; ix++)
12660 : {
12661 0 : if( ae_fp_neq(x->ptr.p_double[ix],(double)(0)) )
12662 : {
12663 0 : absxi = ae_fabs(x->ptr.p_double[ix], _state);
12664 0 : if( ae_fp_less(scl,absxi) )
12665 : {
12666 0 : ssq = 1+ssq*ae_sqr(scl/absxi, _state);
12667 0 : scl = absxi;
12668 : }
12669 : else
12670 : {
12671 0 : ssq = ssq+ae_sqr(absxi/scl, _state);
12672 : }
12673 : }
12674 : }
12675 0 : result = scl*ae_sqrt(ssq, _state);
12676 0 : return result;
12677 : }
12678 :
12679 :
12680 0 : ae_int_t vectoridxabsmax(/* Real */ ae_vector* x,
12681 : ae_int_t i1,
12682 : ae_int_t i2,
12683 : ae_state *_state)
12684 : {
12685 : ae_int_t i;
12686 : ae_int_t result;
12687 :
12688 :
12689 0 : result = i1;
12690 0 : for(i=i1+1; i<=i2; i++)
12691 : {
12692 0 : if( ae_fp_greater(ae_fabs(x->ptr.p_double[i], _state),ae_fabs(x->ptr.p_double[result], _state)) )
12693 : {
12694 0 : result = i;
12695 : }
12696 : }
12697 0 : return result;
12698 : }
12699 :
12700 :
12701 0 : ae_int_t columnidxabsmax(/* Real */ ae_matrix* x,
12702 : ae_int_t i1,
12703 : ae_int_t i2,
12704 : ae_int_t j,
12705 : ae_state *_state)
12706 : {
12707 : ae_int_t i;
12708 : ae_int_t result;
12709 :
12710 :
12711 0 : result = i1;
12712 0 : for(i=i1+1; i<=i2; i++)
12713 : {
12714 0 : if( ae_fp_greater(ae_fabs(x->ptr.pp_double[i][j], _state),ae_fabs(x->ptr.pp_double[result][j], _state)) )
12715 : {
12716 0 : result = i;
12717 : }
12718 : }
12719 0 : return result;
12720 : }
12721 :
12722 :
12723 0 : ae_int_t rowidxabsmax(/* Real */ ae_matrix* x,
12724 : ae_int_t j1,
12725 : ae_int_t j2,
12726 : ae_int_t i,
12727 : ae_state *_state)
12728 : {
12729 : ae_int_t j;
12730 : ae_int_t result;
12731 :
12732 :
12733 0 : result = j1;
12734 0 : for(j=j1+1; j<=j2; j++)
12735 : {
12736 0 : if( ae_fp_greater(ae_fabs(x->ptr.pp_double[i][j], _state),ae_fabs(x->ptr.pp_double[i][result], _state)) )
12737 : {
12738 0 : result = j;
12739 : }
12740 : }
12741 0 : return result;
12742 : }
12743 :
12744 :
12745 0 : double upperhessenberg1norm(/* Real */ ae_matrix* a,
12746 : ae_int_t i1,
12747 : ae_int_t i2,
12748 : ae_int_t j1,
12749 : ae_int_t j2,
12750 : /* Real */ ae_vector* work,
12751 : ae_state *_state)
12752 : {
12753 : ae_int_t i;
12754 : ae_int_t j;
12755 : double result;
12756 :
12757 :
12758 0 : ae_assert(i2-i1==j2-j1, "UpperHessenberg1Norm: I2-I1<>J2-J1!", _state);
12759 0 : for(j=j1; j<=j2; j++)
12760 : {
12761 0 : work->ptr.p_double[j] = (double)(0);
12762 : }
12763 0 : for(i=i1; i<=i2; i++)
12764 : {
12765 0 : for(j=ae_maxint(j1, j1+i-i1-1, _state); j<=j2; j++)
12766 : {
12767 0 : work->ptr.p_double[j] = work->ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state);
12768 : }
12769 : }
12770 0 : result = (double)(0);
12771 0 : for(j=j1; j<=j2; j++)
12772 : {
12773 0 : result = ae_maxreal(result, work->ptr.p_double[j], _state);
12774 : }
12775 0 : return result;
12776 : }
12777 :
12778 :
12779 0 : void copymatrix(/* Real */ ae_matrix* a,
12780 : ae_int_t is1,
12781 : ae_int_t is2,
12782 : ae_int_t js1,
12783 : ae_int_t js2,
12784 : /* Real */ ae_matrix* b,
12785 : ae_int_t id1,
12786 : ae_int_t id2,
12787 : ae_int_t jd1,
12788 : ae_int_t jd2,
12789 : ae_state *_state)
12790 : {
12791 : ae_int_t isrc;
12792 : ae_int_t idst;
12793 :
12794 :
12795 0 : if( is1>is2||js1>js2 )
12796 : {
12797 0 : return;
12798 : }
12799 0 : ae_assert(is2-is1==id2-id1, "CopyMatrix: different sizes!", _state);
12800 0 : ae_assert(js2-js1==jd2-jd1, "CopyMatrix: different sizes!", _state);
12801 0 : for(isrc=is1; isrc<=is2; isrc++)
12802 : {
12803 0 : idst = isrc-is1+id1;
12804 0 : ae_v_move(&b->ptr.pp_double[idst][jd1], 1, &a->ptr.pp_double[isrc][js1], 1, ae_v_len(jd1,jd2));
12805 : }
12806 : }
12807 :
12808 :
12809 0 : void inplacetranspose(/* Real */ ae_matrix* a,
12810 : ae_int_t i1,
12811 : ae_int_t i2,
12812 : ae_int_t j1,
12813 : ae_int_t j2,
12814 : /* Real */ ae_vector* work,
12815 : ae_state *_state)
12816 : {
12817 : ae_int_t i;
12818 : ae_int_t j;
12819 : ae_int_t ips;
12820 : ae_int_t jps;
12821 : ae_int_t l;
12822 :
12823 :
12824 0 : if( i1>i2||j1>j2 )
12825 : {
12826 0 : return;
12827 : }
12828 0 : ae_assert(i1-i2==j1-j2, "InplaceTranspose error: incorrect array size!", _state);
12829 0 : for(i=i1; i<=i2-1; i++)
12830 : {
12831 0 : j = j1+i-i1;
12832 0 : ips = i+1;
12833 0 : jps = j1+ips-i1;
12834 0 : l = i2-i;
12835 0 : ae_v_move(&work->ptr.p_double[1], 1, &a->ptr.pp_double[ips][j], a->stride, ae_v_len(1,l));
12836 0 : ae_v_move(&a->ptr.pp_double[ips][j], a->stride, &a->ptr.pp_double[i][jps], 1, ae_v_len(ips,i2));
12837 0 : ae_v_move(&a->ptr.pp_double[i][jps], 1, &work->ptr.p_double[1], 1, ae_v_len(jps,j2));
12838 : }
12839 : }
12840 :
12841 :
12842 0 : void copyandtranspose(/* Real */ ae_matrix* a,
12843 : ae_int_t is1,
12844 : ae_int_t is2,
12845 : ae_int_t js1,
12846 : ae_int_t js2,
12847 : /* Real */ ae_matrix* b,
12848 : ae_int_t id1,
12849 : ae_int_t id2,
12850 : ae_int_t jd1,
12851 : ae_int_t jd2,
12852 : ae_state *_state)
12853 : {
12854 : ae_int_t isrc;
12855 : ae_int_t jdst;
12856 :
12857 :
12858 0 : if( is1>is2||js1>js2 )
12859 : {
12860 0 : return;
12861 : }
12862 0 : ae_assert(is2-is1==jd2-jd1, "CopyAndTranspose: different sizes!", _state);
12863 0 : ae_assert(js2-js1==id2-id1, "CopyAndTranspose: different sizes!", _state);
12864 0 : for(isrc=is1; isrc<=is2; isrc++)
12865 : {
12866 0 : jdst = isrc-is1+jd1;
12867 0 : ae_v_move(&b->ptr.pp_double[id1][jdst], b->stride, &a->ptr.pp_double[isrc][js1], 1, ae_v_len(id1,id2));
12868 : }
12869 : }
12870 :
12871 :
12872 0 : void matrixvectormultiply(/* Real */ ae_matrix* a,
12873 : ae_int_t i1,
12874 : ae_int_t i2,
12875 : ae_int_t j1,
12876 : ae_int_t j2,
12877 : ae_bool trans,
12878 : /* Real */ ae_vector* x,
12879 : ae_int_t ix1,
12880 : ae_int_t ix2,
12881 : double alpha,
12882 : /* Real */ ae_vector* y,
12883 : ae_int_t iy1,
12884 : ae_int_t iy2,
12885 : double beta,
12886 : ae_state *_state)
12887 : {
12888 : ae_int_t i;
12889 : double v;
12890 :
12891 :
12892 0 : if( !trans )
12893 : {
12894 :
12895 : /*
12896 : * y := alpha*A*x + beta*y;
12897 : */
12898 0 : if( i1>i2||j1>j2 )
12899 : {
12900 0 : return;
12901 : }
12902 0 : ae_assert(j2-j1==ix2-ix1, "MatrixVectorMultiply: A and X dont match!", _state);
12903 0 : ae_assert(i2-i1==iy2-iy1, "MatrixVectorMultiply: A and Y dont match!", _state);
12904 :
12905 : /*
12906 : * beta*y
12907 : */
12908 0 : if( ae_fp_eq(beta,(double)(0)) )
12909 : {
12910 0 : for(i=iy1; i<=iy2; i++)
12911 : {
12912 0 : y->ptr.p_double[i] = (double)(0);
12913 : }
12914 : }
12915 : else
12916 : {
12917 0 : ae_v_muld(&y->ptr.p_double[iy1], 1, ae_v_len(iy1,iy2), beta);
12918 : }
12919 :
12920 : /*
12921 : * alpha*A*x
12922 : */
12923 0 : for(i=i1; i<=i2; i++)
12924 : {
12925 0 : v = ae_v_dotproduct(&a->ptr.pp_double[i][j1], 1, &x->ptr.p_double[ix1], 1, ae_v_len(j1,j2));
12926 0 : y->ptr.p_double[iy1+i-i1] = y->ptr.p_double[iy1+i-i1]+alpha*v;
12927 : }
12928 : }
12929 : else
12930 : {
12931 :
12932 : /*
12933 : * y := alpha*A'*x + beta*y;
12934 : */
12935 0 : if( i1>i2||j1>j2 )
12936 : {
12937 0 : return;
12938 : }
12939 0 : ae_assert(i2-i1==ix2-ix1, "MatrixVectorMultiply: A and X dont match!", _state);
12940 0 : ae_assert(j2-j1==iy2-iy1, "MatrixVectorMultiply: A and Y dont match!", _state);
12941 :
12942 : /*
12943 : * beta*y
12944 : */
12945 0 : if( ae_fp_eq(beta,(double)(0)) )
12946 : {
12947 0 : for(i=iy1; i<=iy2; i++)
12948 : {
12949 0 : y->ptr.p_double[i] = (double)(0);
12950 : }
12951 : }
12952 : else
12953 : {
12954 0 : ae_v_muld(&y->ptr.p_double[iy1], 1, ae_v_len(iy1,iy2), beta);
12955 : }
12956 :
12957 : /*
12958 : * alpha*A'*x
12959 : */
12960 0 : for(i=i1; i<=i2; i++)
12961 : {
12962 0 : v = alpha*x->ptr.p_double[ix1+i-i1];
12963 0 : ae_v_addd(&y->ptr.p_double[iy1], 1, &a->ptr.pp_double[i][j1], 1, ae_v_len(iy1,iy2), v);
12964 : }
12965 : }
12966 : }
12967 :
12968 :
12969 0 : double pythag2(double x, double y, ae_state *_state)
12970 : {
12971 : double w;
12972 : double xabs;
12973 : double yabs;
12974 : double z;
12975 : double result;
12976 :
12977 :
12978 0 : xabs = ae_fabs(x, _state);
12979 0 : yabs = ae_fabs(y, _state);
12980 0 : w = ae_maxreal(xabs, yabs, _state);
12981 0 : z = ae_minreal(xabs, yabs, _state);
12982 0 : if( ae_fp_eq(z,(double)(0)) )
12983 : {
12984 0 : result = w;
12985 : }
12986 : else
12987 : {
12988 0 : result = w*ae_sqrt(1+ae_sqr(z/w, _state), _state);
12989 : }
12990 0 : return result;
12991 : }
12992 :
12993 :
12994 0 : void matrixmatrixmultiply(/* Real */ ae_matrix* a,
12995 : ae_int_t ai1,
12996 : ae_int_t ai2,
12997 : ae_int_t aj1,
12998 : ae_int_t aj2,
12999 : ae_bool transa,
13000 : /* Real */ ae_matrix* b,
13001 : ae_int_t bi1,
13002 : ae_int_t bi2,
13003 : ae_int_t bj1,
13004 : ae_int_t bj2,
13005 : ae_bool transb,
13006 : double alpha,
13007 : /* Real */ ae_matrix* c,
13008 : ae_int_t ci1,
13009 : ae_int_t ci2,
13010 : ae_int_t cj1,
13011 : ae_int_t cj2,
13012 : double beta,
13013 : /* Real */ ae_vector* work,
13014 : ae_state *_state)
13015 : {
13016 : ae_int_t arows;
13017 : ae_int_t acols;
13018 : ae_int_t brows;
13019 : ae_int_t bcols;
13020 : ae_int_t crows;
13021 : ae_int_t i;
13022 : ae_int_t j;
13023 : ae_int_t k;
13024 : ae_int_t l;
13025 : ae_int_t r;
13026 : double v;
13027 :
13028 :
13029 :
13030 : /*
13031 : * Setup
13032 : */
13033 0 : if( !transa )
13034 : {
13035 0 : arows = ai2-ai1+1;
13036 0 : acols = aj2-aj1+1;
13037 : }
13038 : else
13039 : {
13040 0 : arows = aj2-aj1+1;
13041 0 : acols = ai2-ai1+1;
13042 : }
13043 0 : if( !transb )
13044 : {
13045 0 : brows = bi2-bi1+1;
13046 0 : bcols = bj2-bj1+1;
13047 : }
13048 : else
13049 : {
13050 0 : brows = bj2-bj1+1;
13051 0 : bcols = bi2-bi1+1;
13052 : }
13053 0 : ae_assert(acols==brows, "MatrixMatrixMultiply: incorrect matrix sizes!", _state);
13054 0 : if( ((arows<=0||acols<=0)||brows<=0)||bcols<=0 )
13055 : {
13056 0 : return;
13057 : }
13058 0 : crows = arows;
13059 :
13060 : /*
13061 : * Test WORK
13062 : */
13063 0 : i = ae_maxint(arows, acols, _state);
13064 0 : i = ae_maxint(brows, i, _state);
13065 0 : i = ae_maxint(i, bcols, _state);
13066 0 : work->ptr.p_double[1] = (double)(0);
13067 0 : work->ptr.p_double[i] = (double)(0);
13068 :
13069 : /*
13070 : * Prepare C
13071 : */
13072 0 : if( ae_fp_eq(beta,(double)(0)) )
13073 : {
13074 0 : for(i=ci1; i<=ci2; i++)
13075 : {
13076 0 : for(j=cj1; j<=cj2; j++)
13077 : {
13078 0 : c->ptr.pp_double[i][j] = (double)(0);
13079 : }
13080 : }
13081 : }
13082 : else
13083 : {
13084 0 : for(i=ci1; i<=ci2; i++)
13085 : {
13086 0 : ae_v_muld(&c->ptr.pp_double[i][cj1], 1, ae_v_len(cj1,cj2), beta);
13087 : }
13088 : }
13089 :
13090 : /*
13091 : * A*B
13092 : */
13093 0 : if( !transa&&!transb )
13094 : {
13095 0 : for(l=ai1; l<=ai2; l++)
13096 : {
13097 0 : for(r=bi1; r<=bi2; r++)
13098 : {
13099 0 : v = alpha*a->ptr.pp_double[l][aj1+r-bi1];
13100 0 : k = ci1+l-ai1;
13101 0 : ae_v_addd(&c->ptr.pp_double[k][cj1], 1, &b->ptr.pp_double[r][bj1], 1, ae_v_len(cj1,cj2), v);
13102 : }
13103 : }
13104 0 : return;
13105 : }
13106 :
13107 : /*
13108 : * A*B'
13109 : */
13110 0 : if( !transa&&transb )
13111 : {
13112 0 : if( arows*acols<brows*bcols )
13113 : {
13114 0 : for(r=bi1; r<=bi2; r++)
13115 : {
13116 0 : for(l=ai1; l<=ai2; l++)
13117 : {
13118 0 : v = ae_v_dotproduct(&a->ptr.pp_double[l][aj1], 1, &b->ptr.pp_double[r][bj1], 1, ae_v_len(aj1,aj2));
13119 0 : c->ptr.pp_double[ci1+l-ai1][cj1+r-bi1] = c->ptr.pp_double[ci1+l-ai1][cj1+r-bi1]+alpha*v;
13120 : }
13121 : }
13122 0 : return;
13123 : }
13124 : else
13125 : {
13126 0 : for(l=ai1; l<=ai2; l++)
13127 : {
13128 0 : for(r=bi1; r<=bi2; r++)
13129 : {
13130 0 : v = ae_v_dotproduct(&a->ptr.pp_double[l][aj1], 1, &b->ptr.pp_double[r][bj1], 1, ae_v_len(aj1,aj2));
13131 0 : c->ptr.pp_double[ci1+l-ai1][cj1+r-bi1] = c->ptr.pp_double[ci1+l-ai1][cj1+r-bi1]+alpha*v;
13132 : }
13133 : }
13134 0 : return;
13135 : }
13136 : }
13137 :
13138 : /*
13139 : * A'*B
13140 : */
13141 0 : if( transa&&!transb )
13142 : {
13143 0 : for(l=aj1; l<=aj2; l++)
13144 : {
13145 0 : for(r=bi1; r<=bi2; r++)
13146 : {
13147 0 : v = alpha*a->ptr.pp_double[ai1+r-bi1][l];
13148 0 : k = ci1+l-aj1;
13149 0 : ae_v_addd(&c->ptr.pp_double[k][cj1], 1, &b->ptr.pp_double[r][bj1], 1, ae_v_len(cj1,cj2), v);
13150 : }
13151 : }
13152 0 : return;
13153 : }
13154 :
13155 : /*
13156 : * A'*B'
13157 : */
13158 0 : if( transa&&transb )
13159 : {
13160 0 : if( arows*acols<brows*bcols )
13161 : {
13162 0 : for(r=bi1; r<=bi2; r++)
13163 : {
13164 0 : k = cj1+r-bi1;
13165 0 : for(i=1; i<=crows; i++)
13166 : {
13167 0 : work->ptr.p_double[i] = 0.0;
13168 : }
13169 0 : for(l=ai1; l<=ai2; l++)
13170 : {
13171 0 : v = alpha*b->ptr.pp_double[r][bj1+l-ai1];
13172 0 : ae_v_addd(&work->ptr.p_double[1], 1, &a->ptr.pp_double[l][aj1], 1, ae_v_len(1,crows), v);
13173 : }
13174 0 : ae_v_add(&c->ptr.pp_double[ci1][k], c->stride, &work->ptr.p_double[1], 1, ae_v_len(ci1,ci2));
13175 : }
13176 0 : return;
13177 : }
13178 : else
13179 : {
13180 0 : for(l=aj1; l<=aj2; l++)
13181 : {
13182 0 : k = ai2-ai1+1;
13183 0 : ae_v_move(&work->ptr.p_double[1], 1, &a->ptr.pp_double[ai1][l], a->stride, ae_v_len(1,k));
13184 0 : for(r=bi1; r<=bi2; r++)
13185 : {
13186 0 : v = ae_v_dotproduct(&work->ptr.p_double[1], 1, &b->ptr.pp_double[r][bj1], 1, ae_v_len(1,k));
13187 0 : c->ptr.pp_double[ci1+l-aj1][cj1+r-bi1] = c->ptr.pp_double[ci1+l-aj1][cj1+r-bi1]+alpha*v;
13188 : }
13189 : }
13190 0 : return;
13191 : }
13192 : }
13193 : }
13194 :
13195 :
13196 : #endif
13197 : #if defined(AE_COMPILE_LINMIN) || !defined(AE_PARTIAL_BUILD)
13198 :
13199 :
13200 : /*************************************************************************
13201 : Normalizes direction/step pair: makes |D|=1, scales Stp.
13202 : If |D|=0, it returns, leavind D/Stp unchanged.
13203 :
13204 : -- ALGLIB --
13205 : Copyright 01.04.2010 by Bochkanov Sergey
13206 : *************************************************************************/
13207 0 : void linminnormalized(/* Real */ ae_vector* d,
13208 : double* stp,
13209 : ae_int_t n,
13210 : ae_state *_state)
13211 : {
13212 : double mx;
13213 : double s;
13214 : ae_int_t i;
13215 :
13216 :
13217 :
13218 : /*
13219 : * first, scale D to avoid underflow/overflow durng squaring
13220 : */
13221 0 : mx = (double)(0);
13222 0 : for(i=0; i<=n-1; i++)
13223 : {
13224 0 : mx = ae_maxreal(mx, ae_fabs(d->ptr.p_double[i], _state), _state);
13225 : }
13226 0 : if( ae_fp_eq(mx,(double)(0)) )
13227 : {
13228 0 : return;
13229 : }
13230 0 : s = 1/mx;
13231 0 : ae_v_muld(&d->ptr.p_double[0], 1, ae_v_len(0,n-1), s);
13232 0 : *stp = *stp/s;
13233 :
13234 : /*
13235 : * normalize D
13236 : */
13237 0 : s = ae_v_dotproduct(&d->ptr.p_double[0], 1, &d->ptr.p_double[0], 1, ae_v_len(0,n-1));
13238 0 : s = 1/ae_sqrt(s, _state);
13239 0 : ae_v_muld(&d->ptr.p_double[0], 1, ae_v_len(0,n-1), s);
13240 0 : *stp = *stp/s;
13241 : }
13242 :
13243 :
13244 : /*************************************************************************
13245 : THE PURPOSE OF MCSRCH IS TO FIND A STEP WHICH SATISFIES A SUFFICIENT
13246 : DECREASE CONDITION AND A CURVATURE CONDITION.
13247 :
13248 : AT EACH STAGE THE SUBROUTINE UPDATES AN INTERVAL OF UNCERTAINTY WITH
13249 : ENDPOINTS STX AND STY. THE INTERVAL OF UNCERTAINTY IS INITIALLY CHOSEN
13250 : SO THAT IT CONTAINS A MINIMIZER OF THE MODIFIED FUNCTION
13251 :
13252 : F(X+STP*S) - F(X) - FTOL*STP*(GRADF(X)'S).
13253 :
13254 : IF A STEP IS OBTAINED FOR WHICH THE MODIFIED FUNCTION HAS A NONPOSITIVE
13255 : FUNCTION VALUE AND NONNEGATIVE DERIVATIVE, THEN THE INTERVAL OF
13256 : UNCERTAINTY IS CHOSEN SO THAT IT CONTAINS A MINIMIZER OF F(X+STP*S).
13257 :
13258 : THE ALGORITHM IS DESIGNED TO FIND A STEP WHICH SATISFIES THE SUFFICIENT
13259 : DECREASE CONDITION
13260 :
13261 : F(X+STP*S) .LE. F(X) + FTOL*STP*(GRADF(X)'S),
13262 :
13263 : AND THE CURVATURE CONDITION
13264 :
13265 : ABS(GRADF(X+STP*S)'S)) .LE. GTOL*ABS(GRADF(X)'S).
13266 :
13267 : IF FTOL IS LESS THAN GTOL AND IF, FOR EXAMPLE, THE FUNCTION IS BOUNDED
13268 : BELOW, THEN THERE IS ALWAYS A STEP WHICH SATISFIES BOTH CONDITIONS.
13269 : IF NO STEP CAN BE FOUND WHICH SATISFIES BOTH CONDITIONS, THEN THE
13270 : ALGORITHM USUALLY STOPS WHEN ROUNDING ERRORS PREVENT FURTHER PROGRESS.
13271 : IN THIS CASE STP ONLY SATISFIES THE SUFFICIENT DECREASE CONDITION.
13272 :
13273 :
13274 : :::::::::::::IMPORTANT NOTES:::::::::::::
13275 :
13276 : NOTE 1:
13277 :
13278 : This routine guarantees that it will stop at the last point where function
13279 : value was calculated. It won't make several additional function evaluations
13280 : after finding good point. So if you store function evaluations requested by
13281 : this routine, you can be sure that last one is the point where we've stopped.
13282 :
13283 : NOTE 2:
13284 :
13285 : when 0<StpMax<StpMin, algorithm will terminate with INFO=5 and Stp=StpMax
13286 :
13287 : NOTE 3:
13288 :
13289 : this algorithm guarantees that, if MCINFO=1 or MCINFO=5, then:
13290 : * F(final_point)<F(initial_point) - strict inequality
13291 : * final_point<>initial_point - after rounding to machine precision
13292 :
13293 : NOTE 4:
13294 :
13295 : when non-descent direction is specified, algorithm stops with MCINFO=0,
13296 : Stp=0 and initial point at X[].
13297 : :::::::::::::::::::::::::::::::::::::::::
13298 :
13299 :
13300 : PARAMETERS DESCRIPRION
13301 :
13302 : STAGE IS ZERO ON FIRST CALL, ZERO ON FINAL EXIT
13303 :
13304 : N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF VARIABLES.
13305 :
13306 : X IS AN ARRAY OF LENGTH N. ON INPUT IT MUST CONTAIN THE BASE POINT FOR
13307 : THE LINE SEARCH. ON OUTPUT IT CONTAINS X+STP*S.
13308 :
13309 : F IS A VARIABLE. ON INPUT IT MUST CONTAIN THE VALUE OF F AT X. ON OUTPUT
13310 : IT CONTAINS THE VALUE OF F AT X + STP*S.
13311 :
13312 : G IS AN ARRAY OF LENGTH N. ON INPUT IT MUST CONTAIN THE GRADIENT OF F AT X.
13313 : ON OUTPUT IT CONTAINS THE GRADIENT OF F AT X + STP*S.
13314 :
13315 : S IS AN INPUT ARRAY OF LENGTH N WHICH SPECIFIES THE SEARCH DIRECTION.
13316 :
13317 : STP IS A NONNEGATIVE VARIABLE. ON INPUT STP CONTAINS AN INITIAL ESTIMATE
13318 : OF A SATISFACTORY STEP. ON OUTPUT STP CONTAINS THE FINAL ESTIMATE.
13319 :
13320 : FTOL AND GTOL ARE NONNEGATIVE INPUT VARIABLES. TERMINATION OCCURS WHEN THE
13321 : SUFFICIENT DECREASE CONDITION AND THE DIRECTIONAL DERIVATIVE CONDITION ARE
13322 : SATISFIED.
13323 :
13324 : XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS WHEN THE RELATIVE
13325 : WIDTH OF THE INTERVAL OF UNCERTAINTY IS AT MOST XTOL.
13326 :
13327 : STPMIN AND STPMAX ARE NONNEGATIVE INPUT VARIABLES WHICH SPECIFY LOWER AND
13328 : UPPER BOUNDS FOR THE STEP.
13329 :
13330 : MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION OCCURS WHEN THE
13331 : NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV BY THE END OF AN ITERATION.
13332 :
13333 : INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS:
13334 : INFO = 0 IMPROPER INPUT PARAMETERS.
13335 :
13336 : INFO = 1 THE SUFFICIENT DECREASE CONDITION AND THE
13337 : DIRECTIONAL DERIVATIVE CONDITION HOLD.
13338 :
13339 : INFO = 2 RELATIVE WIDTH OF THE INTERVAL OF UNCERTAINTY
13340 : IS AT MOST XTOL.
13341 :
13342 : INFO = 3 NUMBER OF CALLS TO FCN HAS REACHED MAXFEV.
13343 :
13344 : INFO = 4 THE STEP IS AT THE LOWER BOUND STPMIN.
13345 :
13346 : INFO = 5 THE STEP IS AT THE UPPER BOUND STPMAX.
13347 :
13348 : INFO = 6 ROUNDING ERRORS PREVENT FURTHER PROGRESS.
13349 : THERE MAY NOT BE A STEP WHICH SATISFIES THE
13350 : SUFFICIENT DECREASE AND CURVATURE CONDITIONS.
13351 : TOLERANCES MAY BE TOO SMALL.
13352 :
13353 : NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF CALLS TO FCN.
13354 :
13355 : WA IS A WORK ARRAY OF LENGTH N.
13356 :
13357 : ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1983
13358 : JORGE J. MORE', DAVID J. THUENTE
13359 : *************************************************************************/
13360 0 : void mcsrch(ae_int_t n,
13361 : /* Real */ ae_vector* x,
13362 : double* f,
13363 : /* Real */ ae_vector* g,
13364 : /* Real */ ae_vector* s,
13365 : double* stp,
13366 : double stpmax,
13367 : double gtol,
13368 : ae_int_t* info,
13369 : ae_int_t* nfev,
13370 : /* Real */ ae_vector* wa,
13371 : linminstate* state,
13372 : ae_int_t* stage,
13373 : ae_state *_state)
13374 : {
13375 : ae_int_t i;
13376 : double v;
13377 : double p5;
13378 : double p66;
13379 : double zero;
13380 :
13381 :
13382 :
13383 : /*
13384 : * init
13385 : */
13386 0 : p5 = 0.5;
13387 0 : p66 = 0.66;
13388 0 : state->xtrapf = 4.0;
13389 0 : zero = (double)(0);
13390 0 : if( ae_fp_eq(stpmax,(double)(0)) )
13391 : {
13392 0 : stpmax = linmin_defstpmax;
13393 : }
13394 0 : if( ae_fp_less(*stp,linmin_stpmin) )
13395 : {
13396 0 : *stp = linmin_stpmin;
13397 : }
13398 0 : if( ae_fp_greater(*stp,stpmax) )
13399 : {
13400 0 : *stp = stpmax;
13401 : }
13402 :
13403 : /*
13404 : * Main cycle
13405 : */
13406 : for(;;)
13407 : {
13408 0 : if( *stage==0 )
13409 : {
13410 :
13411 : /*
13412 : * NEXT
13413 : */
13414 0 : *stage = 2;
13415 0 : continue;
13416 : }
13417 0 : if( *stage==2 )
13418 : {
13419 0 : state->infoc = 1;
13420 0 : *info = 0;
13421 :
13422 : /*
13423 : * CHECK THE INPUT PARAMETERS FOR ERRORS.
13424 : */
13425 0 : if( ae_fp_less(stpmax,linmin_stpmin)&&ae_fp_greater(stpmax,(double)(0)) )
13426 : {
13427 0 : *info = 5;
13428 0 : *stp = stpmax;
13429 0 : *stage = 0;
13430 0 : return;
13431 : }
13432 0 : if( ((((((n<=0||ae_fp_less_eq(*stp,(double)(0)))||ae_fp_less(linmin_ftol,(double)(0)))||ae_fp_less(gtol,zero))||ae_fp_less(linmin_xtol,zero))||ae_fp_less(linmin_stpmin,zero))||ae_fp_less(stpmax,linmin_stpmin))||linmin_maxfev<=0 )
13433 : {
13434 0 : *stage = 0;
13435 0 : return;
13436 : }
13437 :
13438 : /*
13439 : * COMPUTE THE INITIAL GRADIENT IN THE SEARCH DIRECTION
13440 : * AND CHECK THAT S IS A DESCENT DIRECTION.
13441 : */
13442 0 : v = ae_v_dotproduct(&g->ptr.p_double[0], 1, &s->ptr.p_double[0], 1, ae_v_len(0,n-1));
13443 0 : state->dginit = v;
13444 0 : if( ae_fp_greater_eq(state->dginit,(double)(0)) )
13445 : {
13446 0 : *stage = 0;
13447 0 : *stp = (double)(0);
13448 0 : return;
13449 : }
13450 :
13451 : /*
13452 : * INITIALIZE LOCAL VARIABLES.
13453 : */
13454 0 : state->brackt = ae_false;
13455 0 : state->stage1 = ae_true;
13456 0 : *nfev = 0;
13457 0 : state->finit = *f;
13458 0 : state->dgtest = linmin_ftol*state->dginit;
13459 0 : state->width = stpmax-linmin_stpmin;
13460 0 : state->width1 = state->width/p5;
13461 0 : ae_v_move(&wa->ptr.p_double[0], 1, &x->ptr.p_double[0], 1, ae_v_len(0,n-1));
13462 :
13463 : /*
13464 : * THE VARIABLES STX, FX, DGX CONTAIN THE VALUES OF THE STEP,
13465 : * FUNCTION, AND DIRECTIONAL DERIVATIVE AT THE BEST STEP.
13466 : * THE VARIABLES STY, FY, DGY CONTAIN THE VALUE OF THE STEP,
13467 : * FUNCTION, AND DERIVATIVE AT THE OTHER ENDPOINT OF
13468 : * THE INTERVAL OF UNCERTAINTY.
13469 : * THE VARIABLES STP, F, DG CONTAIN THE VALUES OF THE STEP,
13470 : * FUNCTION, AND DERIVATIVE AT THE CURRENT STEP.
13471 : */
13472 0 : state->stx = (double)(0);
13473 0 : state->fx = state->finit;
13474 0 : state->dgx = state->dginit;
13475 0 : state->sty = (double)(0);
13476 0 : state->fy = state->finit;
13477 0 : state->dgy = state->dginit;
13478 :
13479 : /*
13480 : * NEXT
13481 : */
13482 0 : *stage = 3;
13483 0 : continue;
13484 : }
13485 0 : if( *stage==3 )
13486 : {
13487 :
13488 : /*
13489 : * START OF ITERATION.
13490 : *
13491 : * SET THE MINIMUM AND MAXIMUM STEPS TO CORRESPOND
13492 : * TO THE PRESENT INTERVAL OF UNCERTAINTY.
13493 : */
13494 0 : if( state->brackt )
13495 : {
13496 0 : if( ae_fp_less(state->stx,state->sty) )
13497 : {
13498 0 : state->stmin = state->stx;
13499 0 : state->stmax = state->sty;
13500 : }
13501 : else
13502 : {
13503 0 : state->stmin = state->sty;
13504 0 : state->stmax = state->stx;
13505 : }
13506 : }
13507 : else
13508 : {
13509 0 : state->stmin = state->stx;
13510 0 : state->stmax = *stp+state->xtrapf*(*stp-state->stx);
13511 : }
13512 :
13513 : /*
13514 : * FORCE THE STEP TO BE WITHIN THE BOUNDS STPMAX AND STPMIN.
13515 : */
13516 0 : if( ae_fp_greater(*stp,stpmax) )
13517 : {
13518 0 : *stp = stpmax;
13519 : }
13520 0 : if( ae_fp_less(*stp,linmin_stpmin) )
13521 : {
13522 0 : *stp = linmin_stpmin;
13523 : }
13524 :
13525 : /*
13526 : * IF AN UNUSUAL TERMINATION IS TO OCCUR THEN LET
13527 : * STP BE THE LOWEST POINT OBTAINED SO FAR.
13528 : */
13529 0 : if( (((state->brackt&&(ae_fp_less_eq(*stp,state->stmin)||ae_fp_greater_eq(*stp,state->stmax)))||*nfev>=linmin_maxfev-1)||state->infoc==0)||(state->brackt&&ae_fp_less_eq(state->stmax-state->stmin,linmin_xtol*state->stmax)) )
13530 : {
13531 0 : *stp = state->stx;
13532 : }
13533 :
13534 : /*
13535 : * EVALUATE THE FUNCTION AND GRADIENT AT STP
13536 : * AND COMPUTE THE DIRECTIONAL DERIVATIVE.
13537 : */
13538 0 : ae_v_move(&x->ptr.p_double[0], 1, &wa->ptr.p_double[0], 1, ae_v_len(0,n-1));
13539 0 : ae_v_addd(&x->ptr.p_double[0], 1, &s->ptr.p_double[0], 1, ae_v_len(0,n-1), *stp);
13540 :
13541 : /*
13542 : * NEXT
13543 : */
13544 0 : *stage = 4;
13545 0 : return;
13546 : }
13547 0 : if( *stage==4 )
13548 : {
13549 0 : *info = 0;
13550 0 : *nfev = *nfev+1;
13551 0 : v = ae_v_dotproduct(&g->ptr.p_double[0], 1, &s->ptr.p_double[0], 1, ae_v_len(0,n-1));
13552 0 : state->dg = v;
13553 0 : state->ftest1 = state->finit+*stp*state->dgtest;
13554 :
13555 : /*
13556 : * TEST FOR CONVERGENCE.
13557 : */
13558 0 : if( (state->brackt&&(ae_fp_less_eq(*stp,state->stmin)||ae_fp_greater_eq(*stp,state->stmax)))||state->infoc==0 )
13559 : {
13560 0 : *info = 6;
13561 : }
13562 0 : if( ((ae_fp_eq(*stp,stpmax)&&ae_fp_less(*f,state->finit))&&ae_fp_less_eq(*f,state->ftest1))&&ae_fp_less_eq(state->dg,state->dgtest) )
13563 : {
13564 0 : *info = 5;
13565 : }
13566 0 : if( ae_fp_eq(*stp,linmin_stpmin)&&((ae_fp_greater_eq(*f,state->finit)||ae_fp_greater(*f,state->ftest1))||ae_fp_greater_eq(state->dg,state->dgtest)) )
13567 : {
13568 0 : *info = 4;
13569 : }
13570 0 : if( *nfev>=linmin_maxfev )
13571 : {
13572 0 : *info = 3;
13573 : }
13574 0 : if( state->brackt&&ae_fp_less_eq(state->stmax-state->stmin,linmin_xtol*state->stmax) )
13575 : {
13576 0 : *info = 2;
13577 : }
13578 0 : if( (ae_fp_less(*f,state->finit)&&ae_fp_less_eq(*f,state->ftest1))&&ae_fp_less_eq(ae_fabs(state->dg, _state),-gtol*state->dginit) )
13579 : {
13580 0 : *info = 1;
13581 : }
13582 :
13583 : /*
13584 : * CHECK FOR TERMINATION.
13585 : */
13586 0 : if( *info!=0 )
13587 : {
13588 :
13589 : /*
13590 : * Check guarantees provided by the function for INFO=1 or INFO=5
13591 : */
13592 0 : if( *info==1||*info==5 )
13593 : {
13594 0 : v = 0.0;
13595 0 : for(i=0; i<=n-1; i++)
13596 : {
13597 0 : v = v+(wa->ptr.p_double[i]-x->ptr.p_double[i])*(wa->ptr.p_double[i]-x->ptr.p_double[i]);
13598 : }
13599 0 : if( ae_fp_greater_eq(*f,state->finit)||ae_fp_eq(v,0.0) )
13600 : {
13601 0 : *info = 6;
13602 : }
13603 : }
13604 0 : *stage = 0;
13605 0 : return;
13606 : }
13607 :
13608 : /*
13609 : * IN THE FIRST STAGE WE SEEK A STEP FOR WHICH THE MODIFIED
13610 : * FUNCTION HAS A NONPOSITIVE VALUE AND NONNEGATIVE DERIVATIVE.
13611 : */
13612 0 : if( (state->stage1&&ae_fp_less_eq(*f,state->ftest1))&&ae_fp_greater_eq(state->dg,ae_minreal(linmin_ftol, gtol, _state)*state->dginit) )
13613 : {
13614 0 : state->stage1 = ae_false;
13615 : }
13616 :
13617 : /*
13618 : * A MODIFIED FUNCTION IS USED TO PREDICT THE STEP ONLY IF
13619 : * WE HAVE NOT OBTAINED A STEP FOR WHICH THE MODIFIED
13620 : * FUNCTION HAS A NONPOSITIVE FUNCTION VALUE AND NONNEGATIVE
13621 : * DERIVATIVE, AND IF A LOWER FUNCTION VALUE HAS BEEN
13622 : * OBTAINED BUT THE DECREASE IS NOT SUFFICIENT.
13623 : */
13624 0 : if( (state->stage1&&ae_fp_less_eq(*f,state->fx))&&ae_fp_greater(*f,state->ftest1) )
13625 : {
13626 :
13627 : /*
13628 : * DEFINE THE MODIFIED FUNCTION AND DERIVATIVE VALUES.
13629 : */
13630 0 : state->fm = *f-*stp*state->dgtest;
13631 0 : state->fxm = state->fx-state->stx*state->dgtest;
13632 0 : state->fym = state->fy-state->sty*state->dgtest;
13633 0 : state->dgm = state->dg-state->dgtest;
13634 0 : state->dgxm = state->dgx-state->dgtest;
13635 0 : state->dgym = state->dgy-state->dgtest;
13636 :
13637 : /*
13638 : * CALL CSTEP TO UPDATE THE INTERVAL OF UNCERTAINTY
13639 : * AND TO COMPUTE THE NEW STEP.
13640 : */
13641 0 : linmin_mcstep(&state->stx, &state->fxm, &state->dgxm, &state->sty, &state->fym, &state->dgym, stp, state->fm, state->dgm, &state->brackt, state->stmin, state->stmax, &state->infoc, _state);
13642 :
13643 : /*
13644 : * RESET THE FUNCTION AND GRADIENT VALUES FOR F.
13645 : */
13646 0 : state->fx = state->fxm+state->stx*state->dgtest;
13647 0 : state->fy = state->fym+state->sty*state->dgtest;
13648 0 : state->dgx = state->dgxm+state->dgtest;
13649 0 : state->dgy = state->dgym+state->dgtest;
13650 : }
13651 : else
13652 : {
13653 :
13654 : /*
13655 : * CALL MCSTEP TO UPDATE THE INTERVAL OF UNCERTAINTY
13656 : * AND TO COMPUTE THE NEW STEP.
13657 : */
13658 0 : linmin_mcstep(&state->stx, &state->fx, &state->dgx, &state->sty, &state->fy, &state->dgy, stp, *f, state->dg, &state->brackt, state->stmin, state->stmax, &state->infoc, _state);
13659 : }
13660 :
13661 : /*
13662 : * FORCE A SUFFICIENT DECREASE IN THE SIZE OF THE
13663 : * INTERVAL OF UNCERTAINTY.
13664 : */
13665 0 : if( state->brackt )
13666 : {
13667 0 : if( ae_fp_greater_eq(ae_fabs(state->sty-state->stx, _state),p66*state->width1) )
13668 : {
13669 0 : *stp = state->stx+p5*(state->sty-state->stx);
13670 : }
13671 0 : state->width1 = state->width;
13672 0 : state->width = ae_fabs(state->sty-state->stx, _state);
13673 : }
13674 :
13675 : /*
13676 : * NEXT.
13677 : */
13678 0 : *stage = 3;
13679 0 : continue;
13680 : }
13681 : }
13682 : }
13683 :
13684 :
13685 : /*************************************************************************
13686 : These functions perform Armijo line search using at most FMAX function
13687 : evaluations. It doesn't enforce some kind of " sufficient decrease"
13688 : criterion - it just tries different Armijo steps and returns optimum found
13689 : so far.
13690 :
13691 : Optimization is done using F-rcomm interface:
13692 : * ArmijoCreate initializes State structure
13693 : (reusing previously allocated buffers)
13694 : * ArmijoIteration is subsequently called
13695 : * ArmijoResults returns results
13696 :
13697 : INPUT PARAMETERS:
13698 : N - problem size
13699 : X - array[N], starting point
13700 : F - F(X+S*STP)
13701 : S - step direction, S>0
13702 : STP - step length
13703 : STPMAX - maximum value for STP or zero (if no limit is imposed)
13704 : FMAX - maximum number of function evaluations
13705 : State - optimization state
13706 :
13707 : -- ALGLIB --
13708 : Copyright 05.10.2010 by Bochkanov Sergey
13709 : *************************************************************************/
13710 0 : void armijocreate(ae_int_t n,
13711 : /* Real */ ae_vector* x,
13712 : double f,
13713 : /* Real */ ae_vector* s,
13714 : double stp,
13715 : double stpmax,
13716 : ae_int_t fmax,
13717 : armijostate* state,
13718 : ae_state *_state)
13719 : {
13720 :
13721 :
13722 0 : if( state->x.cnt<n )
13723 : {
13724 0 : ae_vector_set_length(&state->x, n, _state);
13725 : }
13726 0 : if( state->xbase.cnt<n )
13727 : {
13728 0 : ae_vector_set_length(&state->xbase, n, _state);
13729 : }
13730 0 : if( state->s.cnt<n )
13731 : {
13732 0 : ae_vector_set_length(&state->s, n, _state);
13733 : }
13734 0 : state->stpmax = stpmax;
13735 0 : state->fmax = fmax;
13736 0 : state->stplen = stp;
13737 0 : state->fcur = f;
13738 0 : state->n = n;
13739 0 : ae_v_move(&state->xbase.ptr.p_double[0], 1, &x->ptr.p_double[0], 1, ae_v_len(0,n-1));
13740 0 : ae_v_move(&state->s.ptr.p_double[0], 1, &s->ptr.p_double[0], 1, ae_v_len(0,n-1));
13741 0 : ae_vector_set_length(&state->rstate.ia, 0+1, _state);
13742 0 : ae_vector_set_length(&state->rstate.ra, 0+1, _state);
13743 0 : state->rstate.stage = -1;
13744 0 : }
13745 :
13746 :
13747 : /*************************************************************************
13748 : This is rcomm-based search function
13749 :
13750 : -- ALGLIB --
13751 : Copyright 05.10.2010 by Bochkanov Sergey
13752 : *************************************************************************/
13753 0 : ae_bool armijoiteration(armijostate* state, ae_state *_state)
13754 : {
13755 : double v;
13756 : ae_int_t n;
13757 : ae_bool result;
13758 :
13759 :
13760 :
13761 : /*
13762 : * Reverse communication preparations
13763 : * I know it looks ugly, but it works the same way
13764 : * anywhere from C++ to Python.
13765 : *
13766 : * This code initializes locals by:
13767 : * * random values determined during code
13768 : * generation - on first subroutine call
13769 : * * values from previous call - on subsequent calls
13770 : */
13771 0 : if( state->rstate.stage>=0 )
13772 : {
13773 0 : n = state->rstate.ia.ptr.p_int[0];
13774 0 : v = state->rstate.ra.ptr.p_double[0];
13775 : }
13776 : else
13777 : {
13778 0 : n = 359;
13779 0 : v = -58;
13780 : }
13781 0 : if( state->rstate.stage==0 )
13782 : {
13783 0 : goto lbl_0;
13784 : }
13785 0 : if( state->rstate.stage==1 )
13786 : {
13787 0 : goto lbl_1;
13788 : }
13789 0 : if( state->rstate.stage==2 )
13790 : {
13791 0 : goto lbl_2;
13792 : }
13793 0 : if( state->rstate.stage==3 )
13794 : {
13795 0 : goto lbl_3;
13796 : }
13797 :
13798 : /*
13799 : * Routine body
13800 : */
13801 0 : if( (ae_fp_less_eq(state->stplen,(double)(0))||ae_fp_less(state->stpmax,(double)(0)))||state->fmax<2 )
13802 : {
13803 0 : state->info = 0;
13804 0 : result = ae_false;
13805 0 : return result;
13806 : }
13807 0 : if( ae_fp_less_eq(state->stplen,linmin_stpmin) )
13808 : {
13809 0 : state->info = 4;
13810 0 : result = ae_false;
13811 0 : return result;
13812 : }
13813 0 : n = state->n;
13814 0 : state->nfev = 0;
13815 :
13816 : /*
13817 : * We always need F
13818 : */
13819 0 : state->needf = ae_true;
13820 :
13821 : /*
13822 : * Bound StpLen
13823 : */
13824 0 : if( ae_fp_greater(state->stplen,state->stpmax)&&ae_fp_neq(state->stpmax,(double)(0)) )
13825 : {
13826 0 : state->stplen = state->stpmax;
13827 : }
13828 :
13829 : /*
13830 : * Increase length
13831 : */
13832 0 : v = state->stplen*linmin_armijofactor;
13833 0 : if( ae_fp_greater(v,state->stpmax)&&ae_fp_neq(state->stpmax,(double)(0)) )
13834 : {
13835 0 : v = state->stpmax;
13836 : }
13837 0 : ae_v_move(&state->x.ptr.p_double[0], 1, &state->xbase.ptr.p_double[0], 1, ae_v_len(0,n-1));
13838 0 : ae_v_addd(&state->x.ptr.p_double[0], 1, &state->s.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
13839 0 : state->rstate.stage = 0;
13840 0 : goto lbl_rcomm;
13841 0 : lbl_0:
13842 0 : state->nfev = state->nfev+1;
13843 0 : if( ae_fp_greater_eq(state->f,state->fcur) )
13844 : {
13845 0 : goto lbl_4;
13846 : }
13847 0 : state->stplen = v;
13848 0 : state->fcur = state->f;
13849 0 : lbl_6:
13850 : if( ae_false )
13851 : {
13852 : goto lbl_7;
13853 : }
13854 :
13855 : /*
13856 : * test stopping conditions
13857 : */
13858 0 : if( state->nfev>=state->fmax )
13859 : {
13860 0 : state->info = 3;
13861 0 : result = ae_false;
13862 0 : return result;
13863 : }
13864 0 : if( ae_fp_greater_eq(state->stplen,state->stpmax) )
13865 : {
13866 0 : state->info = 5;
13867 0 : result = ae_false;
13868 0 : return result;
13869 : }
13870 :
13871 : /*
13872 : * evaluate F
13873 : */
13874 0 : v = state->stplen*linmin_armijofactor;
13875 0 : if( ae_fp_greater(v,state->stpmax)&&ae_fp_neq(state->stpmax,(double)(0)) )
13876 : {
13877 0 : v = state->stpmax;
13878 : }
13879 0 : ae_v_move(&state->x.ptr.p_double[0], 1, &state->xbase.ptr.p_double[0], 1, ae_v_len(0,n-1));
13880 0 : ae_v_addd(&state->x.ptr.p_double[0], 1, &state->s.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
13881 0 : state->rstate.stage = 1;
13882 0 : goto lbl_rcomm;
13883 0 : lbl_1:
13884 0 : state->nfev = state->nfev+1;
13885 :
13886 : /*
13887 : * make decision
13888 : */
13889 0 : if( ae_fp_less(state->f,state->fcur) )
13890 : {
13891 0 : state->stplen = v;
13892 0 : state->fcur = state->f;
13893 : }
13894 : else
13895 : {
13896 0 : state->info = 1;
13897 0 : result = ae_false;
13898 0 : return result;
13899 : }
13900 0 : goto lbl_6;
13901 : lbl_7:
13902 0 : lbl_4:
13903 :
13904 : /*
13905 : * Decrease length
13906 : */
13907 0 : v = state->stplen/linmin_armijofactor;
13908 0 : ae_v_move(&state->x.ptr.p_double[0], 1, &state->xbase.ptr.p_double[0], 1, ae_v_len(0,n-1));
13909 0 : ae_v_addd(&state->x.ptr.p_double[0], 1, &state->s.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
13910 0 : state->rstate.stage = 2;
13911 0 : goto lbl_rcomm;
13912 0 : lbl_2:
13913 0 : state->nfev = state->nfev+1;
13914 0 : if( ae_fp_greater_eq(state->f,state->fcur) )
13915 : {
13916 0 : goto lbl_8;
13917 : }
13918 0 : state->stplen = state->stplen/linmin_armijofactor;
13919 0 : state->fcur = state->f;
13920 0 : lbl_10:
13921 : if( ae_false )
13922 : {
13923 : goto lbl_11;
13924 : }
13925 :
13926 : /*
13927 : * test stopping conditions
13928 : */
13929 0 : if( state->nfev>=state->fmax )
13930 : {
13931 0 : state->info = 3;
13932 0 : result = ae_false;
13933 0 : return result;
13934 : }
13935 0 : if( ae_fp_less_eq(state->stplen,linmin_stpmin) )
13936 : {
13937 0 : state->info = 4;
13938 0 : result = ae_false;
13939 0 : return result;
13940 : }
13941 :
13942 : /*
13943 : * evaluate F
13944 : */
13945 0 : v = state->stplen/linmin_armijofactor;
13946 0 : ae_v_move(&state->x.ptr.p_double[0], 1, &state->xbase.ptr.p_double[0], 1, ae_v_len(0,n-1));
13947 0 : ae_v_addd(&state->x.ptr.p_double[0], 1, &state->s.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
13948 0 : state->rstate.stage = 3;
13949 0 : goto lbl_rcomm;
13950 0 : lbl_3:
13951 0 : state->nfev = state->nfev+1;
13952 :
13953 : /*
13954 : * make decision
13955 : */
13956 0 : if( ae_fp_less(state->f,state->fcur) )
13957 : {
13958 0 : state->stplen = state->stplen/linmin_armijofactor;
13959 0 : state->fcur = state->f;
13960 : }
13961 : else
13962 : {
13963 0 : state->info = 1;
13964 0 : result = ae_false;
13965 0 : return result;
13966 : }
13967 0 : goto lbl_10;
13968 : lbl_11:
13969 0 : lbl_8:
13970 :
13971 : /*
13972 : * Nothing to be done
13973 : */
13974 0 : state->info = 1;
13975 0 : result = ae_false;
13976 0 : return result;
13977 :
13978 : /*
13979 : * Saving state
13980 : */
13981 0 : lbl_rcomm:
13982 0 : result = ae_true;
13983 0 : state->rstate.ia.ptr.p_int[0] = n;
13984 0 : state->rstate.ra.ptr.p_double[0] = v;
13985 0 : return result;
13986 : }
13987 :
13988 :
13989 : /*************************************************************************
13990 : Results of Armijo search
13991 :
13992 : OUTPUT PARAMETERS:
13993 : INFO - on output it is set to one of the return codes:
13994 : * 0 improper input params
13995 : * 1 optimum step is found with at most FMAX evaluations
13996 : * 3 FMAX evaluations were used,
13997 : X contains optimum found so far
13998 : * 4 step is at lower bound STPMIN
13999 : * 5 step is at upper bound
14000 : STP - step length (in case of failure it is still returned)
14001 : F - function value (in case of failure it is still returned)
14002 :
14003 : -- ALGLIB --
14004 : Copyright 05.10.2010 by Bochkanov Sergey
14005 : *************************************************************************/
14006 0 : void armijoresults(armijostate* state,
14007 : ae_int_t* info,
14008 : double* stp,
14009 : double* f,
14010 : ae_state *_state)
14011 : {
14012 :
14013 :
14014 0 : *info = state->info;
14015 0 : *stp = state->stplen;
14016 0 : *f = state->fcur;
14017 0 : }
14018 :
14019 :
14020 0 : static void linmin_mcstep(double* stx,
14021 : double* fx,
14022 : double* dx,
14023 : double* sty,
14024 : double* fy,
14025 : double* dy,
14026 : double* stp,
14027 : double fp,
14028 : double dp,
14029 : ae_bool* brackt,
14030 : double stmin,
14031 : double stmax,
14032 : ae_int_t* info,
14033 : ae_state *_state)
14034 : {
14035 : ae_bool bound;
14036 : double gamma;
14037 : double p;
14038 : double q;
14039 : double r;
14040 : double s;
14041 : double sgnd;
14042 : double stpc;
14043 : double stpf;
14044 : double stpq;
14045 : double theta;
14046 :
14047 :
14048 0 : *info = 0;
14049 :
14050 : /*
14051 : * CHECK THE INPUT PARAMETERS FOR ERRORS.
14052 : */
14053 0 : if( ((*brackt&&(ae_fp_less_eq(*stp,ae_minreal(*stx, *sty, _state))||ae_fp_greater_eq(*stp,ae_maxreal(*stx, *sty, _state))))||ae_fp_greater_eq(*dx*(*stp-(*stx)),(double)(0)))||ae_fp_less(stmax,stmin) )
14054 : {
14055 0 : return;
14056 : }
14057 :
14058 : /*
14059 : * DETERMINE IF THE DERIVATIVES HAVE OPPOSITE SIGN.
14060 : */
14061 0 : sgnd = dp*(*dx/ae_fabs(*dx, _state));
14062 :
14063 : /*
14064 : * FIRST CASE. A HIGHER FUNCTION VALUE.
14065 : * THE MINIMUM IS BRACKETED. IF THE CUBIC STEP IS CLOSER
14066 : * TO STX THAN THE QUADRATIC STEP, THE CUBIC STEP IS TAKEN,
14067 : * ELSE THE AVERAGE OF THE CUBIC AND QUADRATIC STEPS IS TAKEN.
14068 : */
14069 0 : if( ae_fp_greater(fp,*fx) )
14070 : {
14071 0 : *info = 1;
14072 0 : bound = ae_true;
14073 0 : theta = 3*(*fx-fp)/(*stp-(*stx))+(*dx)+dp;
14074 0 : s = ae_maxreal(ae_fabs(theta, _state), ae_maxreal(ae_fabs(*dx, _state), ae_fabs(dp, _state), _state), _state);
14075 0 : gamma = s*ae_sqrt(ae_sqr(theta/s, _state)-*dx/s*(dp/s), _state);
14076 0 : if( ae_fp_less(*stp,*stx) )
14077 : {
14078 0 : gamma = -gamma;
14079 : }
14080 0 : p = gamma-(*dx)+theta;
14081 0 : q = gamma-(*dx)+gamma+dp;
14082 0 : r = p/q;
14083 0 : stpc = *stx+r*(*stp-(*stx));
14084 0 : stpq = *stx+*dx/((*fx-fp)/(*stp-(*stx))+(*dx))/2*(*stp-(*stx));
14085 0 : if( ae_fp_less(ae_fabs(stpc-(*stx), _state),ae_fabs(stpq-(*stx), _state)) )
14086 : {
14087 0 : stpf = stpc;
14088 : }
14089 : else
14090 : {
14091 0 : stpf = stpc+(stpq-stpc)/2;
14092 : }
14093 0 : *brackt = ae_true;
14094 : }
14095 : else
14096 : {
14097 0 : if( ae_fp_less(sgnd,(double)(0)) )
14098 : {
14099 :
14100 : /*
14101 : * SECOND CASE. A LOWER FUNCTION VALUE AND DERIVATIVES OF
14102 : * OPPOSITE SIGN. THE MINIMUM IS BRACKETED. IF THE CUBIC
14103 : * STEP IS CLOSER TO STX THAN THE QUADRATIC (SECANT) STEP,
14104 : * THE CUBIC STEP IS TAKEN, ELSE THE QUADRATIC STEP IS TAKEN.
14105 : */
14106 0 : *info = 2;
14107 0 : bound = ae_false;
14108 0 : theta = 3*(*fx-fp)/(*stp-(*stx))+(*dx)+dp;
14109 0 : s = ae_maxreal(ae_fabs(theta, _state), ae_maxreal(ae_fabs(*dx, _state), ae_fabs(dp, _state), _state), _state);
14110 0 : gamma = s*ae_sqrt(ae_sqr(theta/s, _state)-*dx/s*(dp/s), _state);
14111 0 : if( ae_fp_greater(*stp,*stx) )
14112 : {
14113 0 : gamma = -gamma;
14114 : }
14115 0 : p = gamma-dp+theta;
14116 0 : q = gamma-dp+gamma+(*dx);
14117 0 : r = p/q;
14118 0 : stpc = *stp+r*(*stx-(*stp));
14119 0 : stpq = *stp+dp/(dp-(*dx))*(*stx-(*stp));
14120 0 : if( ae_fp_greater(ae_fabs(stpc-(*stp), _state),ae_fabs(stpq-(*stp), _state)) )
14121 : {
14122 0 : stpf = stpc;
14123 : }
14124 : else
14125 : {
14126 0 : stpf = stpq;
14127 : }
14128 0 : *brackt = ae_true;
14129 : }
14130 : else
14131 : {
14132 0 : if( ae_fp_less(ae_fabs(dp, _state),ae_fabs(*dx, _state)) )
14133 : {
14134 :
14135 : /*
14136 : * THIRD CASE. A LOWER FUNCTION VALUE, DERIVATIVES OF THE
14137 : * SAME SIGN, AND THE MAGNITUDE OF THE DERIVATIVE DECREASES.
14138 : * THE CUBIC STEP IS ONLY USED IF THE CUBIC TENDS TO INFINITY
14139 : * IN THE DIRECTION OF THE STEP OR IF THE MINIMUM OF THE CUBIC
14140 : * IS BEYOND STP. OTHERWISE THE CUBIC STEP IS DEFINED TO BE
14141 : * EITHER STPMIN OR STPMAX. THE QUADRATIC (SECANT) STEP IS ALSO
14142 : * COMPUTED AND IF THE MINIMUM IS BRACKETED THEN THE THE STEP
14143 : * CLOSEST TO STX IS TAKEN, ELSE THE STEP FARTHEST AWAY IS TAKEN.
14144 : */
14145 0 : *info = 3;
14146 0 : bound = ae_true;
14147 0 : theta = 3*(*fx-fp)/(*stp-(*stx))+(*dx)+dp;
14148 0 : s = ae_maxreal(ae_fabs(theta, _state), ae_maxreal(ae_fabs(*dx, _state), ae_fabs(dp, _state), _state), _state);
14149 :
14150 : /*
14151 : * THE CASE GAMMA = 0 ONLY ARISES IF THE CUBIC DOES NOT TEND
14152 : * TO INFINITY IN THE DIRECTION OF THE STEP.
14153 : */
14154 0 : gamma = s*ae_sqrt(ae_maxreal((double)(0), ae_sqr(theta/s, _state)-*dx/s*(dp/s), _state), _state);
14155 0 : if( ae_fp_greater(*stp,*stx) )
14156 : {
14157 0 : gamma = -gamma;
14158 : }
14159 0 : p = gamma-dp+theta;
14160 0 : q = gamma+(*dx-dp)+gamma;
14161 0 : r = p/q;
14162 0 : if( ae_fp_less(r,(double)(0))&&ae_fp_neq(gamma,(double)(0)) )
14163 : {
14164 0 : stpc = *stp+r*(*stx-(*stp));
14165 : }
14166 : else
14167 : {
14168 0 : if( ae_fp_greater(*stp,*stx) )
14169 : {
14170 0 : stpc = stmax;
14171 : }
14172 : else
14173 : {
14174 0 : stpc = stmin;
14175 : }
14176 : }
14177 0 : stpq = *stp+dp/(dp-(*dx))*(*stx-(*stp));
14178 0 : if( *brackt )
14179 : {
14180 0 : if( ae_fp_less(ae_fabs(*stp-stpc, _state),ae_fabs(*stp-stpq, _state)) )
14181 : {
14182 0 : stpf = stpc;
14183 : }
14184 : else
14185 : {
14186 0 : stpf = stpq;
14187 : }
14188 : }
14189 : else
14190 : {
14191 0 : if( ae_fp_greater(ae_fabs(*stp-stpc, _state),ae_fabs(*stp-stpq, _state)) )
14192 : {
14193 0 : stpf = stpc;
14194 : }
14195 : else
14196 : {
14197 0 : stpf = stpq;
14198 : }
14199 : }
14200 : }
14201 : else
14202 : {
14203 :
14204 : /*
14205 : * FOURTH CASE. A LOWER FUNCTION VALUE, DERIVATIVES OF THE
14206 : * SAME SIGN, AND THE MAGNITUDE OF THE DERIVATIVE DOES
14207 : * NOT DECREASE. IF THE MINIMUM IS NOT BRACKETED, THE STEP
14208 : * IS EITHER STPMIN OR STPMAX, ELSE THE CUBIC STEP IS TAKEN.
14209 : */
14210 0 : *info = 4;
14211 0 : bound = ae_false;
14212 0 : if( *brackt )
14213 : {
14214 0 : theta = 3*(fp-(*fy))/(*sty-(*stp))+(*dy)+dp;
14215 0 : s = ae_maxreal(ae_fabs(theta, _state), ae_maxreal(ae_fabs(*dy, _state), ae_fabs(dp, _state), _state), _state);
14216 0 : gamma = s*ae_sqrt(ae_sqr(theta/s, _state)-*dy/s*(dp/s), _state);
14217 0 : if( ae_fp_greater(*stp,*sty) )
14218 : {
14219 0 : gamma = -gamma;
14220 : }
14221 0 : p = gamma-dp+theta;
14222 0 : q = gamma-dp+gamma+(*dy);
14223 0 : r = p/q;
14224 0 : stpc = *stp+r*(*sty-(*stp));
14225 0 : stpf = stpc;
14226 : }
14227 : else
14228 : {
14229 0 : if( ae_fp_greater(*stp,*stx) )
14230 : {
14231 0 : stpf = stmax;
14232 : }
14233 : else
14234 : {
14235 0 : stpf = stmin;
14236 : }
14237 : }
14238 : }
14239 : }
14240 : }
14241 :
14242 : /*
14243 : * UPDATE THE INTERVAL OF UNCERTAINTY. THIS UPDATE DOES NOT
14244 : * DEPEND ON THE NEW STEP OR THE CASE ANALYSIS ABOVE.
14245 : */
14246 0 : if( ae_fp_greater(fp,*fx) )
14247 : {
14248 0 : *sty = *stp;
14249 0 : *fy = fp;
14250 0 : *dy = dp;
14251 : }
14252 : else
14253 : {
14254 0 : if( ae_fp_less(sgnd,0.0) )
14255 : {
14256 0 : *sty = *stx;
14257 0 : *fy = *fx;
14258 0 : *dy = *dx;
14259 : }
14260 0 : *stx = *stp;
14261 0 : *fx = fp;
14262 0 : *dx = dp;
14263 : }
14264 :
14265 : /*
14266 : * COMPUTE THE NEW STEP AND SAFEGUARD IT.
14267 : */
14268 0 : stpf = ae_minreal(stmax, stpf, _state);
14269 0 : stpf = ae_maxreal(stmin, stpf, _state);
14270 0 : *stp = stpf;
14271 0 : if( *brackt&&bound )
14272 : {
14273 0 : if( ae_fp_greater(*sty,*stx) )
14274 : {
14275 0 : *stp = ae_minreal(*stx+0.66*(*sty-(*stx)), *stp, _state);
14276 : }
14277 : else
14278 : {
14279 0 : *stp = ae_maxreal(*stx+0.66*(*sty-(*stx)), *stp, _state);
14280 : }
14281 : }
14282 : }
14283 :
14284 :
14285 0 : void _linminstate_init(void* _p, ae_state *_state, ae_bool make_automatic)
14286 : {
14287 0 : linminstate *p = (linminstate*)_p;
14288 0 : ae_touch_ptr((void*)p);
14289 0 : }
14290 :
14291 :
14292 0 : void _linminstate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
14293 : {
14294 0 : linminstate *dst = (linminstate*)_dst;
14295 0 : linminstate *src = (linminstate*)_src;
14296 0 : dst->brackt = src->brackt;
14297 0 : dst->stage1 = src->stage1;
14298 0 : dst->infoc = src->infoc;
14299 0 : dst->dg = src->dg;
14300 0 : dst->dgm = src->dgm;
14301 0 : dst->dginit = src->dginit;
14302 0 : dst->dgtest = src->dgtest;
14303 0 : dst->dgx = src->dgx;
14304 0 : dst->dgxm = src->dgxm;
14305 0 : dst->dgy = src->dgy;
14306 0 : dst->dgym = src->dgym;
14307 0 : dst->finit = src->finit;
14308 0 : dst->ftest1 = src->ftest1;
14309 0 : dst->fm = src->fm;
14310 0 : dst->fx = src->fx;
14311 0 : dst->fxm = src->fxm;
14312 0 : dst->fy = src->fy;
14313 0 : dst->fym = src->fym;
14314 0 : dst->stx = src->stx;
14315 0 : dst->sty = src->sty;
14316 0 : dst->stmin = src->stmin;
14317 0 : dst->stmax = src->stmax;
14318 0 : dst->width = src->width;
14319 0 : dst->width1 = src->width1;
14320 0 : dst->xtrapf = src->xtrapf;
14321 0 : }
14322 :
14323 :
14324 0 : void _linminstate_clear(void* _p)
14325 : {
14326 0 : linminstate *p = (linminstate*)_p;
14327 0 : ae_touch_ptr((void*)p);
14328 0 : }
14329 :
14330 :
14331 0 : void _linminstate_destroy(void* _p)
14332 : {
14333 0 : linminstate *p = (linminstate*)_p;
14334 0 : ae_touch_ptr((void*)p);
14335 0 : }
14336 :
14337 :
14338 0 : void _armijostate_init(void* _p, ae_state *_state, ae_bool make_automatic)
14339 : {
14340 0 : armijostate *p = (armijostate*)_p;
14341 0 : ae_touch_ptr((void*)p);
14342 0 : ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic);
14343 0 : ae_vector_init(&p->xbase, 0, DT_REAL, _state, make_automatic);
14344 0 : ae_vector_init(&p->s, 0, DT_REAL, _state, make_automatic);
14345 0 : _rcommstate_init(&p->rstate, _state, make_automatic);
14346 0 : }
14347 :
14348 :
14349 0 : void _armijostate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
14350 : {
14351 0 : armijostate *dst = (armijostate*)_dst;
14352 0 : armijostate *src = (armijostate*)_src;
14353 0 : dst->needf = src->needf;
14354 0 : ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic);
14355 0 : dst->f = src->f;
14356 0 : dst->n = src->n;
14357 0 : ae_vector_init_copy(&dst->xbase, &src->xbase, _state, make_automatic);
14358 0 : ae_vector_init_copy(&dst->s, &src->s, _state, make_automatic);
14359 0 : dst->stplen = src->stplen;
14360 0 : dst->fcur = src->fcur;
14361 0 : dst->stpmax = src->stpmax;
14362 0 : dst->fmax = src->fmax;
14363 0 : dst->nfev = src->nfev;
14364 0 : dst->info = src->info;
14365 0 : _rcommstate_init_copy(&dst->rstate, &src->rstate, _state, make_automatic);
14366 0 : }
14367 :
14368 :
14369 0 : void _armijostate_clear(void* _p)
14370 : {
14371 0 : armijostate *p = (armijostate*)_p;
14372 0 : ae_touch_ptr((void*)p);
14373 0 : ae_vector_clear(&p->x);
14374 0 : ae_vector_clear(&p->xbase);
14375 0 : ae_vector_clear(&p->s);
14376 0 : _rcommstate_clear(&p->rstate);
14377 0 : }
14378 :
14379 :
14380 0 : void _armijostate_destroy(void* _p)
14381 : {
14382 0 : armijostate *p = (armijostate*)_p;
14383 0 : ae_touch_ptr((void*)p);
14384 0 : ae_vector_destroy(&p->x);
14385 0 : ae_vector_destroy(&p->xbase);
14386 0 : ae_vector_destroy(&p->s);
14387 0 : _rcommstate_destroy(&p->rstate);
14388 0 : }
14389 :
14390 :
14391 : #endif
14392 : #if defined(AE_COMPILE_XBLAS) || !defined(AE_PARTIAL_BUILD)
14393 :
14394 :
14395 : /*************************************************************************
14396 : More precise dot-product. Absolute error of subroutine result is about
14397 : 1 ulp of max(MX,V), where:
14398 : MX = max( |a[i]*b[i]| )
14399 : V = |(a,b)|
14400 :
14401 : INPUT PARAMETERS
14402 : A - array[0..N-1], vector 1
14403 : B - array[0..N-1], vector 2
14404 : N - vectors length, N<2^29.
14405 : Temp - array[0..N-1], pre-allocated temporary storage
14406 :
14407 : OUTPUT PARAMETERS
14408 : R - (A,B)
14409 : RErr - estimate of error. This estimate accounts for both errors
14410 : during calculation of (A,B) and errors introduced by
14411 : rounding of A and B to fit in double (about 1 ulp).
14412 :
14413 : -- ALGLIB --
14414 : Copyright 24.08.2009 by Bochkanov Sergey
14415 : *************************************************************************/
14416 0 : void xdot(/* Real */ ae_vector* a,
14417 : /* Real */ ae_vector* b,
14418 : ae_int_t n,
14419 : /* Real */ ae_vector* temp,
14420 : double* r,
14421 : double* rerr,
14422 : ae_state *_state)
14423 : {
14424 : ae_int_t i;
14425 : double mx;
14426 : double v;
14427 :
14428 0 : *r = 0;
14429 0 : *rerr = 0;
14430 :
14431 :
14432 : /*
14433 : * special cases:
14434 : * * N=0
14435 : */
14436 0 : if( n==0 )
14437 : {
14438 0 : *r = (double)(0);
14439 0 : *rerr = (double)(0);
14440 0 : return;
14441 : }
14442 0 : mx = (double)(0);
14443 0 : for(i=0; i<=n-1; i++)
14444 : {
14445 0 : v = a->ptr.p_double[i]*b->ptr.p_double[i];
14446 0 : temp->ptr.p_double[i] = v;
14447 0 : mx = ae_maxreal(mx, ae_fabs(v, _state), _state);
14448 : }
14449 0 : if( ae_fp_eq(mx,(double)(0)) )
14450 : {
14451 0 : *r = (double)(0);
14452 0 : *rerr = (double)(0);
14453 0 : return;
14454 : }
14455 0 : xblas_xsum(temp, mx, n, r, rerr, _state);
14456 : }
14457 :
14458 :
14459 : /*************************************************************************
14460 : More precise complex dot-product. Absolute error of subroutine result is
14461 : about 1 ulp of max(MX,V), where:
14462 : MX = max( |a[i]*b[i]| )
14463 : V = |(a,b)|
14464 :
14465 : INPUT PARAMETERS
14466 : A - array[0..N-1], vector 1
14467 : B - array[0..N-1], vector 2
14468 : N - vectors length, N<2^29.
14469 : Temp - array[0..2*N-1], pre-allocated temporary storage
14470 :
14471 : OUTPUT PARAMETERS
14472 : R - (A,B)
14473 : RErr - estimate of error. This estimate accounts for both errors
14474 : during calculation of (A,B) and errors introduced by
14475 : rounding of A and B to fit in double (about 1 ulp).
14476 :
14477 : -- ALGLIB --
14478 : Copyright 27.01.2010 by Bochkanov Sergey
14479 : *************************************************************************/
14480 0 : void xcdot(/* Complex */ ae_vector* a,
14481 : /* Complex */ ae_vector* b,
14482 : ae_int_t n,
14483 : /* Real */ ae_vector* temp,
14484 : ae_complex* r,
14485 : double* rerr,
14486 : ae_state *_state)
14487 : {
14488 : ae_int_t i;
14489 : double mx;
14490 : double v;
14491 : double rerrx;
14492 : double rerry;
14493 :
14494 0 : r->x = 0;
14495 0 : r->y = 0;
14496 0 : *rerr = 0;
14497 :
14498 :
14499 : /*
14500 : * special cases:
14501 : * * N=0
14502 : */
14503 0 : if( n==0 )
14504 : {
14505 0 : *r = ae_complex_from_i(0);
14506 0 : *rerr = (double)(0);
14507 0 : return;
14508 : }
14509 :
14510 : /*
14511 : * calculate real part
14512 : */
14513 0 : mx = (double)(0);
14514 0 : for(i=0; i<=n-1; i++)
14515 : {
14516 0 : v = a->ptr.p_complex[i].x*b->ptr.p_complex[i].x;
14517 0 : temp->ptr.p_double[2*i+0] = v;
14518 0 : mx = ae_maxreal(mx, ae_fabs(v, _state), _state);
14519 0 : v = -a->ptr.p_complex[i].y*b->ptr.p_complex[i].y;
14520 0 : temp->ptr.p_double[2*i+1] = v;
14521 0 : mx = ae_maxreal(mx, ae_fabs(v, _state), _state);
14522 : }
14523 0 : if( ae_fp_eq(mx,(double)(0)) )
14524 : {
14525 0 : r->x = (double)(0);
14526 0 : rerrx = (double)(0);
14527 : }
14528 : else
14529 : {
14530 0 : xblas_xsum(temp, mx, 2*n, &r->x, &rerrx, _state);
14531 : }
14532 :
14533 : /*
14534 : * calculate imaginary part
14535 : */
14536 0 : mx = (double)(0);
14537 0 : for(i=0; i<=n-1; i++)
14538 : {
14539 0 : v = a->ptr.p_complex[i].x*b->ptr.p_complex[i].y;
14540 0 : temp->ptr.p_double[2*i+0] = v;
14541 0 : mx = ae_maxreal(mx, ae_fabs(v, _state), _state);
14542 0 : v = a->ptr.p_complex[i].y*b->ptr.p_complex[i].x;
14543 0 : temp->ptr.p_double[2*i+1] = v;
14544 0 : mx = ae_maxreal(mx, ae_fabs(v, _state), _state);
14545 : }
14546 0 : if( ae_fp_eq(mx,(double)(0)) )
14547 : {
14548 0 : r->y = (double)(0);
14549 0 : rerry = (double)(0);
14550 : }
14551 : else
14552 : {
14553 0 : xblas_xsum(temp, mx, 2*n, &r->y, &rerry, _state);
14554 : }
14555 :
14556 : /*
14557 : * total error
14558 : */
14559 0 : if( ae_fp_eq(rerrx,(double)(0))&&ae_fp_eq(rerry,(double)(0)) )
14560 : {
14561 0 : *rerr = (double)(0);
14562 : }
14563 : else
14564 : {
14565 0 : *rerr = ae_maxreal(rerrx, rerry, _state)*ae_sqrt(1+ae_sqr(ae_minreal(rerrx, rerry, _state)/ae_maxreal(rerrx, rerry, _state), _state), _state);
14566 : }
14567 : }
14568 :
14569 :
14570 : /*************************************************************************
14571 : Internal subroutine for extra-precise calculation of SUM(w[i]).
14572 :
14573 : INPUT PARAMETERS:
14574 : W - array[0..N-1], values to be added
14575 : W is modified during calculations.
14576 : MX - max(W[i])
14577 : N - array size
14578 :
14579 : OUTPUT PARAMETERS:
14580 : R - SUM(w[i])
14581 : RErr- error estimate for R
14582 :
14583 : -- ALGLIB --
14584 : Copyright 24.08.2009 by Bochkanov Sergey
14585 : *************************************************************************/
14586 0 : static void xblas_xsum(/* Real */ ae_vector* w,
14587 : double mx,
14588 : ae_int_t n,
14589 : double* r,
14590 : double* rerr,
14591 : ae_state *_state)
14592 : {
14593 : ae_int_t i;
14594 : ae_int_t k;
14595 : ae_int_t ks;
14596 : double v;
14597 : double s;
14598 : double ln2;
14599 : double chunk;
14600 : double invchunk;
14601 : ae_bool allzeros;
14602 :
14603 0 : *r = 0;
14604 0 : *rerr = 0;
14605 :
14606 :
14607 : /*
14608 : * special cases:
14609 : * * N=0
14610 : * * N is too large to use integer arithmetics
14611 : */
14612 0 : if( n==0 )
14613 : {
14614 0 : *r = (double)(0);
14615 0 : *rerr = (double)(0);
14616 0 : return;
14617 : }
14618 0 : if( ae_fp_eq(mx,(double)(0)) )
14619 : {
14620 0 : *r = (double)(0);
14621 0 : *rerr = (double)(0);
14622 0 : return;
14623 : }
14624 0 : ae_assert(n<536870912, "XDot: N is too large!", _state);
14625 :
14626 : /*
14627 : * Prepare
14628 : */
14629 0 : ln2 = ae_log((double)(2), _state);
14630 0 : *rerr = mx*ae_machineepsilon;
14631 :
14632 : /*
14633 : * 1. find S such that 0.5<=S*MX<1
14634 : * 2. multiply W by S, so task is normalized in some sense
14635 : * 3. S:=1/S so we can obtain original vector multiplying by S
14636 : */
14637 0 : k = ae_round(ae_log(mx, _state)/ln2, _state);
14638 0 : s = xblas_xfastpow((double)(2), -k, _state);
14639 0 : if( !ae_isfinite(s, _state) )
14640 : {
14641 :
14642 : /*
14643 : * Overflow or underflow during evaluation of S; fallback low-precision code
14644 : */
14645 0 : *r = (double)(0);
14646 0 : *rerr = mx*ae_machineepsilon;
14647 0 : for(i=0; i<=n-1; i++)
14648 : {
14649 0 : *r = *r+w->ptr.p_double[i];
14650 : }
14651 0 : return;
14652 : }
14653 0 : while(ae_fp_greater_eq(s*mx,(double)(1)))
14654 : {
14655 0 : s = 0.5*s;
14656 : }
14657 0 : while(ae_fp_less(s*mx,0.5))
14658 : {
14659 0 : s = 2*s;
14660 : }
14661 0 : ae_v_muld(&w->ptr.p_double[0], 1, ae_v_len(0,n-1), s);
14662 0 : s = 1/s;
14663 :
14664 : /*
14665 : * find Chunk=2^M such that N*Chunk<2^29
14666 : *
14667 : * we have chosen upper limit (2^29) with enough space left
14668 : * to tolerate possible problems with rounding and N's close
14669 : * to the limit, so we don't want to be very strict here.
14670 : */
14671 0 : k = ae_trunc(ae_log((double)536870912/(double)n, _state)/ln2, _state);
14672 0 : chunk = xblas_xfastpow((double)(2), k, _state);
14673 0 : if( ae_fp_less(chunk,(double)(2)) )
14674 : {
14675 0 : chunk = (double)(2);
14676 : }
14677 0 : invchunk = 1/chunk;
14678 :
14679 : /*
14680 : * calculate result
14681 : */
14682 0 : *r = (double)(0);
14683 0 : ae_v_muld(&w->ptr.p_double[0], 1, ae_v_len(0,n-1), chunk);
14684 : for(;;)
14685 : {
14686 0 : s = s*invchunk;
14687 0 : allzeros = ae_true;
14688 0 : ks = 0;
14689 0 : for(i=0; i<=n-1; i++)
14690 : {
14691 0 : v = w->ptr.p_double[i];
14692 0 : k = ae_trunc(v, _state);
14693 0 : if( ae_fp_neq(v,(double)(k)) )
14694 : {
14695 0 : allzeros = ae_false;
14696 : }
14697 0 : w->ptr.p_double[i] = chunk*(v-k);
14698 0 : ks = ks+k;
14699 : }
14700 0 : *r = *r+s*ks;
14701 0 : v = ae_fabs(*r, _state);
14702 0 : if( allzeros||ae_fp_eq(s*n+mx,mx) )
14703 : {
14704 0 : break;
14705 : }
14706 : }
14707 :
14708 : /*
14709 : * correct error
14710 : */
14711 0 : *rerr = ae_maxreal(*rerr, ae_fabs(*r, _state)*ae_machineepsilon, _state);
14712 : }
14713 :
14714 :
14715 : /*************************************************************************
14716 : Fast Pow
14717 :
14718 : -- ALGLIB --
14719 : Copyright 24.08.2009 by Bochkanov Sergey
14720 : *************************************************************************/
14721 0 : static double xblas_xfastpow(double r, ae_int_t n, ae_state *_state)
14722 : {
14723 : double result;
14724 :
14725 :
14726 0 : result = (double)(0);
14727 0 : if( n>0 )
14728 : {
14729 0 : if( n%2==0 )
14730 : {
14731 0 : result = ae_sqr(xblas_xfastpow(r, n/2, _state), _state);
14732 : }
14733 : else
14734 : {
14735 0 : result = r*xblas_xfastpow(r, n-1, _state);
14736 : }
14737 0 : return result;
14738 : }
14739 0 : if( n==0 )
14740 : {
14741 0 : result = (double)(1);
14742 : }
14743 0 : if( n<0 )
14744 : {
14745 0 : result = xblas_xfastpow(1/r, -n, _state);
14746 : }
14747 0 : return result;
14748 : }
14749 :
14750 :
14751 : #endif
14752 : #if defined(AE_COMPILE_BASICSTATOPS) || !defined(AE_PARTIAL_BUILD)
14753 :
14754 :
14755 : /*************************************************************************
14756 : Internal tied ranking subroutine.
14757 :
14758 : INPUT PARAMETERS:
14759 : X - array to rank
14760 : N - array size
14761 : IsCentered- whether ranks are centered or not:
14762 : * True - ranks are centered in such way that their
14763 : sum is zero
14764 : * False - ranks are not centered
14765 : Buf - temporary buffers
14766 :
14767 : NOTE: when IsCentered is True and all X[] are equal, this function fills
14768 : X by zeros (exact zeros are used, not sum which is only approximately
14769 : equal to zero).
14770 : *************************************************************************/
14771 0 : void rankx(/* Real */ ae_vector* x,
14772 : ae_int_t n,
14773 : ae_bool iscentered,
14774 : apbuffers* buf,
14775 : ae_state *_state)
14776 : {
14777 : ae_int_t i;
14778 : ae_int_t j;
14779 : ae_int_t k;
14780 : double tmp;
14781 : double voffs;
14782 :
14783 :
14784 :
14785 : /*
14786 : * Prepare
14787 : */
14788 0 : if( n<1 )
14789 : {
14790 0 : return;
14791 : }
14792 0 : if( n==1 )
14793 : {
14794 0 : x->ptr.p_double[0] = (double)(0);
14795 0 : return;
14796 : }
14797 0 : if( buf->ra1.cnt<n )
14798 : {
14799 0 : ae_vector_set_length(&buf->ra1, n, _state);
14800 : }
14801 0 : if( buf->ia1.cnt<n )
14802 : {
14803 0 : ae_vector_set_length(&buf->ia1, n, _state);
14804 : }
14805 0 : for(i=0; i<=n-1; i++)
14806 : {
14807 0 : buf->ra1.ptr.p_double[i] = x->ptr.p_double[i];
14808 0 : buf->ia1.ptr.p_int[i] = i;
14809 : }
14810 0 : tagsortfasti(&buf->ra1, &buf->ia1, &buf->ra2, &buf->ia2, n, _state);
14811 :
14812 : /*
14813 : * Special test for all values being equal
14814 : */
14815 0 : if( ae_fp_eq(buf->ra1.ptr.p_double[0],buf->ra1.ptr.p_double[n-1]) )
14816 : {
14817 0 : if( iscentered )
14818 : {
14819 0 : tmp = 0.0;
14820 : }
14821 : else
14822 : {
14823 0 : tmp = (double)(n-1)/(double)2;
14824 : }
14825 0 : for(i=0; i<=n-1; i++)
14826 : {
14827 0 : x->ptr.p_double[i] = tmp;
14828 : }
14829 0 : return;
14830 : }
14831 :
14832 : /*
14833 : * compute tied ranks
14834 : */
14835 0 : i = 0;
14836 0 : while(i<=n-1)
14837 : {
14838 0 : j = i+1;
14839 0 : while(j<=n-1)
14840 : {
14841 0 : if( ae_fp_neq(buf->ra1.ptr.p_double[j],buf->ra1.ptr.p_double[i]) )
14842 : {
14843 0 : break;
14844 : }
14845 0 : j = j+1;
14846 : }
14847 0 : for(k=i; k<=j-1; k++)
14848 : {
14849 0 : buf->ra1.ptr.p_double[k] = (double)(i+j-1)/(double)2;
14850 : }
14851 0 : i = j;
14852 : }
14853 :
14854 : /*
14855 : * back to x
14856 : */
14857 0 : if( iscentered )
14858 : {
14859 0 : voffs = (double)(n-1)/(double)2;
14860 : }
14861 : else
14862 : {
14863 0 : voffs = 0.0;
14864 : }
14865 0 : for(i=0; i<=n-1; i++)
14866 : {
14867 0 : x->ptr.p_double[buf->ia1.ptr.p_int[i]] = buf->ra1.ptr.p_double[i]-voffs;
14868 : }
14869 : }
14870 :
14871 :
14872 : /*************************************************************************
14873 : Internal untied ranking subroutine.
14874 :
14875 : INPUT PARAMETERS:
14876 : X - array to rank
14877 : N - array size
14878 : Buf - temporary buffers
14879 :
14880 : Returns untied ranks (in case of a tie ranks are resolved arbitrarily).
14881 : *************************************************************************/
14882 0 : void rankxuntied(/* Real */ ae_vector* x,
14883 : ae_int_t n,
14884 : apbuffers* buf,
14885 : ae_state *_state)
14886 : {
14887 : ae_int_t i;
14888 :
14889 :
14890 :
14891 : /*
14892 : * Prepare
14893 : */
14894 0 : if( n<1 )
14895 : {
14896 0 : return;
14897 : }
14898 0 : if( n==1 )
14899 : {
14900 0 : x->ptr.p_double[0] = (double)(0);
14901 0 : return;
14902 : }
14903 0 : if( buf->ra1.cnt<n )
14904 : {
14905 0 : ae_vector_set_length(&buf->ra1, n, _state);
14906 : }
14907 0 : if( buf->ia1.cnt<n )
14908 : {
14909 0 : ae_vector_set_length(&buf->ia1, n, _state);
14910 : }
14911 0 : for(i=0; i<=n-1; i++)
14912 : {
14913 0 : buf->ra1.ptr.p_double[i] = x->ptr.p_double[i];
14914 0 : buf->ia1.ptr.p_int[i] = i;
14915 : }
14916 0 : tagsortfasti(&buf->ra1, &buf->ia1, &buf->ra2, &buf->ia2, n, _state);
14917 0 : for(i=0; i<=n-1; i++)
14918 : {
14919 0 : x->ptr.p_double[buf->ia1.ptr.p_int[i]] = (double)(i);
14920 : }
14921 : }
14922 :
14923 :
14924 : #endif
14925 : #if defined(AE_COMPILE_HPCCORES) || !defined(AE_PARTIAL_BUILD)
14926 :
14927 :
14928 : /*************************************************************************
14929 : Prepares HPC compuations of chunked gradient with HPCChunkedGradient().
14930 : You have to call this function before calling HPCChunkedGradient() for
14931 : a new set of weights. You have to call it only once, see example below:
14932 :
14933 : HOW TO PROCESS DATASET WITH THIS FUNCTION:
14934 : Grad:=0
14935 : HPCPrepareChunkedGradient(Weights, WCount, NTotal, NOut, Buf)
14936 : foreach chunk-of-dataset do
14937 : HPCChunkedGradient(...)
14938 : HPCFinalizeChunkedGradient(Buf, Grad)
14939 :
14940 : *************************************************************************/
14941 0 : void hpcpreparechunkedgradient(/* Real */ ae_vector* weights,
14942 : ae_int_t wcount,
14943 : ae_int_t ntotal,
14944 : ae_int_t nin,
14945 : ae_int_t nout,
14946 : mlpbuffers* buf,
14947 : ae_state *_state)
14948 : {
14949 : ae_int_t i;
14950 : ae_int_t batch4size;
14951 : ae_int_t chunksize;
14952 :
14953 :
14954 0 : chunksize = 4;
14955 0 : batch4size = 3*chunksize*ntotal+chunksize*(2*nout+1);
14956 0 : if( buf->xy.rows<chunksize||buf->xy.cols<nin+nout )
14957 : {
14958 0 : ae_matrix_set_length(&buf->xy, chunksize, nin+nout, _state);
14959 : }
14960 0 : if( buf->xy2.rows<chunksize||buf->xy2.cols<nin+nout )
14961 : {
14962 0 : ae_matrix_set_length(&buf->xy2, chunksize, nin+nout, _state);
14963 : }
14964 0 : if( buf->xyrow.cnt<nin+nout )
14965 : {
14966 0 : ae_vector_set_length(&buf->xyrow, nin+nout, _state);
14967 : }
14968 0 : if( buf->x.cnt<nin )
14969 : {
14970 0 : ae_vector_set_length(&buf->x, nin, _state);
14971 : }
14972 0 : if( buf->y.cnt<nout )
14973 : {
14974 0 : ae_vector_set_length(&buf->y, nout, _state);
14975 : }
14976 0 : if( buf->desiredy.cnt<nout )
14977 : {
14978 0 : ae_vector_set_length(&buf->desiredy, nout, _state);
14979 : }
14980 0 : if( buf->batch4buf.cnt<batch4size )
14981 : {
14982 0 : ae_vector_set_length(&buf->batch4buf, batch4size, _state);
14983 : }
14984 0 : if( buf->hpcbuf.cnt<wcount )
14985 : {
14986 0 : ae_vector_set_length(&buf->hpcbuf, wcount, _state);
14987 : }
14988 0 : if( buf->g.cnt<wcount )
14989 : {
14990 0 : ae_vector_set_length(&buf->g, wcount, _state);
14991 : }
14992 0 : if( !hpccores_hpcpreparechunkedgradientx(weights, wcount, &buf->hpcbuf, _state) )
14993 : {
14994 0 : for(i=0; i<=wcount-1; i++)
14995 : {
14996 0 : buf->hpcbuf.ptr.p_double[i] = 0.0;
14997 : }
14998 : }
14999 0 : buf->wcount = wcount;
15000 0 : buf->ntotal = ntotal;
15001 0 : buf->nin = nin;
15002 0 : buf->nout = nout;
15003 0 : buf->chunksize = chunksize;
15004 0 : }
15005 :
15006 :
15007 : /*************************************************************************
15008 : Finalizes HPC compuations of chunked gradient with HPCChunkedGradient().
15009 : You have to call this function after calling HPCChunkedGradient() for
15010 : a new set of weights. You have to call it only once, see example below:
15011 :
15012 : HOW TO PROCESS DATASET WITH THIS FUNCTION:
15013 : Grad:=0
15014 : HPCPrepareChunkedGradient(Weights, WCount, NTotal, NOut, Buf)
15015 : foreach chunk-of-dataset do
15016 : HPCChunkedGradient(...)
15017 : HPCFinalizeChunkedGradient(Buf, Grad)
15018 :
15019 : *************************************************************************/
15020 0 : void hpcfinalizechunkedgradient(mlpbuffers* buf,
15021 : /* Real */ ae_vector* grad,
15022 : ae_state *_state)
15023 : {
15024 : ae_int_t i;
15025 :
15026 :
15027 0 : if( !hpccores_hpcfinalizechunkedgradientx(&buf->hpcbuf, buf->wcount, grad, _state) )
15028 : {
15029 0 : for(i=0; i<=buf->wcount-1; i++)
15030 : {
15031 0 : grad->ptr.p_double[i] = grad->ptr.p_double[i]+buf->hpcbuf.ptr.p_double[i];
15032 : }
15033 : }
15034 0 : }
15035 :
15036 :
15037 : /*************************************************************************
15038 : Fast kernel for chunked gradient.
15039 :
15040 : *************************************************************************/
15041 0 : ae_bool hpcchunkedgradient(/* Real */ ae_vector* weights,
15042 : /* Integer */ ae_vector* structinfo,
15043 : /* Real */ ae_vector* columnmeans,
15044 : /* Real */ ae_vector* columnsigmas,
15045 : /* Real */ ae_matrix* xy,
15046 : ae_int_t cstart,
15047 : ae_int_t csize,
15048 : /* Real */ ae_vector* batch4buf,
15049 : /* Real */ ae_vector* hpcbuf,
15050 : double* e,
15051 : ae_bool naturalerrorfunc,
15052 : ae_state *_state)
15053 : {
15054 : #ifndef ALGLIB_INTERCEPTS_SSE2
15055 : ae_bool result;
15056 :
15057 :
15058 0 : result = ae_false;
15059 0 : return result;
15060 : #else
15061 : return _ialglib_i_hpcchunkedgradient(weights, structinfo, columnmeans, columnsigmas, xy, cstart, csize, batch4buf, hpcbuf, e, naturalerrorfunc);
15062 : #endif
15063 : }
15064 :
15065 :
15066 : /*************************************************************************
15067 : Fast kernel for chunked processing.
15068 :
15069 : *************************************************************************/
15070 0 : ae_bool hpcchunkedprocess(/* Real */ ae_vector* weights,
15071 : /* Integer */ ae_vector* structinfo,
15072 : /* Real */ ae_vector* columnmeans,
15073 : /* Real */ ae_vector* columnsigmas,
15074 : /* Real */ ae_matrix* xy,
15075 : ae_int_t cstart,
15076 : ae_int_t csize,
15077 : /* Real */ ae_vector* batch4buf,
15078 : /* Real */ ae_vector* hpcbuf,
15079 : ae_state *_state)
15080 : {
15081 : #ifndef ALGLIB_INTERCEPTS_SSE2
15082 : ae_bool result;
15083 :
15084 :
15085 0 : result = ae_false;
15086 0 : return result;
15087 : #else
15088 : return _ialglib_i_hpcchunkedprocess(weights, structinfo, columnmeans, columnsigmas, xy, cstart, csize, batch4buf, hpcbuf);
15089 : #endif
15090 : }
15091 :
15092 :
15093 : /*************************************************************************
15094 : Stub function.
15095 :
15096 : -- ALGLIB routine --
15097 : 14.06.2013
15098 : Bochkanov Sergey
15099 : *************************************************************************/
15100 0 : static ae_bool hpccores_hpcpreparechunkedgradientx(/* Real */ ae_vector* weights,
15101 : ae_int_t wcount,
15102 : /* Real */ ae_vector* hpcbuf,
15103 : ae_state *_state)
15104 : {
15105 : #ifndef ALGLIB_INTERCEPTS_SSE2
15106 : ae_bool result;
15107 :
15108 :
15109 0 : result = ae_false;
15110 0 : return result;
15111 : #else
15112 : return _ialglib_i_hpcpreparechunkedgradientx(weights, wcount, hpcbuf);
15113 : #endif
15114 : }
15115 :
15116 :
15117 : /*************************************************************************
15118 : Stub function.
15119 :
15120 : -- ALGLIB routine --
15121 : 14.06.2013
15122 : Bochkanov Sergey
15123 : *************************************************************************/
15124 0 : static ae_bool hpccores_hpcfinalizechunkedgradientx(/* Real */ ae_vector* buf,
15125 : ae_int_t wcount,
15126 : /* Real */ ae_vector* grad,
15127 : ae_state *_state)
15128 : {
15129 : #ifndef ALGLIB_INTERCEPTS_SSE2
15130 : ae_bool result;
15131 :
15132 :
15133 0 : result = ae_false;
15134 0 : return result;
15135 : #else
15136 : return _ialglib_i_hpcfinalizechunkedgradientx(buf, wcount, grad);
15137 : #endif
15138 : }
15139 :
15140 :
15141 0 : void _mlpbuffers_init(void* _p, ae_state *_state, ae_bool make_automatic)
15142 : {
15143 0 : mlpbuffers *p = (mlpbuffers*)_p;
15144 0 : ae_touch_ptr((void*)p);
15145 0 : ae_vector_init(&p->batch4buf, 0, DT_REAL, _state, make_automatic);
15146 0 : ae_vector_init(&p->hpcbuf, 0, DT_REAL, _state, make_automatic);
15147 0 : ae_matrix_init(&p->xy, 0, 0, DT_REAL, _state, make_automatic);
15148 0 : ae_matrix_init(&p->xy2, 0, 0, DT_REAL, _state, make_automatic);
15149 0 : ae_vector_init(&p->xyrow, 0, DT_REAL, _state, make_automatic);
15150 0 : ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic);
15151 0 : ae_vector_init(&p->y, 0, DT_REAL, _state, make_automatic);
15152 0 : ae_vector_init(&p->desiredy, 0, DT_REAL, _state, make_automatic);
15153 0 : ae_vector_init(&p->g, 0, DT_REAL, _state, make_automatic);
15154 0 : ae_vector_init(&p->tmp0, 0, DT_REAL, _state, make_automatic);
15155 0 : }
15156 :
15157 :
15158 0 : void _mlpbuffers_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
15159 : {
15160 0 : mlpbuffers *dst = (mlpbuffers*)_dst;
15161 0 : mlpbuffers *src = (mlpbuffers*)_src;
15162 0 : dst->chunksize = src->chunksize;
15163 0 : dst->ntotal = src->ntotal;
15164 0 : dst->nin = src->nin;
15165 0 : dst->nout = src->nout;
15166 0 : dst->wcount = src->wcount;
15167 0 : ae_vector_init_copy(&dst->batch4buf, &src->batch4buf, _state, make_automatic);
15168 0 : ae_vector_init_copy(&dst->hpcbuf, &src->hpcbuf, _state, make_automatic);
15169 0 : ae_matrix_init_copy(&dst->xy, &src->xy, _state, make_automatic);
15170 0 : ae_matrix_init_copy(&dst->xy2, &src->xy2, _state, make_automatic);
15171 0 : ae_vector_init_copy(&dst->xyrow, &src->xyrow, _state, make_automatic);
15172 0 : ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic);
15173 0 : ae_vector_init_copy(&dst->y, &src->y, _state, make_automatic);
15174 0 : ae_vector_init_copy(&dst->desiredy, &src->desiredy, _state, make_automatic);
15175 0 : dst->e = src->e;
15176 0 : ae_vector_init_copy(&dst->g, &src->g, _state, make_automatic);
15177 0 : ae_vector_init_copy(&dst->tmp0, &src->tmp0, _state, make_automatic);
15178 0 : }
15179 :
15180 :
15181 0 : void _mlpbuffers_clear(void* _p)
15182 : {
15183 0 : mlpbuffers *p = (mlpbuffers*)_p;
15184 0 : ae_touch_ptr((void*)p);
15185 0 : ae_vector_clear(&p->batch4buf);
15186 0 : ae_vector_clear(&p->hpcbuf);
15187 0 : ae_matrix_clear(&p->xy);
15188 0 : ae_matrix_clear(&p->xy2);
15189 0 : ae_vector_clear(&p->xyrow);
15190 0 : ae_vector_clear(&p->x);
15191 0 : ae_vector_clear(&p->y);
15192 0 : ae_vector_clear(&p->desiredy);
15193 0 : ae_vector_clear(&p->g);
15194 0 : ae_vector_clear(&p->tmp0);
15195 0 : }
15196 :
15197 :
15198 0 : void _mlpbuffers_destroy(void* _p)
15199 : {
15200 0 : mlpbuffers *p = (mlpbuffers*)_p;
15201 0 : ae_touch_ptr((void*)p);
15202 0 : ae_vector_destroy(&p->batch4buf);
15203 0 : ae_vector_destroy(&p->hpcbuf);
15204 0 : ae_matrix_destroy(&p->xy);
15205 0 : ae_matrix_destroy(&p->xy2);
15206 0 : ae_vector_destroy(&p->xyrow);
15207 0 : ae_vector_destroy(&p->x);
15208 0 : ae_vector_destroy(&p->y);
15209 0 : ae_vector_destroy(&p->desiredy);
15210 0 : ae_vector_destroy(&p->g);
15211 0 : ae_vector_destroy(&p->tmp0);
15212 0 : }
15213 :
15214 :
15215 : #endif
15216 : #if defined(AE_COMPILE_NTHEORY) || !defined(AE_PARTIAL_BUILD)
15217 :
15218 :
15219 0 : void findprimitiverootandinverse(ae_int_t n,
15220 : ae_int_t* proot,
15221 : ae_int_t* invproot,
15222 : ae_state *_state)
15223 : {
15224 : ae_int_t candroot;
15225 : ae_int_t phin;
15226 : ae_int_t q;
15227 : ae_int_t f;
15228 : ae_bool allnonone;
15229 : ae_int_t x;
15230 : ae_int_t lastx;
15231 : ae_int_t y;
15232 : ae_int_t lasty;
15233 : ae_int_t a;
15234 : ae_int_t b;
15235 : ae_int_t t;
15236 : ae_int_t n2;
15237 :
15238 0 : *proot = 0;
15239 0 : *invproot = 0;
15240 :
15241 0 : ae_assert(n>=3, "FindPrimitiveRootAndInverse: N<3", _state);
15242 0 : *proot = 0;
15243 0 : *invproot = 0;
15244 :
15245 : /*
15246 : * check that N is prime
15247 : */
15248 0 : ae_assert(ntheory_isprime(n, _state), "FindPrimitiveRoot: N is not prime", _state);
15249 :
15250 : /*
15251 : * Because N is prime, Euler totient function is equal to N-1
15252 : */
15253 0 : phin = n-1;
15254 :
15255 : /*
15256 : * Test different values of PRoot - from 2 to N-1.
15257 : * One of these values MUST be primitive root.
15258 : *
15259 : * For testing we use algorithm from Wiki (Primitive root modulo n):
15260 : * * compute phi(N)
15261 : * * determine the different prime factors of phi(N), say p1, ..., pk
15262 : * * for every element m of Zn*, compute m^(phi(N)/pi) mod N for i=1..k
15263 : * using a fast algorithm for modular exponentiation.
15264 : * * a number m for which these k results are all different from 1 is a
15265 : * primitive root.
15266 : */
15267 0 : for(candroot=2; candroot<=n-1; candroot++)
15268 : {
15269 :
15270 : /*
15271 : * We have current candidate root in CandRoot.
15272 : *
15273 : * Scan different prime factors of PhiN. Here:
15274 : * * F is a current candidate factor
15275 : * * Q is a current quotient - amount which was left after dividing PhiN
15276 : * by all previous factors
15277 : *
15278 : * For each factor, perform test mentioned above.
15279 : */
15280 0 : q = phin;
15281 0 : f = 2;
15282 0 : allnonone = ae_true;
15283 0 : while(q>1)
15284 : {
15285 0 : if( q%f==0 )
15286 : {
15287 0 : t = ntheory_modexp(candroot, phin/f, n, _state);
15288 0 : if( t==1 )
15289 : {
15290 0 : allnonone = ae_false;
15291 0 : break;
15292 : }
15293 0 : while(q%f==0)
15294 : {
15295 0 : q = q/f;
15296 : }
15297 : }
15298 0 : f = f+1;
15299 : }
15300 0 : if( allnonone )
15301 : {
15302 0 : *proot = candroot;
15303 0 : break;
15304 : }
15305 : }
15306 0 : ae_assert(*proot>=2, "FindPrimitiveRoot: internal error (root not found)", _state);
15307 :
15308 : /*
15309 : * Use extended Euclidean algorithm to find multiplicative inverse of primitive root
15310 : */
15311 0 : x = 0;
15312 0 : lastx = 1;
15313 0 : y = 1;
15314 0 : lasty = 0;
15315 0 : a = *proot;
15316 0 : b = n;
15317 0 : while(b!=0)
15318 : {
15319 0 : q = a/b;
15320 0 : t = a%b;
15321 0 : a = b;
15322 0 : b = t;
15323 0 : t = lastx-q*x;
15324 0 : lastx = x;
15325 0 : x = t;
15326 0 : t = lasty-q*y;
15327 0 : lasty = y;
15328 0 : y = t;
15329 : }
15330 0 : while(lastx<0)
15331 : {
15332 0 : lastx = lastx+n;
15333 : }
15334 0 : *invproot = lastx;
15335 :
15336 : /*
15337 : * Check that it is safe to perform multiplication modulo N.
15338 : * Check results for consistency.
15339 : */
15340 0 : n2 = (n-1)*(n-1);
15341 0 : ae_assert(n2/(n-1)==n-1, "FindPrimitiveRoot: internal error", _state);
15342 0 : ae_assert(*proot*(*invproot)/(*proot)==(*invproot), "FindPrimitiveRoot: internal error", _state);
15343 0 : ae_assert(*proot*(*invproot)/(*invproot)==(*proot), "FindPrimitiveRoot: internal error", _state);
15344 0 : ae_assert(*proot*(*invproot)%n==1, "FindPrimitiveRoot: internal error", _state);
15345 0 : }
15346 :
15347 :
15348 0 : static ae_bool ntheory_isprime(ae_int_t n, ae_state *_state)
15349 : {
15350 : ae_int_t p;
15351 : ae_bool result;
15352 :
15353 :
15354 0 : result = ae_false;
15355 0 : p = 2;
15356 0 : while(p*p<=n)
15357 : {
15358 0 : if( n%p==0 )
15359 : {
15360 0 : return result;
15361 : }
15362 0 : p = p+1;
15363 : }
15364 0 : result = ae_true;
15365 0 : return result;
15366 : }
15367 :
15368 :
15369 0 : static ae_int_t ntheory_modmul(ae_int_t a,
15370 : ae_int_t b,
15371 : ae_int_t n,
15372 : ae_state *_state)
15373 : {
15374 : ae_int_t t;
15375 : double ra;
15376 : double rb;
15377 : ae_int_t result;
15378 :
15379 :
15380 0 : ae_assert(a>=0&&a<n, "ModMul: A<0 or A>=N", _state);
15381 0 : ae_assert(b>=0&&b<n, "ModMul: B<0 or B>=N", _state);
15382 :
15383 : /*
15384 : * Base cases
15385 : */
15386 0 : ra = (double)(a);
15387 0 : rb = (double)(b);
15388 0 : if( b==0||a==0 )
15389 : {
15390 0 : result = 0;
15391 0 : return result;
15392 : }
15393 0 : if( b==1||a==1 )
15394 : {
15395 0 : result = a*b;
15396 0 : return result;
15397 : }
15398 0 : if( ae_fp_eq(ra*rb,(double)(a*b)) )
15399 : {
15400 0 : result = a*b%n;
15401 0 : return result;
15402 : }
15403 :
15404 : /*
15405 : * Non-base cases
15406 : */
15407 0 : if( b%2==0 )
15408 : {
15409 :
15410 : /*
15411 : * A*B = (A*(B/2)) * 2
15412 : *
15413 : * Product T=A*(B/2) is calculated recursively, product T*2 is
15414 : * calculated as follows:
15415 : * * result:=T-N
15416 : * * result:=result+T
15417 : * * if result<0 then result:=result+N
15418 : *
15419 : * In case integer result overflows, we generate exception
15420 : */
15421 0 : t = ntheory_modmul(a, b/2, n, _state);
15422 0 : result = t-n;
15423 0 : result = result+t;
15424 0 : if( result<0 )
15425 : {
15426 0 : result = result+n;
15427 : }
15428 : }
15429 : else
15430 : {
15431 :
15432 : /*
15433 : * A*B = (A*(B div 2)) * 2 + A
15434 : *
15435 : * Product T=A*(B/2) is calculated recursively, product T*2 is
15436 : * calculated as follows:
15437 : * * result:=T-N
15438 : * * result:=result+T
15439 : * * if result<0 then result:=result+N
15440 : *
15441 : * In case integer result overflows, we generate exception
15442 : */
15443 0 : t = ntheory_modmul(a, b/2, n, _state);
15444 0 : result = t-n;
15445 0 : result = result+t;
15446 0 : if( result<0 )
15447 : {
15448 0 : result = result+n;
15449 : }
15450 0 : result = result-n;
15451 0 : result = result+a;
15452 0 : if( result<0 )
15453 : {
15454 0 : result = result+n;
15455 : }
15456 : }
15457 0 : return result;
15458 : }
15459 :
15460 :
15461 0 : static ae_int_t ntheory_modexp(ae_int_t a,
15462 : ae_int_t b,
15463 : ae_int_t n,
15464 : ae_state *_state)
15465 : {
15466 : ae_int_t t;
15467 : ae_int_t result;
15468 :
15469 :
15470 0 : ae_assert(a>=0&&a<n, "ModExp: A<0 or A>=N", _state);
15471 0 : ae_assert(b>=0, "ModExp: B<0", _state);
15472 :
15473 : /*
15474 : * Base cases
15475 : */
15476 0 : if( b==0 )
15477 : {
15478 0 : result = 1;
15479 0 : return result;
15480 : }
15481 0 : if( b==1 )
15482 : {
15483 0 : result = a;
15484 0 : return result;
15485 : }
15486 :
15487 : /*
15488 : * Non-base cases
15489 : */
15490 0 : if( b%2==0 )
15491 : {
15492 0 : t = ntheory_modmul(a, a, n, _state);
15493 0 : result = ntheory_modexp(t, b/2, n, _state);
15494 : }
15495 : else
15496 : {
15497 0 : t = ntheory_modmul(a, a, n, _state);
15498 0 : result = ntheory_modexp(t, b/2, n, _state);
15499 0 : result = ntheory_modmul(result, a, n, _state);
15500 : }
15501 0 : return result;
15502 : }
15503 :
15504 :
15505 : #endif
15506 : #if defined(AE_COMPILE_FTBASE) || !defined(AE_PARTIAL_BUILD)
15507 :
15508 :
15509 : /*************************************************************************
15510 : This subroutine generates FFT plan for K complex FFT's with length N each.
15511 :
15512 : INPUT PARAMETERS:
15513 : N - FFT length (in complex numbers), N>=1
15514 : K - number of repetitions, K>=1
15515 :
15516 : OUTPUT PARAMETERS:
15517 : Plan - plan
15518 :
15519 : -- ALGLIB --
15520 : Copyright 05.04.2013 by Bochkanov Sergey
15521 : *************************************************************************/
15522 0 : void ftcomplexfftplan(ae_int_t n,
15523 : ae_int_t k,
15524 : fasttransformplan* plan,
15525 : ae_state *_state)
15526 : {
15527 : ae_frame _frame_block;
15528 : srealarray bluesteinbuf;
15529 : ae_int_t rowptr;
15530 : ae_int_t bluesteinsize;
15531 : ae_int_t precrptr;
15532 : ae_int_t preciptr;
15533 : ae_int_t precrsize;
15534 : ae_int_t precisize;
15535 :
15536 0 : ae_frame_make(_state, &_frame_block);
15537 0 : memset(&bluesteinbuf, 0, sizeof(bluesteinbuf));
15538 0 : _fasttransformplan_clear(plan);
15539 0 : _srealarray_init(&bluesteinbuf, _state, ae_true);
15540 :
15541 :
15542 : /*
15543 : * Initial check for parameters
15544 : */
15545 0 : ae_assert(n>0, "FTComplexFFTPlan: N<=0", _state);
15546 0 : ae_assert(k>0, "FTComplexFFTPlan: K<=0", _state);
15547 :
15548 : /*
15549 : * Determine required sizes of precomputed real and integer
15550 : * buffers. This stage of code is highly dependent on internals
15551 : * of FTComplexFFTPlanRec() and must be kept synchronized with
15552 : * possible changes in internals of plan generation function.
15553 : *
15554 : * Buffer size is determined as follows:
15555 : * * N is factorized
15556 : * * we factor out anything which is less or equal to MaxRadix
15557 : * * prime factor F>RaderThreshold requires 4*FTBaseFindSmooth(2*F-1)
15558 : * real entries to store precomputed Quantities for Bluestein's
15559 : * transformation
15560 : * * prime factor F<=RaderThreshold does NOT require
15561 : * precomputed storage
15562 : */
15563 0 : precrsize = 0;
15564 0 : precisize = 0;
15565 0 : ftbase_ftdeterminespacerequirements(n, &precrsize, &precisize, _state);
15566 0 : if( precrsize>0 )
15567 : {
15568 0 : ae_vector_set_length(&plan->precr, precrsize, _state);
15569 : }
15570 0 : if( precisize>0 )
15571 : {
15572 0 : ae_vector_set_length(&plan->preci, precisize, _state);
15573 : }
15574 :
15575 : /*
15576 : * Generate plan
15577 : */
15578 0 : rowptr = 0;
15579 0 : precrptr = 0;
15580 0 : preciptr = 0;
15581 0 : bluesteinsize = 1;
15582 0 : ae_vector_set_length(&plan->buffer, 2*n*k, _state);
15583 0 : ftbase_ftcomplexfftplanrec(n, k, ae_true, ae_true, &rowptr, &bluesteinsize, &precrptr, &preciptr, plan, _state);
15584 0 : ae_vector_set_length(&bluesteinbuf.val, bluesteinsize, _state);
15585 0 : ae_shared_pool_set_seed(&plan->bluesteinpool, &bluesteinbuf, sizeof(bluesteinbuf), _srealarray_init, _srealarray_init_copy, _srealarray_destroy, _state);
15586 :
15587 : /*
15588 : * Check that actual amount of precomputed space used by transformation
15589 : * plan is EXACTLY equal to amount of space allocated by us.
15590 : */
15591 0 : ae_assert(precrptr==precrsize, "FTComplexFFTPlan: internal error (PrecRPtr<>PrecRSize)", _state);
15592 0 : ae_assert(preciptr==precisize, "FTComplexFFTPlan: internal error (PrecRPtr<>PrecRSize)", _state);
15593 0 : ae_frame_leave(_state);
15594 0 : }
15595 :
15596 :
15597 : /*************************************************************************
15598 : This subroutine applies transformation plan to input/output array A.
15599 :
15600 : INPUT PARAMETERS:
15601 : Plan - transformation plan
15602 : A - array, must be large enough for plan to work
15603 : OffsA - offset of the subarray to process
15604 : RepCnt - repetition count (transformation is repeatedly applied
15605 : to subsequent subarrays)
15606 :
15607 : OUTPUT PARAMETERS:
15608 : Plan - plan (temporary buffers can be modified, plan itself
15609 : is unchanged and can be reused)
15610 : A - transformed array
15611 :
15612 : -- ALGLIB --
15613 : Copyright 05.04.2013 by Bochkanov Sergey
15614 : *************************************************************************/
15615 0 : void ftapplyplan(fasttransformplan* plan,
15616 : /* Real */ ae_vector* a,
15617 : ae_int_t offsa,
15618 : ae_int_t repcnt,
15619 : ae_state *_state)
15620 : {
15621 : ae_int_t plansize;
15622 : ae_int_t i;
15623 :
15624 :
15625 0 : plansize = plan->entries.ptr.pp_int[0][ftbase_coloperandscnt]*plan->entries.ptr.pp_int[0][ftbase_coloperandsize]*plan->entries.ptr.pp_int[0][ftbase_colmicrovectorsize];
15626 0 : for(i=0; i<=repcnt-1; i++)
15627 : {
15628 0 : ftbase_ftapplysubplan(plan, 0, a, offsa+plansize*i, 0, &plan->buffer, 1, _state);
15629 : }
15630 0 : }
15631 :
15632 :
15633 : /*************************************************************************
15634 : Returns good factorization N=N1*N2.
15635 :
15636 : Usually N1<=N2 (but not always - small N's may be exception).
15637 : if N1<>1 then N2<>1.
15638 :
15639 : Factorization is chosen depending on task type and codelets we have.
15640 :
15641 : -- ALGLIB --
15642 : Copyright 01.05.2009 by Bochkanov Sergey
15643 : *************************************************************************/
15644 0 : void ftbasefactorize(ae_int_t n,
15645 : ae_int_t tasktype,
15646 : ae_int_t* n1,
15647 : ae_int_t* n2,
15648 : ae_state *_state)
15649 : {
15650 : ae_int_t j;
15651 :
15652 0 : *n1 = 0;
15653 0 : *n2 = 0;
15654 :
15655 0 : *n1 = 0;
15656 0 : *n2 = 0;
15657 :
15658 : /*
15659 : * try to find good codelet
15660 : */
15661 0 : if( *n1*(*n2)!=n )
15662 : {
15663 0 : for(j=ftbase_ftbasecodeletrecommended; j>=2; j--)
15664 : {
15665 0 : if( n%j==0 )
15666 : {
15667 0 : *n1 = j;
15668 0 : *n2 = n/j;
15669 0 : break;
15670 : }
15671 : }
15672 : }
15673 :
15674 : /*
15675 : * try to factorize N
15676 : */
15677 0 : if( *n1*(*n2)!=n )
15678 : {
15679 0 : for(j=ftbase_ftbasecodeletrecommended+1; j<=n-1; j++)
15680 : {
15681 0 : if( n%j==0 )
15682 : {
15683 0 : *n1 = j;
15684 0 : *n2 = n/j;
15685 0 : break;
15686 : }
15687 : }
15688 : }
15689 :
15690 : /*
15691 : * looks like N is prime :(
15692 : */
15693 0 : if( *n1*(*n2)!=n )
15694 : {
15695 0 : *n1 = 1;
15696 0 : *n2 = n;
15697 : }
15698 :
15699 : /*
15700 : * normalize
15701 : */
15702 0 : if( *n2==1&&*n1!=1 )
15703 : {
15704 0 : *n2 = *n1;
15705 0 : *n1 = 1;
15706 : }
15707 0 : }
15708 :
15709 :
15710 : /*************************************************************************
15711 : Is number smooth?
15712 :
15713 : -- ALGLIB --
15714 : Copyright 01.05.2009 by Bochkanov Sergey
15715 : *************************************************************************/
15716 0 : ae_bool ftbaseissmooth(ae_int_t n, ae_state *_state)
15717 : {
15718 : ae_int_t i;
15719 : ae_bool result;
15720 :
15721 :
15722 0 : for(i=2; i<=ftbase_ftbasemaxsmoothfactor; i++)
15723 : {
15724 0 : while(n%i==0)
15725 : {
15726 0 : n = n/i;
15727 : }
15728 : }
15729 0 : result = n==1;
15730 0 : return result;
15731 : }
15732 :
15733 :
15734 : /*************************************************************************
15735 : Returns smallest smooth (divisible only by 2, 3, 5) number that is greater
15736 : than or equal to max(N,2)
15737 :
15738 : -- ALGLIB --
15739 : Copyright 01.05.2009 by Bochkanov Sergey
15740 : *************************************************************************/
15741 0 : ae_int_t ftbasefindsmooth(ae_int_t n, ae_state *_state)
15742 : {
15743 : ae_int_t best;
15744 : ae_int_t result;
15745 :
15746 :
15747 0 : best = 2;
15748 0 : while(best<n)
15749 : {
15750 0 : best = 2*best;
15751 : }
15752 0 : ftbase_ftbasefindsmoothrec(n, 1, 2, &best, _state);
15753 0 : result = best;
15754 0 : return result;
15755 : }
15756 :
15757 :
15758 : /*************************************************************************
15759 : Returns smallest smooth (divisible only by 2, 3, 5) even number that is
15760 : greater than or equal to max(N,2)
15761 :
15762 : -- ALGLIB --
15763 : Copyright 01.05.2009 by Bochkanov Sergey
15764 : *************************************************************************/
15765 0 : ae_int_t ftbasefindsmootheven(ae_int_t n, ae_state *_state)
15766 : {
15767 : ae_int_t best;
15768 : ae_int_t result;
15769 :
15770 :
15771 0 : best = 2;
15772 0 : while(best<n)
15773 : {
15774 0 : best = 2*best;
15775 : }
15776 0 : ftbase_ftbasefindsmoothrec(n, 2, 2, &best, _state);
15777 0 : result = best;
15778 0 : return result;
15779 : }
15780 :
15781 :
15782 : /*************************************************************************
15783 : Returns estimate of FLOP count for the FFT.
15784 :
15785 : It is only an estimate based on operations count for the PERFECT FFT
15786 : and relative inefficiency of the algorithm actually used.
15787 :
15788 : N should be power of 2, estimates are badly wrong for non-power-of-2 N's.
15789 :
15790 : -- ALGLIB --
15791 : Copyright 01.05.2009 by Bochkanov Sergey
15792 : *************************************************************************/
15793 0 : double ftbasegetflopestimate(ae_int_t n, ae_state *_state)
15794 : {
15795 : double result;
15796 :
15797 :
15798 0 : result = ftbase_ftbaseinefficiencyfactor*(4*n*ae_log((double)(n), _state)/ae_log((double)(2), _state)-6*n+8);
15799 0 : return result;
15800 : }
15801 :
15802 :
15803 : /*************************************************************************
15804 : This function returns EXACT estimate of the space requirements for N-point
15805 : FFT. Internals of this function are highly dependent on details of different
15806 : FFTs employed by this unit, so every time algorithm is changed this function
15807 : has to be rewritten.
15808 :
15809 : INPUT PARAMETERS:
15810 : N - transform length
15811 : PrecRSize - must be set to zero
15812 : PrecISize - must be set to zero
15813 :
15814 : OUTPUT PARAMETERS:
15815 : PrecRSize - number of real temporaries required for transformation
15816 : PrecISize - number of integer temporaries required for transformation
15817 :
15818 :
15819 : -- ALGLIB --
15820 : Copyright 05.04.2013 by Bochkanov Sergey
15821 : *************************************************************************/
15822 0 : static void ftbase_ftdeterminespacerequirements(ae_int_t n,
15823 : ae_int_t* precrsize,
15824 : ae_int_t* precisize,
15825 : ae_state *_state)
15826 : {
15827 : ae_int_t ncur;
15828 : ae_int_t f;
15829 : ae_int_t i;
15830 :
15831 :
15832 :
15833 : /*
15834 : * Determine required sizes of precomputed real and integer
15835 : * buffers. This stage of code is highly dependent on internals
15836 : * of FTComplexFFTPlanRec() and must be kept synchronized with
15837 : * possible changes in internals of plan generation function.
15838 : *
15839 : * Buffer size is determined as follows:
15840 : * * N is factorized
15841 : * * we factor out anything which is less or equal to MaxRadix
15842 : * * prime factor F>RaderThreshold requires 4*FTBaseFindSmooth(2*F-1)
15843 : * real entries to store precomputed Quantities for Bluestein's
15844 : * transformation
15845 : * * prime factor F<=RaderThreshold requires 2*(F-1)+ESTIMATE(F-1)
15846 : * precomputed storage
15847 : */
15848 0 : ncur = n;
15849 0 : for(i=2; i<=ftbase_maxradix; i++)
15850 : {
15851 0 : while(ncur%i==0)
15852 : {
15853 0 : ncur = ncur/i;
15854 : }
15855 : }
15856 0 : f = 2;
15857 0 : while(f<=ncur)
15858 : {
15859 0 : while(ncur%f==0)
15860 : {
15861 0 : if( f>ftbase_raderthreshold )
15862 : {
15863 0 : *precrsize = *precrsize+4*ftbasefindsmooth(2*f-1, _state);
15864 : }
15865 : else
15866 : {
15867 0 : *precrsize = *precrsize+2*(f-1);
15868 0 : ftbase_ftdeterminespacerequirements(f-1, precrsize, precisize, _state);
15869 : }
15870 0 : ncur = ncur/f;
15871 : }
15872 0 : f = f+1;
15873 : }
15874 0 : }
15875 :
15876 :
15877 : /*************************************************************************
15878 : Recurrent function called by FTComplexFFTPlan() and other functions. It
15879 : recursively builds transformation plan
15880 :
15881 : INPUT PARAMETERS:
15882 : N - FFT length (in complex numbers), N>=1
15883 : K - number of repetitions, K>=1
15884 : ChildPlan - if True, plan generator inserts OpStart/opEnd in the
15885 : plan header/footer.
15886 : TopmostPlan - if True, plan generator assumes that it is topmost plan:
15887 : * it may use global buffer for transpositions
15888 : and there is no other plan which executes in parallel
15889 : RowPtr - index which points to past-the-last entry generated so far
15890 : BluesteinSize- amount of storage (in real numbers) required for Bluestein buffer
15891 : PrecRPtr - pointer to unused part of precomputed real buffer (Plan.PrecR):
15892 : * when this function stores some data to precomputed buffer,
15893 : it advances pointer.
15894 : * it is responsibility of the function to assert that
15895 : Plan.PrecR has enough space to store data before actually
15896 : writing to buffer.
15897 : * it is responsibility of the caller to allocate enough
15898 : space before calling this function
15899 : PrecIPtr - pointer to unused part of precomputed integer buffer (Plan.PrecI):
15900 : * when this function stores some data to precomputed buffer,
15901 : it advances pointer.
15902 : * it is responsibility of the function to assert that
15903 : Plan.PrecR has enough space to store data before actually
15904 : writing to buffer.
15905 : * it is responsibility of the caller to allocate enough
15906 : space before calling this function
15907 : Plan - plan (generated so far)
15908 :
15909 : OUTPUT PARAMETERS:
15910 : RowPtr - updated pointer (advanced by number of entries generated
15911 : by function)
15912 : BluesteinSize- updated amount
15913 : (may be increased, but may never be decreased)
15914 :
15915 : NOTE: in case TopmostPlan is True, ChildPlan is also must be True.
15916 :
15917 : -- ALGLIB --
15918 : Copyright 05.04.2013 by Bochkanov Sergey
15919 : *************************************************************************/
15920 0 : static void ftbase_ftcomplexfftplanrec(ae_int_t n,
15921 : ae_int_t k,
15922 : ae_bool childplan,
15923 : ae_bool topmostplan,
15924 : ae_int_t* rowptr,
15925 : ae_int_t* bluesteinsize,
15926 : ae_int_t* precrptr,
15927 : ae_int_t* preciptr,
15928 : fasttransformplan* plan,
15929 : ae_state *_state)
15930 : {
15931 : ae_frame _frame_block;
15932 : srealarray localbuf;
15933 : ae_int_t m;
15934 : ae_int_t n1;
15935 : ae_int_t n2;
15936 : ae_int_t gq;
15937 : ae_int_t giq;
15938 : ae_int_t row0;
15939 : ae_int_t row1;
15940 : ae_int_t row2;
15941 : ae_int_t row3;
15942 :
15943 0 : ae_frame_make(_state, &_frame_block);
15944 0 : memset(&localbuf, 0, sizeof(localbuf));
15945 0 : _srealarray_init(&localbuf, _state, ae_true);
15946 :
15947 0 : ae_assert(n>0, "FTComplexFFTPlan: N<=0", _state);
15948 0 : ae_assert(k>0, "FTComplexFFTPlan: K<=0", _state);
15949 0 : ae_assert(!topmostplan||childplan, "FTComplexFFTPlan: ChildPlan is inconsistent with TopmostPlan", _state);
15950 :
15951 : /*
15952 : * Try to generate "topmost" plan
15953 : */
15954 0 : if( topmostplan&&n>ftbase_recursivethreshold )
15955 : {
15956 0 : ftbase_ftfactorize(n, ae_false, &n1, &n2, _state);
15957 0 : if( n1*n2==0 )
15958 : {
15959 :
15960 : /*
15961 : * Handle prime-factor FFT with Bluestein's FFT.
15962 : * Determine size of Bluestein's buffer.
15963 : */
15964 0 : m = ftbasefindsmooth(2*n-1, _state);
15965 0 : *bluesteinsize = ae_maxint(2*m, *bluesteinsize, _state);
15966 :
15967 : /*
15968 : * Generate plan
15969 : */
15970 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
15971 0 : ftbase_ftpushentry4(plan, rowptr, ftbase_opbluesteinsfft, k, n, 2, m, 2, *precrptr, 0, _state);
15972 0 : row0 = *rowptr;
15973 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opjmp, 0, 0, 0, 0, _state);
15974 0 : ftbase_ftcomplexfftplanrec(m, 1, ae_true, ae_true, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
15975 0 : row1 = *rowptr;
15976 0 : plan->entries.ptr.pp_int[row0][ftbase_colparam0] = row1-row0;
15977 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
15978 :
15979 : /*
15980 : * Fill precomputed buffer
15981 : */
15982 0 : ftbase_ftprecomputebluesteinsfft(n, m, &plan->precr, *precrptr, _state);
15983 :
15984 : /*
15985 : * Update pointer to the precomputed area
15986 : */
15987 0 : *precrptr = *precrptr+4*m;
15988 : }
15989 : else
15990 : {
15991 :
15992 : /*
15993 : * Handle composite FFT with recursive Cooley-Tukey which
15994 : * uses global buffer instead of local one.
15995 : */
15996 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
15997 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
15998 0 : row0 = *rowptr;
15999 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opparallelcall, k*n2, n1, 2, 0, ftbase_ftoptimisticestimate(n, _state), _state);
16000 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplexfftfactors, k, n, 2, n1, _state);
16001 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n2, _state);
16002 0 : row2 = *rowptr;
16003 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opparallelcall, k*n1, n2, 2, 0, ftbase_ftoptimisticestimate(n, _state), _state);
16004 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16005 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16006 0 : row1 = *rowptr;
16007 0 : ftbase_ftcomplexfftplanrec(n1, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16008 0 : plan->entries.ptr.pp_int[row0][ftbase_colparam0] = row1-row0;
16009 0 : row3 = *rowptr;
16010 0 : ftbase_ftcomplexfftplanrec(n2, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16011 0 : plan->entries.ptr.pp_int[row2][ftbase_colparam0] = row3-row2;
16012 : }
16013 0 : ae_frame_leave(_state);
16014 0 : return;
16015 : }
16016 :
16017 : /*
16018 : * Prepare "non-topmost" plan:
16019 : * * calculate factorization
16020 : * * use local (shared) buffer
16021 : * * update buffer size - ANY plan will need at least
16022 : * 2*N temporaries, additional requirements can be
16023 : * applied later
16024 : */
16025 0 : ftbase_ftfactorize(n, ae_false, &n1, &n2, _state);
16026 :
16027 : /*
16028 : * Handle FFT's with N1*N2=0: either small-N or prime-factor
16029 : */
16030 0 : if( n1*n2==0 )
16031 : {
16032 0 : if( n<=ftbase_maxradix )
16033 : {
16034 :
16035 : /*
16036 : * Small-N FFT
16037 : */
16038 0 : if( childplan )
16039 : {
16040 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16041 : }
16042 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplexcodeletfft, k, n, 2, 0, _state);
16043 0 : if( childplan )
16044 : {
16045 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16046 : }
16047 0 : ae_frame_leave(_state);
16048 0 : return;
16049 : }
16050 0 : if( n<=ftbase_raderthreshold )
16051 : {
16052 :
16053 : /*
16054 : * Handle prime-factor FFT's with Rader's FFT
16055 : */
16056 0 : m = n-1;
16057 0 : if( childplan )
16058 : {
16059 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16060 : }
16061 0 : findprimitiverootandinverse(n, &gq, &giq, _state);
16062 0 : ftbase_ftpushentry4(plan, rowptr, ftbase_opradersfft, k, n, 2, 2, gq, giq, *precrptr, _state);
16063 0 : ftbase_ftprecomputeradersfft(n, gq, giq, &plan->precr, *precrptr, _state);
16064 0 : *precrptr = *precrptr+2*(n-1);
16065 0 : row0 = *rowptr;
16066 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opjmp, 0, 0, 0, 0, _state);
16067 0 : ftbase_ftcomplexfftplanrec(m, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16068 0 : row1 = *rowptr;
16069 0 : plan->entries.ptr.pp_int[row0][ftbase_colparam0] = row1-row0;
16070 0 : if( childplan )
16071 : {
16072 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16073 : }
16074 : }
16075 : else
16076 : {
16077 :
16078 : /*
16079 : * Handle prime-factor FFT's with Bluestein's FFT
16080 : */
16081 0 : m = ftbasefindsmooth(2*n-1, _state);
16082 0 : *bluesteinsize = ae_maxint(2*m, *bluesteinsize, _state);
16083 0 : if( childplan )
16084 : {
16085 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16086 : }
16087 0 : ftbase_ftpushentry4(plan, rowptr, ftbase_opbluesteinsfft, k, n, 2, m, 2, *precrptr, 0, _state);
16088 0 : ftbase_ftprecomputebluesteinsfft(n, m, &plan->precr, *precrptr, _state);
16089 0 : *precrptr = *precrptr+4*m;
16090 0 : row0 = *rowptr;
16091 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opjmp, 0, 0, 0, 0, _state);
16092 0 : ftbase_ftcomplexfftplanrec(m, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16093 0 : row1 = *rowptr;
16094 0 : plan->entries.ptr.pp_int[row0][ftbase_colparam0] = row1-row0;
16095 0 : if( childplan )
16096 : {
16097 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16098 : }
16099 : }
16100 0 : ae_frame_leave(_state);
16101 0 : return;
16102 : }
16103 :
16104 : /*
16105 : * Handle Cooley-Tukey FFT with small N1
16106 : */
16107 0 : if( n1<=ftbase_maxradix )
16108 : {
16109 :
16110 : /*
16111 : * Specialized transformation for small N1:
16112 : * * N2 short inplace FFT's, each N1-point, with integrated twiddle factors
16113 : * * N1 long FFT's
16114 : * * final transposition
16115 : */
16116 0 : if( childplan )
16117 : {
16118 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16119 : }
16120 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplexcodelettwfft, k, n1, 2*n2, 0, _state);
16121 0 : ftbase_ftcomplexfftplanrec(n2, k*n1, ae_false, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16122 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16123 0 : if( childplan )
16124 : {
16125 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16126 : }
16127 0 : ae_frame_leave(_state);
16128 0 : return;
16129 : }
16130 :
16131 : /*
16132 : * Handle general Cooley-Tukey FFT, either "flat" or "recursive"
16133 : */
16134 0 : if( n<=ftbase_recursivethreshold )
16135 : {
16136 :
16137 : /*
16138 : * General code for large N1/N2, "flat" version without explicit recurrence
16139 : * (nested subplans are inserted directly into the body of the plan)
16140 : */
16141 0 : if( childplan )
16142 : {
16143 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16144 : }
16145 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16146 0 : ftbase_ftcomplexfftplanrec(n1, k*n2, ae_false, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16147 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplexfftfactors, k, n, 2, n1, _state);
16148 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n2, _state);
16149 0 : ftbase_ftcomplexfftplanrec(n2, k*n1, ae_false, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16150 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16151 0 : if( childplan )
16152 : {
16153 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16154 : }
16155 : }
16156 : else
16157 : {
16158 :
16159 : /*
16160 : * General code for large N1/N2, "recursive" version - nested subplans
16161 : * are separated from the plan body.
16162 : *
16163 : * Generate parent plan.
16164 : */
16165 0 : if( childplan )
16166 : {
16167 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opstart, k, n, 2, -1, ftbase_ftoptimisticestimate(n, _state), _state);
16168 : }
16169 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16170 0 : row0 = *rowptr;
16171 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opparallelcall, k*n2, n1, 2, 0, ftbase_ftoptimisticestimate(n, _state), _state);
16172 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplexfftfactors, k, n, 2, n1, _state);
16173 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n2, _state);
16174 0 : row2 = *rowptr;
16175 0 : ftbase_ftpushentry2(plan, rowptr, ftbase_opparallelcall, k*n1, n2, 2, 0, ftbase_ftoptimisticestimate(n, _state), _state);
16176 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opcomplextranspose, k, n, 2, n1, _state);
16177 0 : if( childplan )
16178 : {
16179 0 : ftbase_ftpushentry(plan, rowptr, ftbase_opend, k, n, 2, 0, _state);
16180 : }
16181 :
16182 : /*
16183 : * Generate child subplans, insert refence to parent plans
16184 : */
16185 0 : row1 = *rowptr;
16186 0 : ftbase_ftcomplexfftplanrec(n1, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16187 0 : plan->entries.ptr.pp_int[row0][ftbase_colparam0] = row1-row0;
16188 0 : row3 = *rowptr;
16189 0 : ftbase_ftcomplexfftplanrec(n2, 1, ae_true, ae_false, rowptr, bluesteinsize, precrptr, preciptr, plan, _state);
16190 0 : plan->entries.ptr.pp_int[row2][ftbase_colparam0] = row3-row2;
16191 : }
16192 0 : ae_frame_leave(_state);
16193 : }
16194 :
16195 :
16196 : /*************************************************************************
16197 : This function pushes one more entry to the plan. It resizes Entries matrix
16198 : if needed.
16199 :
16200 : INPUT PARAMETERS:
16201 : Plan - plan (generated so far)
16202 : RowPtr - index which points to past-the-last entry generated so far
16203 : EType - entry type
16204 : EOpCnt - operands count
16205 : EOpSize - operand size
16206 : EMcvSize - microvector size
16207 : EParam0 - parameter 0
16208 :
16209 : OUTPUT PARAMETERS:
16210 : Plan - updated plan
16211 : RowPtr - updated pointer
16212 :
16213 : NOTE: Param1 is set to -1.
16214 :
16215 : -- ALGLIB --
16216 : Copyright 05.04.2013 by Bochkanov Sergey
16217 : *************************************************************************/
16218 0 : static void ftbase_ftpushentry(fasttransformplan* plan,
16219 : ae_int_t* rowptr,
16220 : ae_int_t etype,
16221 : ae_int_t eopcnt,
16222 : ae_int_t eopsize,
16223 : ae_int_t emcvsize,
16224 : ae_int_t eparam0,
16225 : ae_state *_state)
16226 : {
16227 :
16228 :
16229 0 : ftbase_ftpushentry2(plan, rowptr, etype, eopcnt, eopsize, emcvsize, eparam0, -1, _state);
16230 0 : }
16231 :
16232 :
16233 : /*************************************************************************
16234 : Same as FTPushEntry(), but sets Param0 AND Param1.
16235 : This function pushes one more entry to the plan. It resized Entries matrix
16236 : if needed.
16237 :
16238 : INPUT PARAMETERS:
16239 : Plan - plan (generated so far)
16240 : RowPtr - index which points to past-the-last entry generated so far
16241 : EType - entry type
16242 : EOpCnt - operands count
16243 : EOpSize - operand size
16244 : EMcvSize - microvector size
16245 : EParam0 - parameter 0
16246 : EParam1 - parameter 1
16247 :
16248 : OUTPUT PARAMETERS:
16249 : Plan - updated plan
16250 : RowPtr - updated pointer
16251 :
16252 : -- ALGLIB --
16253 : Copyright 05.04.2013 by Bochkanov Sergey
16254 : *************************************************************************/
16255 0 : static void ftbase_ftpushentry2(fasttransformplan* plan,
16256 : ae_int_t* rowptr,
16257 : ae_int_t etype,
16258 : ae_int_t eopcnt,
16259 : ae_int_t eopsize,
16260 : ae_int_t emcvsize,
16261 : ae_int_t eparam0,
16262 : ae_int_t eparam1,
16263 : ae_state *_state)
16264 : {
16265 :
16266 :
16267 0 : if( *rowptr>=plan->entries.rows )
16268 : {
16269 0 : imatrixresize(&plan->entries, ae_maxint(2*plan->entries.rows, 1, _state), ftbase_colscnt, _state);
16270 : }
16271 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coltype] = etype;
16272 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coloperandscnt] = eopcnt;
16273 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coloperandsize] = eopsize;
16274 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colmicrovectorsize] = emcvsize;
16275 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam0] = eparam0;
16276 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam1] = eparam1;
16277 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam2] = 0;
16278 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam3] = 0;
16279 0 : *rowptr = *rowptr+1;
16280 0 : }
16281 :
16282 :
16283 : /*************************************************************************
16284 : Same as FTPushEntry(), but sets Param0, Param1, Param2 and Param3.
16285 : This function pushes one more entry to the plan. It resized Entries matrix
16286 : if needed.
16287 :
16288 : INPUT PARAMETERS:
16289 : Plan - plan (generated so far)
16290 : RowPtr - index which points to past-the-last entry generated so far
16291 : EType - entry type
16292 : EOpCnt - operands count
16293 : EOpSize - operand size
16294 : EMcvSize - microvector size
16295 : EParam0 - parameter 0
16296 : EParam1 - parameter 1
16297 : EParam2 - parameter 2
16298 : EParam3 - parameter 3
16299 :
16300 : OUTPUT PARAMETERS:
16301 : Plan - updated plan
16302 : RowPtr - updated pointer
16303 :
16304 : -- ALGLIB --
16305 : Copyright 05.04.2013 by Bochkanov Sergey
16306 : *************************************************************************/
16307 0 : static void ftbase_ftpushentry4(fasttransformplan* plan,
16308 : ae_int_t* rowptr,
16309 : ae_int_t etype,
16310 : ae_int_t eopcnt,
16311 : ae_int_t eopsize,
16312 : ae_int_t emcvsize,
16313 : ae_int_t eparam0,
16314 : ae_int_t eparam1,
16315 : ae_int_t eparam2,
16316 : ae_int_t eparam3,
16317 : ae_state *_state)
16318 : {
16319 :
16320 :
16321 0 : if( *rowptr>=plan->entries.rows )
16322 : {
16323 0 : imatrixresize(&plan->entries, ae_maxint(2*plan->entries.rows, 1, _state), ftbase_colscnt, _state);
16324 : }
16325 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coltype] = etype;
16326 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coloperandscnt] = eopcnt;
16327 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_coloperandsize] = eopsize;
16328 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colmicrovectorsize] = emcvsize;
16329 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam0] = eparam0;
16330 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam1] = eparam1;
16331 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam2] = eparam2;
16332 0 : plan->entries.ptr.pp_int[*rowptr][ftbase_colparam3] = eparam3;
16333 0 : *rowptr = *rowptr+1;
16334 0 : }
16335 :
16336 :
16337 : /*************************************************************************
16338 : This subroutine applies subplan to input/output array A.
16339 :
16340 : INPUT PARAMETERS:
16341 : Plan - transformation plan
16342 : SubPlan - subplan index
16343 : A - array, must be large enough for plan to work
16344 : ABase - base offset in array A, this value points to start of
16345 : subarray whose length is equal to length of the plan
16346 : AOffset - offset with respect to ABase, 0<=AOffset<PlanLength.
16347 : This is an offset within large PlanLength-subarray of
16348 : the chunk to process.
16349 : Buf - temporary buffer whose length is equal to plan length
16350 : (without taking into account RepCnt) or larger.
16351 : OffsBuf - offset in the buffer array
16352 : RepCnt - repetition count (transformation is repeatedly applied
16353 : to subsequent subarrays)
16354 :
16355 : OUTPUT PARAMETERS:
16356 : Plan - plan (temporary buffers can be modified, plan itself
16357 : is unchanged and can be reused)
16358 : A - transformed array
16359 :
16360 : -- ALGLIB --
16361 : Copyright 05.04.2013 by Bochkanov Sergey
16362 : *************************************************************************/
16363 0 : static void ftbase_ftapplysubplan(fasttransformplan* plan,
16364 : ae_int_t subplan,
16365 : /* Real */ ae_vector* a,
16366 : ae_int_t abase,
16367 : ae_int_t aoffset,
16368 : /* Real */ ae_vector* buf,
16369 : ae_int_t repcnt,
16370 : ae_state *_state)
16371 : {
16372 : ae_frame _frame_block;
16373 : ae_int_t rowidx;
16374 : ae_int_t i;
16375 : ae_int_t n1;
16376 : ae_int_t n2;
16377 : ae_int_t operation;
16378 : ae_int_t operandscnt;
16379 : ae_int_t operandsize;
16380 : ae_int_t microvectorsize;
16381 : ae_int_t param0;
16382 : ae_int_t param1;
16383 : ae_int_t parentsize;
16384 : ae_int_t childsize;
16385 : ae_int_t chunksize;
16386 : ae_int_t lastchunksize;
16387 : srealarray *bufa;
16388 : ae_smart_ptr _bufa;
16389 : srealarray *bufb;
16390 : ae_smart_ptr _bufb;
16391 : srealarray *bufc;
16392 : ae_smart_ptr _bufc;
16393 : srealarray *bufd;
16394 : ae_smart_ptr _bufd;
16395 :
16396 0 : ae_frame_make(_state, &_frame_block);
16397 0 : memset(&_bufa, 0, sizeof(_bufa));
16398 0 : memset(&_bufb, 0, sizeof(_bufb));
16399 0 : memset(&_bufc, 0, sizeof(_bufc));
16400 0 : memset(&_bufd, 0, sizeof(_bufd));
16401 0 : ae_smart_ptr_init(&_bufa, (void**)&bufa, _state, ae_true);
16402 0 : ae_smart_ptr_init(&_bufb, (void**)&bufb, _state, ae_true);
16403 0 : ae_smart_ptr_init(&_bufc, (void**)&bufc, _state, ae_true);
16404 0 : ae_smart_ptr_init(&_bufd, (void**)&bufd, _state, ae_true);
16405 :
16406 0 : ae_assert(plan->entries.ptr.pp_int[subplan][ftbase_coltype]==ftbase_opstart, "FTApplySubPlan: incorrect subplan header", _state);
16407 0 : rowidx = subplan+1;
16408 0 : while(plan->entries.ptr.pp_int[rowidx][ftbase_coltype]!=ftbase_opend)
16409 : {
16410 0 : operation = plan->entries.ptr.pp_int[rowidx][ftbase_coltype];
16411 0 : operandscnt = repcnt*plan->entries.ptr.pp_int[rowidx][ftbase_coloperandscnt];
16412 0 : operandsize = plan->entries.ptr.pp_int[rowidx][ftbase_coloperandsize];
16413 0 : microvectorsize = plan->entries.ptr.pp_int[rowidx][ftbase_colmicrovectorsize];
16414 0 : param0 = plan->entries.ptr.pp_int[rowidx][ftbase_colparam0];
16415 0 : param1 = plan->entries.ptr.pp_int[rowidx][ftbase_colparam1];
16416 0 : touchint(¶m1, _state);
16417 :
16418 : /*
16419 : * Process "jump" operation
16420 : */
16421 0 : if( operation==ftbase_opjmp )
16422 : {
16423 0 : rowidx = rowidx+plan->entries.ptr.pp_int[rowidx][ftbase_colparam0];
16424 0 : continue;
16425 : }
16426 :
16427 : /*
16428 : * Process "parallel call" operation:
16429 : * * we perform initial check for consistency between parent and child plans
16430 : * * we call FTSplitAndApplyParallelPlan(), which splits parallel plan into
16431 : * several parallel tasks
16432 : */
16433 0 : if( operation==ftbase_opparallelcall )
16434 : {
16435 0 : parentsize = operandsize*microvectorsize;
16436 0 : childsize = plan->entries.ptr.pp_int[rowidx+param0][ftbase_coloperandscnt]*plan->entries.ptr.pp_int[rowidx+param0][ftbase_coloperandsize]*plan->entries.ptr.pp_int[rowidx+param0][ftbase_colmicrovectorsize];
16437 0 : ae_assert(plan->entries.ptr.pp_int[rowidx+param0][ftbase_coltype]==ftbase_opstart, "FTApplySubPlan: incorrect child subplan header", _state);
16438 0 : ae_assert(parentsize==childsize, "FTApplySubPlan: incorrect child subplan header", _state);
16439 0 : chunksize = ae_maxint(ftbase_recursivethreshold/childsize, 1, _state);
16440 0 : lastchunksize = operandscnt%chunksize;
16441 0 : if( lastchunksize==0 )
16442 : {
16443 0 : lastchunksize = chunksize;
16444 : }
16445 0 : i = 0;
16446 0 : while(i<operandscnt)
16447 : {
16448 0 : chunksize = ae_minint(chunksize, operandscnt-i, _state);
16449 0 : ftbase_ftapplysubplan(plan, rowidx+param0, a, abase, aoffset+i*childsize, buf, chunksize, _state);
16450 0 : i = i+chunksize;
16451 : }
16452 0 : rowidx = rowidx+1;
16453 0 : continue;
16454 : }
16455 :
16456 : /*
16457 : * Process "reference complex FFT" operation
16458 : */
16459 0 : if( operation==ftbase_opcomplexreffft )
16460 : {
16461 0 : ftbase_ftapplycomplexreffft(a, abase+aoffset, operandscnt, operandsize, microvectorsize, buf, _state);
16462 0 : rowidx = rowidx+1;
16463 0 : continue;
16464 : }
16465 :
16466 : /*
16467 : * Process "codelet FFT" operation
16468 : */
16469 0 : if( operation==ftbase_opcomplexcodeletfft )
16470 : {
16471 0 : ftbase_ftapplycomplexcodeletfft(a, abase+aoffset, operandscnt, operandsize, microvectorsize, _state);
16472 0 : rowidx = rowidx+1;
16473 0 : continue;
16474 : }
16475 :
16476 : /*
16477 : * Process "integrated codelet FFT" operation
16478 : */
16479 0 : if( operation==ftbase_opcomplexcodelettwfft )
16480 : {
16481 0 : ftbase_ftapplycomplexcodelettwfft(a, abase+aoffset, operandscnt, operandsize, microvectorsize, _state);
16482 0 : rowidx = rowidx+1;
16483 0 : continue;
16484 : }
16485 :
16486 : /*
16487 : * Process Bluestein's FFT operation
16488 : */
16489 0 : if( operation==ftbase_opbluesteinsfft )
16490 : {
16491 0 : ae_assert(microvectorsize==2, "FTApplySubPlan: microvectorsize!=2 for Bluesteins FFT", _state);
16492 0 : ae_shared_pool_retrieve(&plan->bluesteinpool, &_bufa, _state);
16493 0 : ae_shared_pool_retrieve(&plan->bluesteinpool, &_bufb, _state);
16494 0 : ae_shared_pool_retrieve(&plan->bluesteinpool, &_bufc, _state);
16495 0 : ae_shared_pool_retrieve(&plan->bluesteinpool, &_bufd, _state);
16496 0 : ftbase_ftbluesteinsfft(plan, a, abase, aoffset, operandscnt, operandsize, plan->entries.ptr.pp_int[rowidx][ftbase_colparam0], plan->entries.ptr.pp_int[rowidx][ftbase_colparam2], rowidx+plan->entries.ptr.pp_int[rowidx][ftbase_colparam1], &bufa->val, &bufb->val, &bufc->val, &bufd->val, _state);
16497 0 : ae_shared_pool_recycle(&plan->bluesteinpool, &_bufa, _state);
16498 0 : ae_shared_pool_recycle(&plan->bluesteinpool, &_bufb, _state);
16499 0 : ae_shared_pool_recycle(&plan->bluesteinpool, &_bufc, _state);
16500 0 : ae_shared_pool_recycle(&plan->bluesteinpool, &_bufd, _state);
16501 0 : rowidx = rowidx+1;
16502 0 : continue;
16503 : }
16504 :
16505 : /*
16506 : * Process Rader's FFT
16507 : */
16508 0 : if( operation==ftbase_opradersfft )
16509 : {
16510 0 : ftbase_ftradersfft(plan, a, abase, aoffset, operandscnt, operandsize, rowidx+plan->entries.ptr.pp_int[rowidx][ftbase_colparam0], plan->entries.ptr.pp_int[rowidx][ftbase_colparam1], plan->entries.ptr.pp_int[rowidx][ftbase_colparam2], plan->entries.ptr.pp_int[rowidx][ftbase_colparam3], buf, _state);
16511 0 : rowidx = rowidx+1;
16512 0 : continue;
16513 : }
16514 :
16515 : /*
16516 : * Process "complex twiddle factors" operation
16517 : */
16518 0 : if( operation==ftbase_opcomplexfftfactors )
16519 : {
16520 0 : ae_assert(microvectorsize==2, "FTApplySubPlan: MicrovectorSize<>1", _state);
16521 0 : n1 = plan->entries.ptr.pp_int[rowidx][ftbase_colparam0];
16522 0 : n2 = operandsize/n1;
16523 0 : for(i=0; i<=operandscnt-1; i++)
16524 : {
16525 0 : ftbase_ffttwcalc(a, abase+aoffset+i*operandsize*2, n1, n2, _state);
16526 : }
16527 0 : rowidx = rowidx+1;
16528 0 : continue;
16529 : }
16530 :
16531 : /*
16532 : * Process "complex transposition" operation
16533 : */
16534 0 : if( operation==ftbase_opcomplextranspose )
16535 : {
16536 0 : ae_assert(microvectorsize==2, "FTApplySubPlan: MicrovectorSize<>1", _state);
16537 0 : n1 = plan->entries.ptr.pp_int[rowidx][ftbase_colparam0];
16538 0 : n2 = operandsize/n1;
16539 0 : for(i=0; i<=operandscnt-1; i++)
16540 : {
16541 0 : ftbase_internalcomplexlintranspose(a, n1, n2, abase+aoffset+i*operandsize*2, buf, _state);
16542 : }
16543 0 : rowidx = rowidx+1;
16544 0 : continue;
16545 : }
16546 :
16547 : /*
16548 : * Error
16549 : */
16550 0 : ae_assert(ae_false, "FTApplySubPlan: unexpected plan type", _state);
16551 : }
16552 0 : ae_frame_leave(_state);
16553 0 : }
16554 :
16555 :
16556 : /*************************************************************************
16557 : This subroutine applies complex reference FFT to input/output array A.
16558 :
16559 : VERY SLOW OPERATION, do not use it in real life plans :)
16560 :
16561 : INPUT PARAMETERS:
16562 : A - array, must be large enough for plan to work
16563 : Offs - offset of the subarray to process
16564 : OperandsCnt - operands count (see description of FastTransformPlan)
16565 : OperandSize - operand size (see description of FastTransformPlan)
16566 : MicrovectorSize-microvector size (see description of FastTransformPlan)
16567 : Buf - temporary array, must be at least OperandsCnt*OperandSize*MicrovectorSize
16568 :
16569 : OUTPUT PARAMETERS:
16570 : A - transformed array
16571 :
16572 : -- ALGLIB --
16573 : Copyright 05.04.2013 by Bochkanov Sergey
16574 : *************************************************************************/
16575 0 : static void ftbase_ftapplycomplexreffft(/* Real */ ae_vector* a,
16576 : ae_int_t offs,
16577 : ae_int_t operandscnt,
16578 : ae_int_t operandsize,
16579 : ae_int_t microvectorsize,
16580 : /* Real */ ae_vector* buf,
16581 : ae_state *_state)
16582 : {
16583 : ae_int_t opidx;
16584 : ae_int_t i;
16585 : ae_int_t k;
16586 : double hre;
16587 : double him;
16588 : double c;
16589 : double s;
16590 : double re;
16591 : double im;
16592 : ae_int_t n;
16593 :
16594 :
16595 0 : ae_assert(operandscnt>=1, "FTApplyComplexRefFFT: OperandsCnt<1", _state);
16596 0 : ae_assert(operandsize>=1, "FTApplyComplexRefFFT: OperandSize<1", _state);
16597 0 : ae_assert(microvectorsize==2, "FTApplyComplexRefFFT: MicrovectorSize<>2", _state);
16598 0 : n = operandsize;
16599 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16600 : {
16601 0 : for(i=0; i<=n-1; i++)
16602 : {
16603 0 : hre = (double)(0);
16604 0 : him = (double)(0);
16605 0 : for(k=0; k<=n-1; k++)
16606 : {
16607 0 : re = a->ptr.p_double[offs+opidx*operandsize*2+2*k+0];
16608 0 : im = a->ptr.p_double[offs+opidx*operandsize*2+2*k+1];
16609 0 : c = ae_cos(-2*ae_pi*k*i/n, _state);
16610 0 : s = ae_sin(-2*ae_pi*k*i/n, _state);
16611 0 : hre = hre+c*re-s*im;
16612 0 : him = him+c*im+s*re;
16613 : }
16614 0 : buf->ptr.p_double[2*i+0] = hre;
16615 0 : buf->ptr.p_double[2*i+1] = him;
16616 : }
16617 0 : for(i=0; i<=operandsize*2-1; i++)
16618 : {
16619 0 : a->ptr.p_double[offs+opidx*operandsize*2+i] = buf->ptr.p_double[i];
16620 : }
16621 : }
16622 0 : }
16623 :
16624 :
16625 : /*************************************************************************
16626 : This subroutine applies complex codelet FFT to input/output array A.
16627 :
16628 : INPUT PARAMETERS:
16629 : A - array, must be large enough for plan to work
16630 : Offs - offset of the subarray to process
16631 : OperandsCnt - operands count (see description of FastTransformPlan)
16632 : OperandSize - operand size (see description of FastTransformPlan)
16633 : MicrovectorSize-microvector size, must be 2
16634 :
16635 : OUTPUT PARAMETERS:
16636 : A - transformed array
16637 :
16638 : -- ALGLIB --
16639 : Copyright 05.04.2013 by Bochkanov Sergey
16640 : *************************************************************************/
16641 0 : static void ftbase_ftapplycomplexcodeletfft(/* Real */ ae_vector* a,
16642 : ae_int_t offs,
16643 : ae_int_t operandscnt,
16644 : ae_int_t operandsize,
16645 : ae_int_t microvectorsize,
16646 : ae_state *_state)
16647 : {
16648 : ae_int_t opidx;
16649 : ae_int_t n;
16650 : ae_int_t aoffset;
16651 : double a0x;
16652 : double a0y;
16653 : double a1x;
16654 : double a1y;
16655 : double a2x;
16656 : double a2y;
16657 : double a3x;
16658 : double a3y;
16659 : double a4x;
16660 : double a4y;
16661 : double a5x;
16662 : double a5y;
16663 : double v0;
16664 : double v1;
16665 : double v2;
16666 : double v3;
16667 : double t1x;
16668 : double t1y;
16669 : double t2x;
16670 : double t2y;
16671 : double t3x;
16672 : double t3y;
16673 : double t4x;
16674 : double t4y;
16675 : double t5x;
16676 : double t5y;
16677 : double m1x;
16678 : double m1y;
16679 : double m2x;
16680 : double m2y;
16681 : double m3x;
16682 : double m3y;
16683 : double m4x;
16684 : double m4y;
16685 : double m5x;
16686 : double m5y;
16687 : double s1x;
16688 : double s1y;
16689 : double s2x;
16690 : double s2y;
16691 : double s3x;
16692 : double s3y;
16693 : double s4x;
16694 : double s4y;
16695 : double s5x;
16696 : double s5y;
16697 : double c1;
16698 : double c2;
16699 : double c3;
16700 : double c4;
16701 : double c5;
16702 : double v;
16703 :
16704 :
16705 0 : ae_assert(operandscnt>=1, "FTApplyComplexCodeletFFT: OperandsCnt<1", _state);
16706 0 : ae_assert(operandsize>=1, "FTApplyComplexCodeletFFT: OperandSize<1", _state);
16707 0 : ae_assert(microvectorsize==2, "FTApplyComplexCodeletFFT: MicrovectorSize<>2", _state);
16708 0 : n = operandsize;
16709 :
16710 : /*
16711 : * Hard-coded transforms for different N's
16712 : */
16713 0 : ae_assert(n<=ftbase_maxradix, "FTApplyComplexCodeletFFT: N>MaxRadix", _state);
16714 0 : if( n==2 )
16715 : {
16716 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16717 : {
16718 0 : aoffset = offs+opidx*operandsize*2;
16719 0 : a0x = a->ptr.p_double[aoffset+0];
16720 0 : a0y = a->ptr.p_double[aoffset+1];
16721 0 : a1x = a->ptr.p_double[aoffset+2];
16722 0 : a1y = a->ptr.p_double[aoffset+3];
16723 0 : v0 = a0x+a1x;
16724 0 : v1 = a0y+a1y;
16725 0 : v2 = a0x-a1x;
16726 0 : v3 = a0y-a1y;
16727 0 : a->ptr.p_double[aoffset+0] = v0;
16728 0 : a->ptr.p_double[aoffset+1] = v1;
16729 0 : a->ptr.p_double[aoffset+2] = v2;
16730 0 : a->ptr.p_double[aoffset+3] = v3;
16731 : }
16732 0 : return;
16733 : }
16734 0 : if( n==3 )
16735 : {
16736 0 : c1 = ae_cos(2*ae_pi/3, _state)-1;
16737 0 : c2 = ae_sin(2*ae_pi/3, _state);
16738 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16739 : {
16740 0 : aoffset = offs+opidx*operandsize*2;
16741 0 : a0x = a->ptr.p_double[aoffset+0];
16742 0 : a0y = a->ptr.p_double[aoffset+1];
16743 0 : a1x = a->ptr.p_double[aoffset+2];
16744 0 : a1y = a->ptr.p_double[aoffset+3];
16745 0 : a2x = a->ptr.p_double[aoffset+4];
16746 0 : a2y = a->ptr.p_double[aoffset+5];
16747 0 : t1x = a1x+a2x;
16748 0 : t1y = a1y+a2y;
16749 0 : a0x = a0x+t1x;
16750 0 : a0y = a0y+t1y;
16751 0 : m1x = c1*t1x;
16752 0 : m1y = c1*t1y;
16753 0 : m2x = c2*(a1y-a2y);
16754 0 : m2y = c2*(a2x-a1x);
16755 0 : s1x = a0x+m1x;
16756 0 : s1y = a0y+m1y;
16757 0 : a1x = s1x+m2x;
16758 0 : a1y = s1y+m2y;
16759 0 : a2x = s1x-m2x;
16760 0 : a2y = s1y-m2y;
16761 0 : a->ptr.p_double[aoffset+0] = a0x;
16762 0 : a->ptr.p_double[aoffset+1] = a0y;
16763 0 : a->ptr.p_double[aoffset+2] = a1x;
16764 0 : a->ptr.p_double[aoffset+3] = a1y;
16765 0 : a->ptr.p_double[aoffset+4] = a2x;
16766 0 : a->ptr.p_double[aoffset+5] = a2y;
16767 : }
16768 0 : return;
16769 : }
16770 0 : if( n==4 )
16771 : {
16772 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16773 : {
16774 0 : aoffset = offs+opidx*operandsize*2;
16775 0 : a0x = a->ptr.p_double[aoffset+0];
16776 0 : a0y = a->ptr.p_double[aoffset+1];
16777 0 : a1x = a->ptr.p_double[aoffset+2];
16778 0 : a1y = a->ptr.p_double[aoffset+3];
16779 0 : a2x = a->ptr.p_double[aoffset+4];
16780 0 : a2y = a->ptr.p_double[aoffset+5];
16781 0 : a3x = a->ptr.p_double[aoffset+6];
16782 0 : a3y = a->ptr.p_double[aoffset+7];
16783 0 : t1x = a0x+a2x;
16784 0 : t1y = a0y+a2y;
16785 0 : t2x = a1x+a3x;
16786 0 : t2y = a1y+a3y;
16787 0 : m2x = a0x-a2x;
16788 0 : m2y = a0y-a2y;
16789 0 : m3x = a1y-a3y;
16790 0 : m3y = a3x-a1x;
16791 0 : a->ptr.p_double[aoffset+0] = t1x+t2x;
16792 0 : a->ptr.p_double[aoffset+1] = t1y+t2y;
16793 0 : a->ptr.p_double[aoffset+4] = t1x-t2x;
16794 0 : a->ptr.p_double[aoffset+5] = t1y-t2y;
16795 0 : a->ptr.p_double[aoffset+2] = m2x+m3x;
16796 0 : a->ptr.p_double[aoffset+3] = m2y+m3y;
16797 0 : a->ptr.p_double[aoffset+6] = m2x-m3x;
16798 0 : a->ptr.p_double[aoffset+7] = m2y-m3y;
16799 : }
16800 0 : return;
16801 : }
16802 0 : if( n==5 )
16803 : {
16804 0 : v = 2*ae_pi/5;
16805 0 : c1 = (ae_cos(v, _state)+ae_cos(2*v, _state))/2-1;
16806 0 : c2 = (ae_cos(v, _state)-ae_cos(2*v, _state))/2;
16807 0 : c3 = -ae_sin(v, _state);
16808 0 : c4 = -(ae_sin(v, _state)+ae_sin(2*v, _state));
16809 0 : c5 = ae_sin(v, _state)-ae_sin(2*v, _state);
16810 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16811 : {
16812 0 : aoffset = offs+opidx*operandsize*2;
16813 0 : t1x = a->ptr.p_double[aoffset+2]+a->ptr.p_double[aoffset+8];
16814 0 : t1y = a->ptr.p_double[aoffset+3]+a->ptr.p_double[aoffset+9];
16815 0 : t2x = a->ptr.p_double[aoffset+4]+a->ptr.p_double[aoffset+6];
16816 0 : t2y = a->ptr.p_double[aoffset+5]+a->ptr.p_double[aoffset+7];
16817 0 : t3x = a->ptr.p_double[aoffset+2]-a->ptr.p_double[aoffset+8];
16818 0 : t3y = a->ptr.p_double[aoffset+3]-a->ptr.p_double[aoffset+9];
16819 0 : t4x = a->ptr.p_double[aoffset+6]-a->ptr.p_double[aoffset+4];
16820 0 : t4y = a->ptr.p_double[aoffset+7]-a->ptr.p_double[aoffset+5];
16821 0 : t5x = t1x+t2x;
16822 0 : t5y = t1y+t2y;
16823 0 : a->ptr.p_double[aoffset+0] = a->ptr.p_double[aoffset+0]+t5x;
16824 0 : a->ptr.p_double[aoffset+1] = a->ptr.p_double[aoffset+1]+t5y;
16825 0 : m1x = c1*t5x;
16826 0 : m1y = c1*t5y;
16827 0 : m2x = c2*(t1x-t2x);
16828 0 : m2y = c2*(t1y-t2y);
16829 0 : m3x = -c3*(t3y+t4y);
16830 0 : m3y = c3*(t3x+t4x);
16831 0 : m4x = -c4*t4y;
16832 0 : m4y = c4*t4x;
16833 0 : m5x = -c5*t3y;
16834 0 : m5y = c5*t3x;
16835 0 : s3x = m3x-m4x;
16836 0 : s3y = m3y-m4y;
16837 0 : s5x = m3x+m5x;
16838 0 : s5y = m3y+m5y;
16839 0 : s1x = a->ptr.p_double[aoffset+0]+m1x;
16840 0 : s1y = a->ptr.p_double[aoffset+1]+m1y;
16841 0 : s2x = s1x+m2x;
16842 0 : s2y = s1y+m2y;
16843 0 : s4x = s1x-m2x;
16844 0 : s4y = s1y-m2y;
16845 0 : a->ptr.p_double[aoffset+2] = s2x+s3x;
16846 0 : a->ptr.p_double[aoffset+3] = s2y+s3y;
16847 0 : a->ptr.p_double[aoffset+4] = s4x+s5x;
16848 0 : a->ptr.p_double[aoffset+5] = s4y+s5y;
16849 0 : a->ptr.p_double[aoffset+6] = s4x-s5x;
16850 0 : a->ptr.p_double[aoffset+7] = s4y-s5y;
16851 0 : a->ptr.p_double[aoffset+8] = s2x-s3x;
16852 0 : a->ptr.p_double[aoffset+9] = s2y-s3y;
16853 : }
16854 0 : return;
16855 : }
16856 0 : if( n==6 )
16857 : {
16858 0 : c1 = ae_cos(2*ae_pi/3, _state)-1;
16859 0 : c2 = ae_sin(2*ae_pi/3, _state);
16860 0 : c3 = ae_cos(-ae_pi/3, _state);
16861 0 : c4 = ae_sin(-ae_pi/3, _state);
16862 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
16863 : {
16864 0 : aoffset = offs+opidx*operandsize*2;
16865 0 : a0x = a->ptr.p_double[aoffset+0];
16866 0 : a0y = a->ptr.p_double[aoffset+1];
16867 0 : a1x = a->ptr.p_double[aoffset+2];
16868 0 : a1y = a->ptr.p_double[aoffset+3];
16869 0 : a2x = a->ptr.p_double[aoffset+4];
16870 0 : a2y = a->ptr.p_double[aoffset+5];
16871 0 : a3x = a->ptr.p_double[aoffset+6];
16872 0 : a3y = a->ptr.p_double[aoffset+7];
16873 0 : a4x = a->ptr.p_double[aoffset+8];
16874 0 : a4y = a->ptr.p_double[aoffset+9];
16875 0 : a5x = a->ptr.p_double[aoffset+10];
16876 0 : a5y = a->ptr.p_double[aoffset+11];
16877 0 : v0 = a0x;
16878 0 : v1 = a0y;
16879 0 : a0x = a0x+a3x;
16880 0 : a0y = a0y+a3y;
16881 0 : a3x = v0-a3x;
16882 0 : a3y = v1-a3y;
16883 0 : v0 = a1x;
16884 0 : v1 = a1y;
16885 0 : a1x = a1x+a4x;
16886 0 : a1y = a1y+a4y;
16887 0 : a4x = v0-a4x;
16888 0 : a4y = v1-a4y;
16889 0 : v0 = a2x;
16890 0 : v1 = a2y;
16891 0 : a2x = a2x+a5x;
16892 0 : a2y = a2y+a5y;
16893 0 : a5x = v0-a5x;
16894 0 : a5y = v1-a5y;
16895 0 : t4x = a4x*c3-a4y*c4;
16896 0 : t4y = a4x*c4+a4y*c3;
16897 0 : a4x = t4x;
16898 0 : a4y = t4y;
16899 0 : t5x = -a5x*c3-a5y*c4;
16900 0 : t5y = a5x*c4-a5y*c3;
16901 0 : a5x = t5x;
16902 0 : a5y = t5y;
16903 0 : t1x = a1x+a2x;
16904 0 : t1y = a1y+a2y;
16905 0 : a0x = a0x+t1x;
16906 0 : a0y = a0y+t1y;
16907 0 : m1x = c1*t1x;
16908 0 : m1y = c1*t1y;
16909 0 : m2x = c2*(a1y-a2y);
16910 0 : m2y = c2*(a2x-a1x);
16911 0 : s1x = a0x+m1x;
16912 0 : s1y = a0y+m1y;
16913 0 : a1x = s1x+m2x;
16914 0 : a1y = s1y+m2y;
16915 0 : a2x = s1x-m2x;
16916 0 : a2y = s1y-m2y;
16917 0 : t1x = a4x+a5x;
16918 0 : t1y = a4y+a5y;
16919 0 : a3x = a3x+t1x;
16920 0 : a3y = a3y+t1y;
16921 0 : m1x = c1*t1x;
16922 0 : m1y = c1*t1y;
16923 0 : m2x = c2*(a4y-a5y);
16924 0 : m2y = c2*(a5x-a4x);
16925 0 : s1x = a3x+m1x;
16926 0 : s1y = a3y+m1y;
16927 0 : a4x = s1x+m2x;
16928 0 : a4y = s1y+m2y;
16929 0 : a5x = s1x-m2x;
16930 0 : a5y = s1y-m2y;
16931 0 : a->ptr.p_double[aoffset+0] = a0x;
16932 0 : a->ptr.p_double[aoffset+1] = a0y;
16933 0 : a->ptr.p_double[aoffset+2] = a3x;
16934 0 : a->ptr.p_double[aoffset+3] = a3y;
16935 0 : a->ptr.p_double[aoffset+4] = a1x;
16936 0 : a->ptr.p_double[aoffset+5] = a1y;
16937 0 : a->ptr.p_double[aoffset+6] = a4x;
16938 0 : a->ptr.p_double[aoffset+7] = a4y;
16939 0 : a->ptr.p_double[aoffset+8] = a2x;
16940 0 : a->ptr.p_double[aoffset+9] = a2y;
16941 0 : a->ptr.p_double[aoffset+10] = a5x;
16942 0 : a->ptr.p_double[aoffset+11] = a5y;
16943 : }
16944 0 : return;
16945 : }
16946 : }
16947 :
16948 :
16949 : /*************************************************************************
16950 : This subroutine applies complex "integrated" codelet FFT to input/output
16951 : array A. "Integrated" codelet differs from "normal" one in following ways:
16952 : * it can work with MicrovectorSize>1
16953 : * hence, it can be used in Cooley-Tukey FFT without transpositions
16954 : * it performs inlined multiplication by twiddle factors of Cooley-Tukey
16955 : FFT with N2=MicrovectorSize/2.
16956 :
16957 : INPUT PARAMETERS:
16958 : A - array, must be large enough for plan to work
16959 : Offs - offset of the subarray to process
16960 : OperandsCnt - operands count (see description of FastTransformPlan)
16961 : OperandSize - operand size (see description of FastTransformPlan)
16962 : MicrovectorSize-microvector size, must be 1
16963 :
16964 : OUTPUT PARAMETERS:
16965 : A - transformed array
16966 :
16967 : -- ALGLIB --
16968 : Copyright 05.04.2013 by Bochkanov Sergey
16969 : *************************************************************************/
16970 0 : static void ftbase_ftapplycomplexcodelettwfft(/* Real */ ae_vector* a,
16971 : ae_int_t offs,
16972 : ae_int_t operandscnt,
16973 : ae_int_t operandsize,
16974 : ae_int_t microvectorsize,
16975 : ae_state *_state)
16976 : {
16977 : ae_int_t opidx;
16978 : ae_int_t mvidx;
16979 : ae_int_t n;
16980 : ae_int_t m;
16981 : ae_int_t aoffset0;
16982 : ae_int_t aoffset2;
16983 : ae_int_t aoffset4;
16984 : ae_int_t aoffset6;
16985 : ae_int_t aoffset8;
16986 : ae_int_t aoffset10;
16987 : double a0x;
16988 : double a0y;
16989 : double a1x;
16990 : double a1y;
16991 : double a2x;
16992 : double a2y;
16993 : double a3x;
16994 : double a3y;
16995 : double a4x;
16996 : double a4y;
16997 : double a5x;
16998 : double a5y;
16999 : double v0;
17000 : double v1;
17001 : double v2;
17002 : double v3;
17003 : double q0x;
17004 : double q0y;
17005 : double t1x;
17006 : double t1y;
17007 : double t2x;
17008 : double t2y;
17009 : double t3x;
17010 : double t3y;
17011 : double t4x;
17012 : double t4y;
17013 : double t5x;
17014 : double t5y;
17015 : double m1x;
17016 : double m1y;
17017 : double m2x;
17018 : double m2y;
17019 : double m3x;
17020 : double m3y;
17021 : double m4x;
17022 : double m4y;
17023 : double m5x;
17024 : double m5y;
17025 : double s1x;
17026 : double s1y;
17027 : double s2x;
17028 : double s2y;
17029 : double s3x;
17030 : double s3y;
17031 : double s4x;
17032 : double s4y;
17033 : double s5x;
17034 : double s5y;
17035 : double c1;
17036 : double c2;
17037 : double c3;
17038 : double c4;
17039 : double c5;
17040 : double v;
17041 : double tw0;
17042 : double tw1;
17043 : double twx;
17044 : double twxm1;
17045 : double twy;
17046 : double tw2x;
17047 : double tw2y;
17048 : double tw3x;
17049 : double tw3y;
17050 : double tw4x;
17051 : double tw4y;
17052 : double tw5x;
17053 : double tw5y;
17054 :
17055 :
17056 0 : ae_assert(operandscnt>=1, "FTApplyComplexCodeletFFT: OperandsCnt<1", _state);
17057 0 : ae_assert(operandsize>=1, "FTApplyComplexCodeletFFT: OperandSize<1", _state);
17058 0 : ae_assert(microvectorsize>=1, "FTApplyComplexCodeletFFT: MicrovectorSize<>1", _state);
17059 0 : ae_assert(microvectorsize%2==0, "FTApplyComplexCodeletFFT: MicrovectorSize is not even", _state);
17060 0 : n = operandsize;
17061 0 : m = microvectorsize/2;
17062 :
17063 : /*
17064 : * Hard-coded transforms for different N's
17065 : */
17066 0 : ae_assert(n<=ftbase_maxradix, "FTApplyComplexCodeletTwFFT: N>MaxRadix", _state);
17067 0 : if( n==2 )
17068 : {
17069 0 : v = -2*ae_pi/(n*m);
17070 0 : tw0 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
17071 0 : tw1 = ae_sin(v, _state);
17072 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17073 : {
17074 0 : aoffset0 = offs+opidx*operandsize*microvectorsize;
17075 0 : aoffset2 = aoffset0+microvectorsize;
17076 0 : twxm1 = 0.0;
17077 0 : twy = 0.0;
17078 0 : for(mvidx=0; mvidx<=m-1; mvidx++)
17079 : {
17080 0 : a0x = a->ptr.p_double[aoffset0];
17081 0 : a0y = a->ptr.p_double[aoffset0+1];
17082 0 : a1x = a->ptr.p_double[aoffset2];
17083 0 : a1y = a->ptr.p_double[aoffset2+1];
17084 0 : v0 = a0x+a1x;
17085 0 : v1 = a0y+a1y;
17086 0 : v2 = a0x-a1x;
17087 0 : v3 = a0y-a1y;
17088 0 : a->ptr.p_double[aoffset0] = v0;
17089 0 : a->ptr.p_double[aoffset0+1] = v1;
17090 0 : a->ptr.p_double[aoffset2] = v2*(1+twxm1)-v3*twy;
17091 0 : a->ptr.p_double[aoffset2+1] = v3*(1+twxm1)+v2*twy;
17092 0 : aoffset0 = aoffset0+2;
17093 0 : aoffset2 = aoffset2+2;
17094 0 : if( (mvidx+1)%ftbase_updatetw==0 )
17095 : {
17096 0 : v = -2*ae_pi*(mvidx+1)/(n*m);
17097 0 : twxm1 = ae_sin(0.5*v, _state);
17098 0 : twxm1 = -2*twxm1*twxm1;
17099 0 : twy = ae_sin(v, _state);
17100 : }
17101 : else
17102 : {
17103 0 : v = twxm1+tw0+twxm1*tw0-twy*tw1;
17104 0 : twy = twy+tw1+twxm1*tw1+twy*tw0;
17105 0 : twxm1 = v;
17106 : }
17107 : }
17108 : }
17109 0 : return;
17110 : }
17111 0 : if( n==3 )
17112 : {
17113 0 : v = -2*ae_pi/(n*m);
17114 0 : tw0 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
17115 0 : tw1 = ae_sin(v, _state);
17116 0 : c1 = ae_cos(2*ae_pi/3, _state)-1;
17117 0 : c2 = ae_sin(2*ae_pi/3, _state);
17118 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17119 : {
17120 0 : aoffset0 = offs+opidx*operandsize*microvectorsize;
17121 0 : aoffset2 = aoffset0+microvectorsize;
17122 0 : aoffset4 = aoffset2+microvectorsize;
17123 0 : twx = 1.0;
17124 0 : twxm1 = 0.0;
17125 0 : twy = 0.0;
17126 0 : for(mvidx=0; mvidx<=m-1; mvidx++)
17127 : {
17128 0 : a0x = a->ptr.p_double[aoffset0];
17129 0 : a0y = a->ptr.p_double[aoffset0+1];
17130 0 : a1x = a->ptr.p_double[aoffset2];
17131 0 : a1y = a->ptr.p_double[aoffset2+1];
17132 0 : a2x = a->ptr.p_double[aoffset4];
17133 0 : a2y = a->ptr.p_double[aoffset4+1];
17134 0 : t1x = a1x+a2x;
17135 0 : t1y = a1y+a2y;
17136 0 : a0x = a0x+t1x;
17137 0 : a0y = a0y+t1y;
17138 0 : m1x = c1*t1x;
17139 0 : m1y = c1*t1y;
17140 0 : m2x = c2*(a1y-a2y);
17141 0 : m2y = c2*(a2x-a1x);
17142 0 : s1x = a0x+m1x;
17143 0 : s1y = a0y+m1y;
17144 0 : a1x = s1x+m2x;
17145 0 : a1y = s1y+m2y;
17146 0 : a2x = s1x-m2x;
17147 0 : a2y = s1y-m2y;
17148 0 : tw2x = twx*twx-twy*twy;
17149 0 : tw2y = 2*twx*twy;
17150 0 : a->ptr.p_double[aoffset0] = a0x;
17151 0 : a->ptr.p_double[aoffset0+1] = a0y;
17152 0 : a->ptr.p_double[aoffset2] = a1x*twx-a1y*twy;
17153 0 : a->ptr.p_double[aoffset2+1] = a1y*twx+a1x*twy;
17154 0 : a->ptr.p_double[aoffset4] = a2x*tw2x-a2y*tw2y;
17155 0 : a->ptr.p_double[aoffset4+1] = a2y*tw2x+a2x*tw2y;
17156 0 : aoffset0 = aoffset0+2;
17157 0 : aoffset2 = aoffset2+2;
17158 0 : aoffset4 = aoffset4+2;
17159 0 : if( (mvidx+1)%ftbase_updatetw==0 )
17160 : {
17161 0 : v = -2*ae_pi*(mvidx+1)/(n*m);
17162 0 : twxm1 = ae_sin(0.5*v, _state);
17163 0 : twxm1 = -2*twxm1*twxm1;
17164 0 : twy = ae_sin(v, _state);
17165 0 : twx = twxm1+1;
17166 : }
17167 : else
17168 : {
17169 0 : v = twxm1+tw0+twxm1*tw0-twy*tw1;
17170 0 : twy = twy+tw1+twxm1*tw1+twy*tw0;
17171 0 : twxm1 = v;
17172 0 : twx = v+1;
17173 : }
17174 : }
17175 : }
17176 0 : return;
17177 : }
17178 0 : if( n==4 )
17179 : {
17180 0 : v = -2*ae_pi/(n*m);
17181 0 : tw0 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
17182 0 : tw1 = ae_sin(v, _state);
17183 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17184 : {
17185 0 : aoffset0 = offs+opidx*operandsize*microvectorsize;
17186 0 : aoffset2 = aoffset0+microvectorsize;
17187 0 : aoffset4 = aoffset2+microvectorsize;
17188 0 : aoffset6 = aoffset4+microvectorsize;
17189 0 : twx = 1.0;
17190 0 : twxm1 = 0.0;
17191 0 : twy = 0.0;
17192 0 : for(mvidx=0; mvidx<=m-1; mvidx++)
17193 : {
17194 0 : a0x = a->ptr.p_double[aoffset0];
17195 0 : a0y = a->ptr.p_double[aoffset0+1];
17196 0 : a1x = a->ptr.p_double[aoffset2];
17197 0 : a1y = a->ptr.p_double[aoffset2+1];
17198 0 : a2x = a->ptr.p_double[aoffset4];
17199 0 : a2y = a->ptr.p_double[aoffset4+1];
17200 0 : a3x = a->ptr.p_double[aoffset6];
17201 0 : a3y = a->ptr.p_double[aoffset6+1];
17202 0 : t1x = a0x+a2x;
17203 0 : t1y = a0y+a2y;
17204 0 : t2x = a1x+a3x;
17205 0 : t2y = a1y+a3y;
17206 0 : m2x = a0x-a2x;
17207 0 : m2y = a0y-a2y;
17208 0 : m3x = a1y-a3y;
17209 0 : m3y = a3x-a1x;
17210 0 : tw2x = twx*twx-twy*twy;
17211 0 : tw2y = 2*twx*twy;
17212 0 : tw3x = twx*tw2x-twy*tw2y;
17213 0 : tw3y = twx*tw2y+twy*tw2x;
17214 0 : a1x = m2x+m3x;
17215 0 : a1y = m2y+m3y;
17216 0 : a2x = t1x-t2x;
17217 0 : a2y = t1y-t2y;
17218 0 : a3x = m2x-m3x;
17219 0 : a3y = m2y-m3y;
17220 0 : a->ptr.p_double[aoffset0] = t1x+t2x;
17221 0 : a->ptr.p_double[aoffset0+1] = t1y+t2y;
17222 0 : a->ptr.p_double[aoffset2] = a1x*twx-a1y*twy;
17223 0 : a->ptr.p_double[aoffset2+1] = a1y*twx+a1x*twy;
17224 0 : a->ptr.p_double[aoffset4] = a2x*tw2x-a2y*tw2y;
17225 0 : a->ptr.p_double[aoffset4+1] = a2y*tw2x+a2x*tw2y;
17226 0 : a->ptr.p_double[aoffset6] = a3x*tw3x-a3y*tw3y;
17227 0 : a->ptr.p_double[aoffset6+1] = a3y*tw3x+a3x*tw3y;
17228 0 : aoffset0 = aoffset0+2;
17229 0 : aoffset2 = aoffset2+2;
17230 0 : aoffset4 = aoffset4+2;
17231 0 : aoffset6 = aoffset6+2;
17232 0 : if( (mvidx+1)%ftbase_updatetw==0 )
17233 : {
17234 0 : v = -2*ae_pi*(mvidx+1)/(n*m);
17235 0 : twxm1 = ae_sin(0.5*v, _state);
17236 0 : twxm1 = -2*twxm1*twxm1;
17237 0 : twy = ae_sin(v, _state);
17238 0 : twx = twxm1+1;
17239 : }
17240 : else
17241 : {
17242 0 : v = twxm1+tw0+twxm1*tw0-twy*tw1;
17243 0 : twy = twy+tw1+twxm1*tw1+twy*tw0;
17244 0 : twxm1 = v;
17245 0 : twx = v+1;
17246 : }
17247 : }
17248 : }
17249 0 : return;
17250 : }
17251 0 : if( n==5 )
17252 : {
17253 0 : v = -2*ae_pi/(n*m);
17254 0 : tw0 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
17255 0 : tw1 = ae_sin(v, _state);
17256 0 : v = 2*ae_pi/5;
17257 0 : c1 = (ae_cos(v, _state)+ae_cos(2*v, _state))/2-1;
17258 0 : c2 = (ae_cos(v, _state)-ae_cos(2*v, _state))/2;
17259 0 : c3 = -ae_sin(v, _state);
17260 0 : c4 = -(ae_sin(v, _state)+ae_sin(2*v, _state));
17261 0 : c5 = ae_sin(v, _state)-ae_sin(2*v, _state);
17262 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17263 : {
17264 0 : aoffset0 = offs+opidx*operandsize*microvectorsize;
17265 0 : aoffset2 = aoffset0+microvectorsize;
17266 0 : aoffset4 = aoffset2+microvectorsize;
17267 0 : aoffset6 = aoffset4+microvectorsize;
17268 0 : aoffset8 = aoffset6+microvectorsize;
17269 0 : twx = 1.0;
17270 0 : twxm1 = 0.0;
17271 0 : twy = 0.0;
17272 0 : for(mvidx=0; mvidx<=m-1; mvidx++)
17273 : {
17274 0 : a0x = a->ptr.p_double[aoffset0];
17275 0 : a0y = a->ptr.p_double[aoffset0+1];
17276 0 : a1x = a->ptr.p_double[aoffset2];
17277 0 : a1y = a->ptr.p_double[aoffset2+1];
17278 0 : a2x = a->ptr.p_double[aoffset4];
17279 0 : a2y = a->ptr.p_double[aoffset4+1];
17280 0 : a3x = a->ptr.p_double[aoffset6];
17281 0 : a3y = a->ptr.p_double[aoffset6+1];
17282 0 : a4x = a->ptr.p_double[aoffset8];
17283 0 : a4y = a->ptr.p_double[aoffset8+1];
17284 0 : t1x = a1x+a4x;
17285 0 : t1y = a1y+a4y;
17286 0 : t2x = a2x+a3x;
17287 0 : t2y = a2y+a3y;
17288 0 : t3x = a1x-a4x;
17289 0 : t3y = a1y-a4y;
17290 0 : t4x = a3x-a2x;
17291 0 : t4y = a3y-a2y;
17292 0 : t5x = t1x+t2x;
17293 0 : t5y = t1y+t2y;
17294 0 : q0x = a0x+t5x;
17295 0 : q0y = a0y+t5y;
17296 0 : m1x = c1*t5x;
17297 0 : m1y = c1*t5y;
17298 0 : m2x = c2*(t1x-t2x);
17299 0 : m2y = c2*(t1y-t2y);
17300 0 : m3x = -c3*(t3y+t4y);
17301 0 : m3y = c3*(t3x+t4x);
17302 0 : m4x = -c4*t4y;
17303 0 : m4y = c4*t4x;
17304 0 : m5x = -c5*t3y;
17305 0 : m5y = c5*t3x;
17306 0 : s3x = m3x-m4x;
17307 0 : s3y = m3y-m4y;
17308 0 : s5x = m3x+m5x;
17309 0 : s5y = m3y+m5y;
17310 0 : s1x = q0x+m1x;
17311 0 : s1y = q0y+m1y;
17312 0 : s2x = s1x+m2x;
17313 0 : s2y = s1y+m2y;
17314 0 : s4x = s1x-m2x;
17315 0 : s4y = s1y-m2y;
17316 0 : tw2x = twx*twx-twy*twy;
17317 0 : tw2y = 2*twx*twy;
17318 0 : tw3x = twx*tw2x-twy*tw2y;
17319 0 : tw3y = twx*tw2y+twy*tw2x;
17320 0 : tw4x = tw2x*tw2x-tw2y*tw2y;
17321 0 : tw4y = tw2x*tw2y+tw2y*tw2x;
17322 0 : a1x = s2x+s3x;
17323 0 : a1y = s2y+s3y;
17324 0 : a2x = s4x+s5x;
17325 0 : a2y = s4y+s5y;
17326 0 : a3x = s4x-s5x;
17327 0 : a3y = s4y-s5y;
17328 0 : a4x = s2x-s3x;
17329 0 : a4y = s2y-s3y;
17330 0 : a->ptr.p_double[aoffset0] = q0x;
17331 0 : a->ptr.p_double[aoffset0+1] = q0y;
17332 0 : a->ptr.p_double[aoffset2] = a1x*twx-a1y*twy;
17333 0 : a->ptr.p_double[aoffset2+1] = a1x*twy+a1y*twx;
17334 0 : a->ptr.p_double[aoffset4] = a2x*tw2x-a2y*tw2y;
17335 0 : a->ptr.p_double[aoffset4+1] = a2x*tw2y+a2y*tw2x;
17336 0 : a->ptr.p_double[aoffset6] = a3x*tw3x-a3y*tw3y;
17337 0 : a->ptr.p_double[aoffset6+1] = a3x*tw3y+a3y*tw3x;
17338 0 : a->ptr.p_double[aoffset8] = a4x*tw4x-a4y*tw4y;
17339 0 : a->ptr.p_double[aoffset8+1] = a4x*tw4y+a4y*tw4x;
17340 0 : aoffset0 = aoffset0+2;
17341 0 : aoffset2 = aoffset2+2;
17342 0 : aoffset4 = aoffset4+2;
17343 0 : aoffset6 = aoffset6+2;
17344 0 : aoffset8 = aoffset8+2;
17345 0 : if( (mvidx+1)%ftbase_updatetw==0 )
17346 : {
17347 0 : v = -2*ae_pi*(mvidx+1)/(n*m);
17348 0 : twxm1 = ae_sin(0.5*v, _state);
17349 0 : twxm1 = -2*twxm1*twxm1;
17350 0 : twy = ae_sin(v, _state);
17351 0 : twx = twxm1+1;
17352 : }
17353 : else
17354 : {
17355 0 : v = twxm1+tw0+twxm1*tw0-twy*tw1;
17356 0 : twy = twy+tw1+twxm1*tw1+twy*tw0;
17357 0 : twxm1 = v;
17358 0 : twx = v+1;
17359 : }
17360 : }
17361 : }
17362 0 : return;
17363 : }
17364 0 : if( n==6 )
17365 : {
17366 0 : c1 = ae_cos(2*ae_pi/3, _state)-1;
17367 0 : c2 = ae_sin(2*ae_pi/3, _state);
17368 0 : c3 = ae_cos(-ae_pi/3, _state);
17369 0 : c4 = ae_sin(-ae_pi/3, _state);
17370 0 : v = -2*ae_pi/(n*m);
17371 0 : tw0 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
17372 0 : tw1 = ae_sin(v, _state);
17373 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17374 : {
17375 0 : aoffset0 = offs+opidx*operandsize*microvectorsize;
17376 0 : aoffset2 = aoffset0+microvectorsize;
17377 0 : aoffset4 = aoffset2+microvectorsize;
17378 0 : aoffset6 = aoffset4+microvectorsize;
17379 0 : aoffset8 = aoffset6+microvectorsize;
17380 0 : aoffset10 = aoffset8+microvectorsize;
17381 0 : twx = 1.0;
17382 0 : twxm1 = 0.0;
17383 0 : twy = 0.0;
17384 0 : for(mvidx=0; mvidx<=m-1; mvidx++)
17385 : {
17386 0 : a0x = a->ptr.p_double[aoffset0+0];
17387 0 : a0y = a->ptr.p_double[aoffset0+1];
17388 0 : a1x = a->ptr.p_double[aoffset2+0];
17389 0 : a1y = a->ptr.p_double[aoffset2+1];
17390 0 : a2x = a->ptr.p_double[aoffset4+0];
17391 0 : a2y = a->ptr.p_double[aoffset4+1];
17392 0 : a3x = a->ptr.p_double[aoffset6+0];
17393 0 : a3y = a->ptr.p_double[aoffset6+1];
17394 0 : a4x = a->ptr.p_double[aoffset8+0];
17395 0 : a4y = a->ptr.p_double[aoffset8+1];
17396 0 : a5x = a->ptr.p_double[aoffset10+0];
17397 0 : a5y = a->ptr.p_double[aoffset10+1];
17398 0 : v0 = a0x;
17399 0 : v1 = a0y;
17400 0 : a0x = a0x+a3x;
17401 0 : a0y = a0y+a3y;
17402 0 : a3x = v0-a3x;
17403 0 : a3y = v1-a3y;
17404 0 : v0 = a1x;
17405 0 : v1 = a1y;
17406 0 : a1x = a1x+a4x;
17407 0 : a1y = a1y+a4y;
17408 0 : a4x = v0-a4x;
17409 0 : a4y = v1-a4y;
17410 0 : v0 = a2x;
17411 0 : v1 = a2y;
17412 0 : a2x = a2x+a5x;
17413 0 : a2y = a2y+a5y;
17414 0 : a5x = v0-a5x;
17415 0 : a5y = v1-a5y;
17416 0 : t4x = a4x*c3-a4y*c4;
17417 0 : t4y = a4x*c4+a4y*c3;
17418 0 : a4x = t4x;
17419 0 : a4y = t4y;
17420 0 : t5x = -a5x*c3-a5y*c4;
17421 0 : t5y = a5x*c4-a5y*c3;
17422 0 : a5x = t5x;
17423 0 : a5y = t5y;
17424 0 : t1x = a1x+a2x;
17425 0 : t1y = a1y+a2y;
17426 0 : a0x = a0x+t1x;
17427 0 : a0y = a0y+t1y;
17428 0 : m1x = c1*t1x;
17429 0 : m1y = c1*t1y;
17430 0 : m2x = c2*(a1y-a2y);
17431 0 : m2y = c2*(a2x-a1x);
17432 0 : s1x = a0x+m1x;
17433 0 : s1y = a0y+m1y;
17434 0 : a1x = s1x+m2x;
17435 0 : a1y = s1y+m2y;
17436 0 : a2x = s1x-m2x;
17437 0 : a2y = s1y-m2y;
17438 0 : t1x = a4x+a5x;
17439 0 : t1y = a4y+a5y;
17440 0 : a3x = a3x+t1x;
17441 0 : a3y = a3y+t1y;
17442 0 : m1x = c1*t1x;
17443 0 : m1y = c1*t1y;
17444 0 : m2x = c2*(a4y-a5y);
17445 0 : m2y = c2*(a5x-a4x);
17446 0 : s1x = a3x+m1x;
17447 0 : s1y = a3y+m1y;
17448 0 : a4x = s1x+m2x;
17449 0 : a4y = s1y+m2y;
17450 0 : a5x = s1x-m2x;
17451 0 : a5y = s1y-m2y;
17452 0 : tw2x = twx*twx-twy*twy;
17453 0 : tw2y = 2*twx*twy;
17454 0 : tw3x = twx*tw2x-twy*tw2y;
17455 0 : tw3y = twx*tw2y+twy*tw2x;
17456 0 : tw4x = tw2x*tw2x-tw2y*tw2y;
17457 0 : tw4y = 2*tw2x*tw2y;
17458 0 : tw5x = tw3x*tw2x-tw3y*tw2y;
17459 0 : tw5y = tw3x*tw2y+tw3y*tw2x;
17460 0 : a->ptr.p_double[aoffset0+0] = a0x;
17461 0 : a->ptr.p_double[aoffset0+1] = a0y;
17462 0 : a->ptr.p_double[aoffset2+0] = a3x*twx-a3y*twy;
17463 0 : a->ptr.p_double[aoffset2+1] = a3y*twx+a3x*twy;
17464 0 : a->ptr.p_double[aoffset4+0] = a1x*tw2x-a1y*tw2y;
17465 0 : a->ptr.p_double[aoffset4+1] = a1y*tw2x+a1x*tw2y;
17466 0 : a->ptr.p_double[aoffset6+0] = a4x*tw3x-a4y*tw3y;
17467 0 : a->ptr.p_double[aoffset6+1] = a4y*tw3x+a4x*tw3y;
17468 0 : a->ptr.p_double[aoffset8+0] = a2x*tw4x-a2y*tw4y;
17469 0 : a->ptr.p_double[aoffset8+1] = a2y*tw4x+a2x*tw4y;
17470 0 : a->ptr.p_double[aoffset10+0] = a5x*tw5x-a5y*tw5y;
17471 0 : a->ptr.p_double[aoffset10+1] = a5y*tw5x+a5x*tw5y;
17472 0 : aoffset0 = aoffset0+2;
17473 0 : aoffset2 = aoffset2+2;
17474 0 : aoffset4 = aoffset4+2;
17475 0 : aoffset6 = aoffset6+2;
17476 0 : aoffset8 = aoffset8+2;
17477 0 : aoffset10 = aoffset10+2;
17478 0 : if( (mvidx+1)%ftbase_updatetw==0 )
17479 : {
17480 0 : v = -2*ae_pi*(mvidx+1)/(n*m);
17481 0 : twxm1 = ae_sin(0.5*v, _state);
17482 0 : twxm1 = -2*twxm1*twxm1;
17483 0 : twy = ae_sin(v, _state);
17484 0 : twx = twxm1+1;
17485 : }
17486 : else
17487 : {
17488 0 : v = twxm1+tw0+twxm1*tw0-twy*tw1;
17489 0 : twy = twy+tw1+twxm1*tw1+twy*tw0;
17490 0 : twxm1 = v;
17491 0 : twx = v+1;
17492 : }
17493 : }
17494 : }
17495 0 : return;
17496 : }
17497 : }
17498 :
17499 :
17500 : /*************************************************************************
17501 : This subroutine precomputes data for complex Bluestein's FFT and writes
17502 : them to array PrecR[] at specified offset. It is responsibility of the
17503 : caller to make sure that PrecR[] is large enough.
17504 :
17505 : INPUT PARAMETERS:
17506 : N - original size of the transform
17507 : M - size of the "padded" Bluestein's transform
17508 : PrecR - preallocated array
17509 : Offs - offset
17510 :
17511 : OUTPUT PARAMETERS:
17512 : PrecR - data at Offs:Offs+4*M-1 are modified:
17513 : * PrecR[Offs:Offs+2*M-1] stores Z[k]=exp(i*pi*k^2/N)
17514 : * PrecR[Offs+2*M:Offs+4*M-1] stores FFT of the Z
17515 : Other parts of PrecR are unchanged.
17516 :
17517 : NOTE: this function performs internal M-point FFT. It allocates temporary
17518 : plan which is destroyed after leaving this function.
17519 :
17520 : -- ALGLIB --
17521 : Copyright 08.05.2013 by Bochkanov Sergey
17522 : *************************************************************************/
17523 0 : static void ftbase_ftprecomputebluesteinsfft(ae_int_t n,
17524 : ae_int_t m,
17525 : /* Real */ ae_vector* precr,
17526 : ae_int_t offs,
17527 : ae_state *_state)
17528 : {
17529 : ae_frame _frame_block;
17530 : ae_int_t i;
17531 : double bx;
17532 : double by;
17533 : fasttransformplan plan;
17534 :
17535 0 : ae_frame_make(_state, &_frame_block);
17536 0 : memset(&plan, 0, sizeof(plan));
17537 0 : _fasttransformplan_init(&plan, _state, ae_true);
17538 :
17539 :
17540 : /*
17541 : * Fill first half of PrecR with b[k] = exp(i*pi*k^2/N)
17542 : */
17543 0 : for(i=0; i<=2*m-1; i++)
17544 : {
17545 0 : precr->ptr.p_double[offs+i] = (double)(0);
17546 : }
17547 0 : for(i=0; i<=n-1; i++)
17548 : {
17549 0 : bx = ae_cos(ae_pi/n*i*i, _state);
17550 0 : by = ae_sin(ae_pi/n*i*i, _state);
17551 0 : precr->ptr.p_double[offs+2*i+0] = bx;
17552 0 : precr->ptr.p_double[offs+2*i+1] = by;
17553 0 : precr->ptr.p_double[offs+2*((m-i)%m)+0] = bx;
17554 0 : precr->ptr.p_double[offs+2*((m-i)%m)+1] = by;
17555 : }
17556 :
17557 : /*
17558 : * Precomputed FFT
17559 : */
17560 0 : ftcomplexfftplan(m, 1, &plan, _state);
17561 0 : for(i=0; i<=2*m-1; i++)
17562 : {
17563 0 : precr->ptr.p_double[offs+2*m+i] = precr->ptr.p_double[offs+i];
17564 : }
17565 0 : ftbase_ftapplysubplan(&plan, 0, precr, offs+2*m, 0, &plan.buffer, 1, _state);
17566 0 : ae_frame_leave(_state);
17567 0 : }
17568 :
17569 :
17570 : /*************************************************************************
17571 : This subroutine applies complex Bluestein's FFT to input/output array A.
17572 :
17573 : INPUT PARAMETERS:
17574 : Plan - transformation plan
17575 : A - array, must be large enough for plan to work
17576 : ABase - base offset in array A, this value points to start of
17577 : subarray whose length is equal to length of the plan
17578 : AOffset - offset with respect to ABase, 0<=AOffset<PlanLength.
17579 : This is an offset within large PlanLength-subarray of
17580 : the chunk to process.
17581 : OperandsCnt - number of repeated operands (length N each)
17582 : N - original data length (measured in complex numbers)
17583 : M - padded data length (measured in complex numbers)
17584 : PrecOffs - offset of the precomputed data for the plan
17585 : SubPlan - position of the length-M FFT subplan which is used by
17586 : transformation
17587 : BufA - temporary buffer, at least 2*M elements
17588 : BufB - temporary buffer, at least 2*M elements
17589 : BufC - temporary buffer, at least 2*M elements
17590 : BufD - temporary buffer, at least 2*M elements
17591 :
17592 : OUTPUT PARAMETERS:
17593 : A - transformed array
17594 :
17595 : -- ALGLIB --
17596 : Copyright 05.04.2013 by Bochkanov Sergey
17597 : *************************************************************************/
17598 0 : static void ftbase_ftbluesteinsfft(fasttransformplan* plan,
17599 : /* Real */ ae_vector* a,
17600 : ae_int_t abase,
17601 : ae_int_t aoffset,
17602 : ae_int_t operandscnt,
17603 : ae_int_t n,
17604 : ae_int_t m,
17605 : ae_int_t precoffs,
17606 : ae_int_t subplan,
17607 : /* Real */ ae_vector* bufa,
17608 : /* Real */ ae_vector* bufb,
17609 : /* Real */ ae_vector* bufc,
17610 : /* Real */ ae_vector* bufd,
17611 : ae_state *_state)
17612 : {
17613 : ae_int_t op;
17614 : ae_int_t i;
17615 : double x;
17616 : double y;
17617 : double bx;
17618 : double by;
17619 : double ax;
17620 : double ay;
17621 : double rx;
17622 : double ry;
17623 : ae_int_t p0;
17624 : ae_int_t p1;
17625 : ae_int_t p2;
17626 :
17627 :
17628 0 : for(op=0; op<=operandscnt-1; op++)
17629 : {
17630 :
17631 : /*
17632 : * Multiply A by conj(Z), store to buffer.
17633 : * Pad A by zeros.
17634 : *
17635 : * NOTE: Z[k]=exp(i*pi*k^2/N)
17636 : */
17637 0 : p0 = abase+aoffset+op*2*n;
17638 0 : p1 = precoffs;
17639 0 : for(i=0; i<=n-1; i++)
17640 : {
17641 0 : x = a->ptr.p_double[p0+0];
17642 0 : y = a->ptr.p_double[p0+1];
17643 0 : bx = plan->precr.ptr.p_double[p1+0];
17644 0 : by = -plan->precr.ptr.p_double[p1+1];
17645 0 : bufa->ptr.p_double[2*i+0] = x*bx-y*by;
17646 0 : bufa->ptr.p_double[2*i+1] = x*by+y*bx;
17647 0 : p0 = p0+2;
17648 0 : p1 = p1+2;
17649 : }
17650 0 : for(i=2*n; i<=2*m-1; i++)
17651 : {
17652 0 : bufa->ptr.p_double[i] = (double)(0);
17653 : }
17654 :
17655 : /*
17656 : * Perform convolution of A and Z (using precomputed
17657 : * FFT of Z stored in Plan structure).
17658 : */
17659 0 : ftbase_ftapplysubplan(plan, subplan, bufa, 0, 0, bufc, 1, _state);
17660 0 : p0 = 0;
17661 0 : p1 = precoffs+2*m;
17662 0 : for(i=0; i<=m-1; i++)
17663 : {
17664 0 : ax = bufa->ptr.p_double[p0+0];
17665 0 : ay = bufa->ptr.p_double[p0+1];
17666 0 : bx = plan->precr.ptr.p_double[p1+0];
17667 0 : by = plan->precr.ptr.p_double[p1+1];
17668 0 : bufa->ptr.p_double[p0+0] = ax*bx-ay*by;
17669 0 : bufa->ptr.p_double[p0+1] = -(ax*by+ay*bx);
17670 0 : p0 = p0+2;
17671 0 : p1 = p1+2;
17672 : }
17673 0 : ftbase_ftapplysubplan(plan, subplan, bufa, 0, 0, bufc, 1, _state);
17674 :
17675 : /*
17676 : * Post processing:
17677 : * A:=conj(Z)*conj(A)/M
17678 : * Here conj(A)/M corresponds to last stage of inverse DFT,
17679 : * and conj(Z) comes from Bluestein's FFT algorithm.
17680 : */
17681 0 : p0 = precoffs;
17682 0 : p1 = 0;
17683 0 : p2 = abase+aoffset+op*2*n;
17684 0 : for(i=0; i<=n-1; i++)
17685 : {
17686 0 : bx = plan->precr.ptr.p_double[p0+0];
17687 0 : by = plan->precr.ptr.p_double[p0+1];
17688 0 : rx = bufa->ptr.p_double[p1+0]/m;
17689 0 : ry = -bufa->ptr.p_double[p1+1]/m;
17690 0 : a->ptr.p_double[p2+0] = rx*bx-ry*(-by);
17691 0 : a->ptr.p_double[p2+1] = rx*(-by)+ry*bx;
17692 0 : p0 = p0+2;
17693 0 : p1 = p1+2;
17694 0 : p2 = p2+2;
17695 : }
17696 : }
17697 0 : }
17698 :
17699 :
17700 : /*************************************************************************
17701 : This subroutine precomputes data for complex Rader's FFT and writes them
17702 : to array PrecR[] at specified offset. It is responsibility of the caller
17703 : to make sure that PrecR[] is large enough.
17704 :
17705 : INPUT PARAMETERS:
17706 : N - original size of the transform (before reduction to N-1)
17707 : RQ - primitive root modulo N
17708 : RIQ - inverse of primitive root modulo N
17709 : PrecR - preallocated array
17710 : Offs - offset
17711 :
17712 : OUTPUT PARAMETERS:
17713 : PrecR - data at Offs:Offs+2*(N-1)-1 store FFT of Rader's factors,
17714 : other parts of PrecR are unchanged.
17715 :
17716 : NOTE: this function performs internal (N-1)-point FFT. It allocates temporary
17717 : plan which is destroyed after leaving this function.
17718 :
17719 : -- ALGLIB --
17720 : Copyright 08.05.2013 by Bochkanov Sergey
17721 : *************************************************************************/
17722 0 : static void ftbase_ftprecomputeradersfft(ae_int_t n,
17723 : ae_int_t rq,
17724 : ae_int_t riq,
17725 : /* Real */ ae_vector* precr,
17726 : ae_int_t offs,
17727 : ae_state *_state)
17728 : {
17729 : ae_frame _frame_block;
17730 : ae_int_t q;
17731 : fasttransformplan plan;
17732 : ae_int_t kiq;
17733 : double v;
17734 :
17735 0 : ae_frame_make(_state, &_frame_block);
17736 0 : memset(&plan, 0, sizeof(plan));
17737 0 : _fasttransformplan_init(&plan, _state, ae_true);
17738 :
17739 :
17740 : /*
17741 : * Fill PrecR with Rader factors, perform FFT
17742 : */
17743 0 : kiq = 1;
17744 0 : for(q=0; q<=n-2; q++)
17745 : {
17746 0 : v = -2*ae_pi*kiq/n;
17747 0 : precr->ptr.p_double[offs+2*q+0] = ae_cos(v, _state);
17748 0 : precr->ptr.p_double[offs+2*q+1] = ae_sin(v, _state);
17749 0 : kiq = kiq*riq%n;
17750 : }
17751 0 : ftcomplexfftplan(n-1, 1, &plan, _state);
17752 0 : ftbase_ftapplysubplan(&plan, 0, precr, offs, 0, &plan.buffer, 1, _state);
17753 0 : ae_frame_leave(_state);
17754 0 : }
17755 :
17756 :
17757 : /*************************************************************************
17758 : This subroutine applies complex Rader's FFT to input/output array A.
17759 :
17760 : INPUT PARAMETERS:
17761 : A - array, must be large enough for plan to work
17762 : ABase - base offset in array A, this value points to start of
17763 : subarray whose length is equal to length of the plan
17764 : AOffset - offset with respect to ABase, 0<=AOffset<PlanLength.
17765 : This is an offset within large PlanLength-subarray of
17766 : the chunk to process.
17767 : OperandsCnt - number of repeated operands (length N each)
17768 : N - original data length (measured in complex numbers)
17769 : SubPlan - position of the (N-1)-point FFT subplan which is used
17770 : by transformation
17771 : RQ - primitive root modulo N
17772 : RIQ - inverse of primitive root modulo N
17773 : PrecOffs - offset of the precomputed data for the plan
17774 : Buf - temporary array
17775 :
17776 : OUTPUT PARAMETERS:
17777 : A - transformed array
17778 :
17779 : -- ALGLIB --
17780 : Copyright 05.04.2013 by Bochkanov Sergey
17781 : *************************************************************************/
17782 0 : static void ftbase_ftradersfft(fasttransformplan* plan,
17783 : /* Real */ ae_vector* a,
17784 : ae_int_t abase,
17785 : ae_int_t aoffset,
17786 : ae_int_t operandscnt,
17787 : ae_int_t n,
17788 : ae_int_t subplan,
17789 : ae_int_t rq,
17790 : ae_int_t riq,
17791 : ae_int_t precoffs,
17792 : /* Real */ ae_vector* buf,
17793 : ae_state *_state)
17794 : {
17795 : ae_int_t opidx;
17796 : ae_int_t i;
17797 : ae_int_t q;
17798 : ae_int_t kq;
17799 : ae_int_t kiq;
17800 : double x0;
17801 : double y0;
17802 : ae_int_t p0;
17803 : ae_int_t p1;
17804 : double ax;
17805 : double ay;
17806 : double bx;
17807 : double by;
17808 : double rx;
17809 : double ry;
17810 :
17811 :
17812 0 : ae_assert(operandscnt>=1, "FTApplyComplexRefFFT: OperandsCnt<1", _state);
17813 :
17814 : /*
17815 : * Process operands
17816 : */
17817 0 : for(opidx=0; opidx<=operandscnt-1; opidx++)
17818 : {
17819 :
17820 : /*
17821 : * fill QA
17822 : */
17823 0 : kq = 1;
17824 0 : p0 = abase+aoffset+opidx*n*2;
17825 0 : p1 = aoffset+opidx*n*2;
17826 0 : rx = a->ptr.p_double[p0+0];
17827 0 : ry = a->ptr.p_double[p0+1];
17828 0 : x0 = rx;
17829 0 : y0 = ry;
17830 0 : for(q=0; q<=n-2; q++)
17831 : {
17832 0 : ax = a->ptr.p_double[p0+2*kq+0];
17833 0 : ay = a->ptr.p_double[p0+2*kq+1];
17834 0 : buf->ptr.p_double[p1+0] = ax;
17835 0 : buf->ptr.p_double[p1+1] = ay;
17836 0 : rx = rx+ax;
17837 0 : ry = ry+ay;
17838 0 : kq = kq*rq%n;
17839 0 : p1 = p1+2;
17840 : }
17841 0 : p0 = abase+aoffset+opidx*n*2;
17842 0 : p1 = aoffset+opidx*n*2;
17843 0 : for(q=0; q<=n-2; q++)
17844 : {
17845 0 : a->ptr.p_double[p0] = buf->ptr.p_double[p1];
17846 0 : a->ptr.p_double[p0+1] = buf->ptr.p_double[p1+1];
17847 0 : p0 = p0+2;
17848 0 : p1 = p1+2;
17849 : }
17850 :
17851 : /*
17852 : * Convolution
17853 : */
17854 0 : ftbase_ftapplysubplan(plan, subplan, a, abase, aoffset+opidx*n*2, buf, 1, _state);
17855 0 : p0 = abase+aoffset+opidx*n*2;
17856 0 : p1 = precoffs;
17857 0 : for(i=0; i<=n-2; i++)
17858 : {
17859 0 : ax = a->ptr.p_double[p0+0];
17860 0 : ay = a->ptr.p_double[p0+1];
17861 0 : bx = plan->precr.ptr.p_double[p1+0];
17862 0 : by = plan->precr.ptr.p_double[p1+1];
17863 0 : a->ptr.p_double[p0+0] = ax*bx-ay*by;
17864 0 : a->ptr.p_double[p0+1] = -(ax*by+ay*bx);
17865 0 : p0 = p0+2;
17866 0 : p1 = p1+2;
17867 : }
17868 0 : ftbase_ftapplysubplan(plan, subplan, a, abase, aoffset+opidx*n*2, buf, 1, _state);
17869 0 : p0 = abase+aoffset+opidx*n*2;
17870 0 : for(i=0; i<=n-2; i++)
17871 : {
17872 0 : a->ptr.p_double[p0+0] = a->ptr.p_double[p0+0]/(n-1);
17873 0 : a->ptr.p_double[p0+1] = -a->ptr.p_double[p0+1]/(n-1);
17874 0 : p0 = p0+2;
17875 : }
17876 :
17877 : /*
17878 : * Result
17879 : */
17880 0 : buf->ptr.p_double[aoffset+opidx*n*2+0] = rx;
17881 0 : buf->ptr.p_double[aoffset+opidx*n*2+1] = ry;
17882 0 : kiq = 1;
17883 0 : p0 = aoffset+opidx*n*2;
17884 0 : p1 = abase+aoffset+opidx*n*2;
17885 0 : for(q=0; q<=n-2; q++)
17886 : {
17887 0 : buf->ptr.p_double[p0+2*kiq+0] = x0+a->ptr.p_double[p1+0];
17888 0 : buf->ptr.p_double[p0+2*kiq+1] = y0+a->ptr.p_double[p1+1];
17889 0 : kiq = kiq*riq%n;
17890 0 : p1 = p1+2;
17891 : }
17892 0 : p0 = abase+aoffset+opidx*n*2;
17893 0 : p1 = aoffset+opidx*n*2;
17894 0 : for(q=0; q<=n-1; q++)
17895 : {
17896 0 : a->ptr.p_double[p0] = buf->ptr.p_double[p1];
17897 0 : a->ptr.p_double[p0+1] = buf->ptr.p_double[p1+1];
17898 0 : p0 = p0+2;
17899 0 : p1 = p1+2;
17900 : }
17901 : }
17902 0 : }
17903 :
17904 :
17905 : /*************************************************************************
17906 : Factorizes task size N into product of two smaller sizes N1 and N2
17907 :
17908 : INPUT PARAMETERS:
17909 : N - task size, N>0
17910 : IsRoot - whether taks is root task (first one in a sequence)
17911 :
17912 : OUTPUT PARAMETERS:
17913 : N1, N2 - such numbers that:
17914 : * for prime N: N1=N2=0
17915 : * for composite N<=MaxRadix: N1=N2=0
17916 : * for composite N>MaxRadix: 1<=N1<=N2, N1*N2=N
17917 :
17918 : -- ALGLIB --
17919 : Copyright 08.04.2013 by Bochkanov Sergey
17920 : *************************************************************************/
17921 0 : static void ftbase_ftfactorize(ae_int_t n,
17922 : ae_bool isroot,
17923 : ae_int_t* n1,
17924 : ae_int_t* n2,
17925 : ae_state *_state)
17926 : {
17927 : ae_int_t j;
17928 : ae_int_t k;
17929 :
17930 0 : *n1 = 0;
17931 0 : *n2 = 0;
17932 :
17933 0 : ae_assert(n>0, "FTFactorize: N<=0", _state);
17934 0 : *n1 = 0;
17935 0 : *n2 = 0;
17936 :
17937 : /*
17938 : * Small N
17939 : */
17940 0 : if( n<=ftbase_maxradix )
17941 : {
17942 0 : return;
17943 : }
17944 :
17945 : /*
17946 : * Large N, recursive split
17947 : */
17948 0 : if( n>ftbase_recursivethreshold )
17949 : {
17950 0 : k = ae_iceil(ae_sqrt((double)(n), _state), _state)+1;
17951 0 : ae_assert(k*k>=n, "FTFactorize: internal error during recursive factorization", _state);
17952 0 : for(j=k; j>=2; j--)
17953 : {
17954 0 : if( n%j==0 )
17955 : {
17956 0 : *n1 = ae_minint(n/j, j, _state);
17957 0 : *n2 = ae_maxint(n/j, j, _state);
17958 0 : return;
17959 : }
17960 : }
17961 : }
17962 :
17963 : /*
17964 : * N>MaxRadix, try to find good codelet
17965 : */
17966 0 : for(j=ftbase_maxradix; j>=2; j--)
17967 : {
17968 0 : if( n%j==0 )
17969 : {
17970 0 : *n1 = j;
17971 0 : *n2 = n/j;
17972 0 : break;
17973 : }
17974 : }
17975 :
17976 : /*
17977 : * In case no good codelet was found,
17978 : * try to factorize N into product of ANY primes.
17979 : */
17980 0 : if( *n1*(*n2)!=n )
17981 : {
17982 0 : for(j=2; j<=n-1; j++)
17983 : {
17984 0 : if( n%j==0 )
17985 : {
17986 0 : *n1 = j;
17987 0 : *n2 = n/j;
17988 0 : break;
17989 : }
17990 0 : if( j*j>n )
17991 : {
17992 0 : break;
17993 : }
17994 : }
17995 : }
17996 :
17997 : /*
17998 : * normalize
17999 : */
18000 0 : if( *n1>(*n2) )
18001 : {
18002 0 : j = *n1;
18003 0 : *n1 = *n2;
18004 0 : *n2 = j;
18005 : }
18006 : }
18007 :
18008 :
18009 : /*************************************************************************
18010 : Returns optimistic estimate of the FFT cost, in UNITs (1 UNIT = 100 KFLOPs)
18011 :
18012 : INPUT PARAMETERS:
18013 : N - task size, N>0
18014 :
18015 : RESULU:
18016 : cost in UNITs, rounded down to nearest integer
18017 :
18018 : NOTE: If FFT cost is less than 1 UNIT, it will return 0 as result.
18019 :
18020 : -- ALGLIB --
18021 : Copyright 08.04.2013 by Bochkanov Sergey
18022 : *************************************************************************/
18023 0 : static ae_int_t ftbase_ftoptimisticestimate(ae_int_t n, ae_state *_state)
18024 : {
18025 : ae_int_t result;
18026 :
18027 :
18028 0 : ae_assert(n>0, "FTOptimisticEstimate: N<=0", _state);
18029 0 : result = ae_ifloor(1.0E-5*5*n*ae_log((double)(n), _state)/ae_log((double)(2), _state), _state);
18030 0 : return result;
18031 : }
18032 :
18033 :
18034 : /*************************************************************************
18035 : Twiddle factors calculation
18036 :
18037 : -- ALGLIB --
18038 : Copyright 01.05.2009 by Bochkanov Sergey
18039 : *************************************************************************/
18040 0 : static void ftbase_ffttwcalc(/* Real */ ae_vector* a,
18041 : ae_int_t aoffset,
18042 : ae_int_t n1,
18043 : ae_int_t n2,
18044 : ae_state *_state)
18045 : {
18046 : ae_int_t i;
18047 : ae_int_t j2;
18048 : ae_int_t n;
18049 : ae_int_t halfn1;
18050 : ae_int_t offs;
18051 : double x;
18052 : double y;
18053 : double twxm1;
18054 : double twy;
18055 : double twbasexm1;
18056 : double twbasey;
18057 : double twrowxm1;
18058 : double twrowy;
18059 : double tmpx;
18060 : double tmpy;
18061 : double v;
18062 : ae_int_t updatetw2;
18063 :
18064 :
18065 :
18066 : /*
18067 : * Multiplication by twiddle factors for complex Cooley-Tukey FFT
18068 : * with N factorized as N1*N2.
18069 : *
18070 : * Naive solution to this problem is given below:
18071 : *
18072 : * > for K:=1 to N2-1 do
18073 : * > for J:=1 to N1-1 do
18074 : * > begin
18075 : * > Idx:=K*N1+J;
18076 : * > X:=A[AOffset+2*Idx+0];
18077 : * > Y:=A[AOffset+2*Idx+1];
18078 : * > TwX:=Cos(-2*Pi()*K*J/(N1*N2));
18079 : * > TwY:=Sin(-2*Pi()*K*J/(N1*N2));
18080 : * > A[AOffset+2*Idx+0]:=X*TwX-Y*TwY;
18081 : * > A[AOffset+2*Idx+1]:=X*TwY+Y*TwX;
18082 : * > end;
18083 : *
18084 : * However, there are exist more efficient solutions.
18085 : *
18086 : * Each pass of the inner cycle corresponds to multiplication of one
18087 : * entry of A by W[k,j]=exp(-I*2*pi*k*j/N). This factor can be rewritten
18088 : * as exp(-I*2*pi*k/N)^j. So we can replace costly exponentiation by
18089 : * repeated multiplication: W[k,j+1]=W[k,j]*exp(-I*2*pi*k/N), with
18090 : * second factor being computed once in the beginning of the iteration.
18091 : *
18092 : * Also, exp(-I*2*pi*k/N) can be represented as exp(-I*2*pi/N)^k, i.e.
18093 : * we have W[K+1,1]=W[K,1]*W[1,1].
18094 : *
18095 : * In our loop we use following variables:
18096 : * * [TwBaseXM1,TwBaseY] = [cos(2*pi/N)-1, sin(2*pi/N)]
18097 : * * [TwRowXM1, TwRowY] = [cos(2*pi*I/N)-1, sin(2*pi*I/N)]
18098 : * * [TwXM1, TwY] = [cos(2*pi*I*J/N)-1, sin(2*pi*I*J/N)]
18099 : *
18100 : * Meaning of the variables:
18101 : * * [TwXM1,TwY] is current twiddle factor W[I,J]
18102 : * * [TwRowXM1, TwRowY] is W[I,1]
18103 : * * [TwBaseXM1,TwBaseY] is W[1,1]
18104 : *
18105 : * During inner loop we multiply current twiddle factor by W[I,1],
18106 : * during outer loop we update W[I,1].
18107 : *
18108 : */
18109 0 : ae_assert(ftbase_updatetw>=2, "FFTTwCalc: internal error - UpdateTw<2", _state);
18110 0 : updatetw2 = ftbase_updatetw/2;
18111 0 : halfn1 = n1/2;
18112 0 : n = n1*n2;
18113 0 : v = -2*ae_pi/n;
18114 0 : twbasexm1 = -2*ae_sqr(ae_sin(0.5*v, _state), _state);
18115 0 : twbasey = ae_sin(v, _state);
18116 0 : twrowxm1 = (double)(0);
18117 0 : twrowy = (double)(0);
18118 0 : offs = aoffset;
18119 0 : for(i=0; i<=n2-1; i++)
18120 : {
18121 :
18122 : /*
18123 : * Initialize twiddle factor for current row
18124 : */
18125 0 : twxm1 = (double)(0);
18126 0 : twy = (double)(0);
18127 :
18128 : /*
18129 : * N1-point block is separated into 2-point chunks and residual 1-point chunk
18130 : * (in case N1 is odd). Unrolled loop is several times faster.
18131 : */
18132 0 : for(j2=0; j2<=halfn1-1; j2++)
18133 : {
18134 :
18135 : /*
18136 : * Processing:
18137 : * * process first element in a chunk.
18138 : * * update twiddle factor (unconditional update)
18139 : * * process second element
18140 : * * conditional update of the twiddle factor
18141 : */
18142 0 : x = a->ptr.p_double[offs+0];
18143 0 : y = a->ptr.p_double[offs+1];
18144 0 : tmpx = x*(1+twxm1)-y*twy;
18145 0 : tmpy = x*twy+y*(1+twxm1);
18146 0 : a->ptr.p_double[offs+0] = tmpx;
18147 0 : a->ptr.p_double[offs+1] = tmpy;
18148 0 : tmpx = (1+twxm1)*twrowxm1-twy*twrowy;
18149 0 : twy = twy+(1+twxm1)*twrowy+twy*twrowxm1;
18150 0 : twxm1 = twxm1+tmpx;
18151 0 : x = a->ptr.p_double[offs+2];
18152 0 : y = a->ptr.p_double[offs+3];
18153 0 : tmpx = x*(1+twxm1)-y*twy;
18154 0 : tmpy = x*twy+y*(1+twxm1);
18155 0 : a->ptr.p_double[offs+2] = tmpx;
18156 0 : a->ptr.p_double[offs+3] = tmpy;
18157 0 : offs = offs+4;
18158 0 : if( (j2+1)%updatetw2==0&&j2<halfn1-1 )
18159 : {
18160 :
18161 : /*
18162 : * Recalculate twiddle factor
18163 : */
18164 0 : v = -2*ae_pi*i*2*(j2+1)/n;
18165 0 : twxm1 = ae_sin(0.5*v, _state);
18166 0 : twxm1 = -2*twxm1*twxm1;
18167 0 : twy = ae_sin(v, _state);
18168 : }
18169 : else
18170 : {
18171 :
18172 : /*
18173 : * Update twiddle factor
18174 : */
18175 0 : tmpx = (1+twxm1)*twrowxm1-twy*twrowy;
18176 0 : twy = twy+(1+twxm1)*twrowy+twy*twrowxm1;
18177 0 : twxm1 = twxm1+tmpx;
18178 : }
18179 : }
18180 0 : if( n1%2==1 )
18181 : {
18182 :
18183 : /*
18184 : * Handle residual chunk
18185 : */
18186 0 : x = a->ptr.p_double[offs+0];
18187 0 : y = a->ptr.p_double[offs+1];
18188 0 : tmpx = x*(1+twxm1)-y*twy;
18189 0 : tmpy = x*twy+y*(1+twxm1);
18190 0 : a->ptr.p_double[offs+0] = tmpx;
18191 0 : a->ptr.p_double[offs+1] = tmpy;
18192 0 : offs = offs+2;
18193 : }
18194 :
18195 : /*
18196 : * update TwRow: TwRow(new) = TwRow(old)*TwBase
18197 : */
18198 0 : if( i<n2-1 )
18199 : {
18200 0 : if( (i+1)%ftbase_updatetw==0 )
18201 : {
18202 0 : v = -2*ae_pi*(i+1)/n;
18203 0 : twrowxm1 = ae_sin(0.5*v, _state);
18204 0 : twrowxm1 = -2*twrowxm1*twrowxm1;
18205 0 : twrowy = ae_sin(v, _state);
18206 : }
18207 : else
18208 : {
18209 0 : tmpx = twbasexm1+twrowxm1*twbasexm1-twrowy*twbasey;
18210 0 : tmpy = twbasey+twrowxm1*twbasey+twrowy*twbasexm1;
18211 0 : twrowxm1 = twrowxm1+tmpx;
18212 0 : twrowy = twrowy+tmpy;
18213 : }
18214 : }
18215 : }
18216 0 : }
18217 :
18218 :
18219 : /*************************************************************************
18220 : Linear transpose: transpose complex matrix stored in 1-dimensional array
18221 :
18222 : -- ALGLIB --
18223 : Copyright 01.05.2009 by Bochkanov Sergey
18224 : *************************************************************************/
18225 0 : static void ftbase_internalcomplexlintranspose(/* Real */ ae_vector* a,
18226 : ae_int_t m,
18227 : ae_int_t n,
18228 : ae_int_t astart,
18229 : /* Real */ ae_vector* buf,
18230 : ae_state *_state)
18231 : {
18232 :
18233 :
18234 0 : ftbase_ffticltrec(a, astart, n, buf, 0, m, m, n, _state);
18235 0 : ae_v_move(&a->ptr.p_double[astart], 1, &buf->ptr.p_double[0], 1, ae_v_len(astart,astart+2*m*n-1));
18236 0 : }
18237 :
18238 :
18239 : /*************************************************************************
18240 : Recurrent subroutine for a InternalComplexLinTranspose
18241 :
18242 : Write A^T to B, where:
18243 : * A is m*n complex matrix stored in array A as pairs of real/image values,
18244 : beginning from AStart position, with AStride stride
18245 : * B is n*m complex matrix stored in array B as pairs of real/image values,
18246 : beginning from BStart position, with BStride stride
18247 : stride is measured in complex numbers, i.e. in real/image pairs.
18248 :
18249 : -- ALGLIB --
18250 : Copyright 01.05.2009 by Bochkanov Sergey
18251 : *************************************************************************/
18252 0 : static void ftbase_ffticltrec(/* Real */ ae_vector* a,
18253 : ae_int_t astart,
18254 : ae_int_t astride,
18255 : /* Real */ ae_vector* b,
18256 : ae_int_t bstart,
18257 : ae_int_t bstride,
18258 : ae_int_t m,
18259 : ae_int_t n,
18260 : ae_state *_state)
18261 : {
18262 : ae_int_t i;
18263 : ae_int_t j;
18264 : ae_int_t idx1;
18265 : ae_int_t idx2;
18266 : ae_int_t m2;
18267 : ae_int_t m1;
18268 : ae_int_t n1;
18269 :
18270 :
18271 0 : if( m==0||n==0 )
18272 : {
18273 0 : return;
18274 : }
18275 0 : if( ae_maxint(m, n, _state)<=8 )
18276 : {
18277 0 : m2 = 2*bstride;
18278 0 : for(i=0; i<=m-1; i++)
18279 : {
18280 0 : idx1 = bstart+2*i;
18281 0 : idx2 = astart+2*i*astride;
18282 0 : for(j=0; j<=n-1; j++)
18283 : {
18284 0 : b->ptr.p_double[idx1+0] = a->ptr.p_double[idx2+0];
18285 0 : b->ptr.p_double[idx1+1] = a->ptr.p_double[idx2+1];
18286 0 : idx1 = idx1+m2;
18287 0 : idx2 = idx2+2;
18288 : }
18289 : }
18290 0 : return;
18291 : }
18292 0 : if( n>m )
18293 : {
18294 :
18295 : /*
18296 : * New partition:
18297 : *
18298 : * "A^T -> B" becomes "(A1 A2)^T -> ( B1 )
18299 : * ( B2 )
18300 : */
18301 0 : n1 = n/2;
18302 0 : if( n-n1>=8&&n1%8!=0 )
18303 : {
18304 0 : n1 = n1+(8-n1%8);
18305 : }
18306 0 : ae_assert(n-n1>0, "Assertion failed", _state);
18307 0 : ftbase_ffticltrec(a, astart, astride, b, bstart, bstride, m, n1, _state);
18308 0 : ftbase_ffticltrec(a, astart+2*n1, astride, b, bstart+2*n1*bstride, bstride, m, n-n1, _state);
18309 : }
18310 : else
18311 : {
18312 :
18313 : /*
18314 : * New partition:
18315 : *
18316 : * "A^T -> B" becomes "( A1 )^T -> ( B1 B2 )
18317 : * ( A2 )
18318 : */
18319 0 : m1 = m/2;
18320 0 : if( m-m1>=8&&m1%8!=0 )
18321 : {
18322 0 : m1 = m1+(8-m1%8);
18323 : }
18324 0 : ae_assert(m-m1>0, "Assertion failed", _state);
18325 0 : ftbase_ffticltrec(a, astart, astride, b, bstart, bstride, m1, n, _state);
18326 0 : ftbase_ffticltrec(a, astart+2*m1*astride, astride, b, bstart+2*m1, bstride, m-m1, n, _state);
18327 : }
18328 : }
18329 :
18330 :
18331 : /*************************************************************************
18332 : Recurrent subroutine for a InternalRealLinTranspose
18333 :
18334 :
18335 : -- ALGLIB --
18336 : Copyright 01.05.2009 by Bochkanov Sergey
18337 : *************************************************************************/
18338 0 : static void ftbase_fftirltrec(/* Real */ ae_vector* a,
18339 : ae_int_t astart,
18340 : ae_int_t astride,
18341 : /* Real */ ae_vector* b,
18342 : ae_int_t bstart,
18343 : ae_int_t bstride,
18344 : ae_int_t m,
18345 : ae_int_t n,
18346 : ae_state *_state)
18347 : {
18348 : ae_int_t i;
18349 : ae_int_t j;
18350 : ae_int_t idx1;
18351 : ae_int_t idx2;
18352 : ae_int_t m1;
18353 : ae_int_t n1;
18354 :
18355 :
18356 0 : if( m==0||n==0 )
18357 : {
18358 0 : return;
18359 : }
18360 0 : if( ae_maxint(m, n, _state)<=8 )
18361 : {
18362 0 : for(i=0; i<=m-1; i++)
18363 : {
18364 0 : idx1 = bstart+i;
18365 0 : idx2 = astart+i*astride;
18366 0 : for(j=0; j<=n-1; j++)
18367 : {
18368 0 : b->ptr.p_double[idx1] = a->ptr.p_double[idx2];
18369 0 : idx1 = idx1+bstride;
18370 0 : idx2 = idx2+1;
18371 : }
18372 : }
18373 0 : return;
18374 : }
18375 0 : if( n>m )
18376 : {
18377 :
18378 : /*
18379 : * New partition:
18380 : *
18381 : * "A^T -> B" becomes "(A1 A2)^T -> ( B1 )
18382 : * ( B2 )
18383 : */
18384 0 : n1 = n/2;
18385 0 : if( n-n1>=8&&n1%8!=0 )
18386 : {
18387 0 : n1 = n1+(8-n1%8);
18388 : }
18389 0 : ae_assert(n-n1>0, "Assertion failed", _state);
18390 0 : ftbase_fftirltrec(a, astart, astride, b, bstart, bstride, m, n1, _state);
18391 0 : ftbase_fftirltrec(a, astart+n1, astride, b, bstart+n1*bstride, bstride, m, n-n1, _state);
18392 : }
18393 : else
18394 : {
18395 :
18396 : /*
18397 : * New partition:
18398 : *
18399 : * "A^T -> B" becomes "( A1 )^T -> ( B1 B2 )
18400 : * ( A2 )
18401 : */
18402 0 : m1 = m/2;
18403 0 : if( m-m1>=8&&m1%8!=0 )
18404 : {
18405 0 : m1 = m1+(8-m1%8);
18406 : }
18407 0 : ae_assert(m-m1>0, "Assertion failed", _state);
18408 0 : ftbase_fftirltrec(a, astart, astride, b, bstart, bstride, m1, n, _state);
18409 0 : ftbase_fftirltrec(a, astart+m1*astride, astride, b, bstart+m1, bstride, m-m1, n, _state);
18410 : }
18411 : }
18412 :
18413 :
18414 : /*************************************************************************
18415 : recurrent subroutine for FFTFindSmoothRec
18416 :
18417 : -- ALGLIB --
18418 : Copyright 01.05.2009 by Bochkanov Sergey
18419 : *************************************************************************/
18420 0 : static void ftbase_ftbasefindsmoothrec(ae_int_t n,
18421 : ae_int_t seed,
18422 : ae_int_t leastfactor,
18423 : ae_int_t* best,
18424 : ae_state *_state)
18425 : {
18426 :
18427 :
18428 0 : ae_assert(ftbase_ftbasemaxsmoothfactor<=5, "FTBaseFindSmoothRec: internal error!", _state);
18429 0 : if( seed>=n )
18430 : {
18431 0 : *best = ae_minint(*best, seed, _state);
18432 0 : return;
18433 : }
18434 0 : if( leastfactor<=2 )
18435 : {
18436 0 : ftbase_ftbasefindsmoothrec(n, seed*2, 2, best, _state);
18437 : }
18438 0 : if( leastfactor<=3 )
18439 : {
18440 0 : ftbase_ftbasefindsmoothrec(n, seed*3, 3, best, _state);
18441 : }
18442 0 : if( leastfactor<=5 )
18443 : {
18444 0 : ftbase_ftbasefindsmoothrec(n, seed*5, 5, best, _state);
18445 : }
18446 : }
18447 :
18448 :
18449 0 : void _fasttransformplan_init(void* _p, ae_state *_state, ae_bool make_automatic)
18450 : {
18451 0 : fasttransformplan *p = (fasttransformplan*)_p;
18452 0 : ae_touch_ptr((void*)p);
18453 0 : ae_matrix_init(&p->entries, 0, 0, DT_INT, _state, make_automatic);
18454 0 : ae_vector_init(&p->buffer, 0, DT_REAL, _state, make_automatic);
18455 0 : ae_vector_init(&p->precr, 0, DT_REAL, _state, make_automatic);
18456 0 : ae_vector_init(&p->preci, 0, DT_REAL, _state, make_automatic);
18457 0 : ae_shared_pool_init(&p->bluesteinpool, _state, make_automatic);
18458 0 : }
18459 :
18460 :
18461 0 : void _fasttransformplan_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
18462 : {
18463 0 : fasttransformplan *dst = (fasttransformplan*)_dst;
18464 0 : fasttransformplan *src = (fasttransformplan*)_src;
18465 0 : ae_matrix_init_copy(&dst->entries, &src->entries, _state, make_automatic);
18466 0 : ae_vector_init_copy(&dst->buffer, &src->buffer, _state, make_automatic);
18467 0 : ae_vector_init_copy(&dst->precr, &src->precr, _state, make_automatic);
18468 0 : ae_vector_init_copy(&dst->preci, &src->preci, _state, make_automatic);
18469 0 : ae_shared_pool_init_copy(&dst->bluesteinpool, &src->bluesteinpool, _state, make_automatic);
18470 0 : }
18471 :
18472 :
18473 0 : void _fasttransformplan_clear(void* _p)
18474 : {
18475 0 : fasttransformplan *p = (fasttransformplan*)_p;
18476 0 : ae_touch_ptr((void*)p);
18477 0 : ae_matrix_clear(&p->entries);
18478 0 : ae_vector_clear(&p->buffer);
18479 0 : ae_vector_clear(&p->precr);
18480 0 : ae_vector_clear(&p->preci);
18481 0 : ae_shared_pool_clear(&p->bluesteinpool);
18482 0 : }
18483 :
18484 :
18485 0 : void _fasttransformplan_destroy(void* _p)
18486 : {
18487 0 : fasttransformplan *p = (fasttransformplan*)_p;
18488 0 : ae_touch_ptr((void*)p);
18489 0 : ae_matrix_destroy(&p->entries);
18490 0 : ae_vector_destroy(&p->buffer);
18491 0 : ae_vector_destroy(&p->precr);
18492 0 : ae_vector_destroy(&p->preci);
18493 0 : ae_shared_pool_destroy(&p->bluesteinpool);
18494 0 : }
18495 :
18496 :
18497 : #endif
18498 : #if defined(AE_COMPILE_NEARUNITYUNIT) || !defined(AE_PARTIAL_BUILD)
18499 :
18500 :
18501 0 : double nulog1p(double x, ae_state *_state)
18502 : {
18503 : double z;
18504 : double lp;
18505 : double lq;
18506 : double result;
18507 :
18508 :
18509 0 : z = 1.0+x;
18510 0 : if( ae_fp_less(z,0.70710678118654752440)||ae_fp_greater(z,1.41421356237309504880) )
18511 : {
18512 0 : result = ae_log(z, _state);
18513 0 : return result;
18514 : }
18515 0 : z = x*x;
18516 0 : lp = 4.5270000862445199635215E-5;
18517 0 : lp = lp*x+4.9854102823193375972212E-1;
18518 0 : lp = lp*x+6.5787325942061044846969E0;
18519 0 : lp = lp*x+2.9911919328553073277375E1;
18520 0 : lp = lp*x+6.0949667980987787057556E1;
18521 0 : lp = lp*x+5.7112963590585538103336E1;
18522 0 : lp = lp*x+2.0039553499201281259648E1;
18523 0 : lq = 1.0000000000000000000000E0;
18524 0 : lq = lq*x+1.5062909083469192043167E1;
18525 0 : lq = lq*x+8.3047565967967209469434E1;
18526 0 : lq = lq*x+2.2176239823732856465394E2;
18527 0 : lq = lq*x+3.0909872225312059774938E2;
18528 0 : lq = lq*x+2.1642788614495947685003E2;
18529 0 : lq = lq*x+6.0118660497603843919306E1;
18530 0 : z = -0.5*z+x*(z*lp/lq);
18531 0 : result = x+z;
18532 0 : return result;
18533 : }
18534 :
18535 :
18536 0 : double nuexpm1(double x, ae_state *_state)
18537 : {
18538 : double r;
18539 : double xx;
18540 : double ep;
18541 : double eq;
18542 : double result;
18543 :
18544 :
18545 0 : if( ae_fp_less(x,-0.5)||ae_fp_greater(x,0.5) )
18546 : {
18547 0 : result = ae_exp(x, _state)-1.0;
18548 0 : return result;
18549 : }
18550 0 : xx = x*x;
18551 0 : ep = 1.2617719307481059087798E-4;
18552 0 : ep = ep*xx+3.0299440770744196129956E-2;
18553 0 : ep = ep*xx+9.9999999999999999991025E-1;
18554 0 : eq = 3.0019850513866445504159E-6;
18555 0 : eq = eq*xx+2.5244834034968410419224E-3;
18556 0 : eq = eq*xx+2.2726554820815502876593E-1;
18557 0 : eq = eq*xx+2.0000000000000000000897E0;
18558 0 : r = x*ep;
18559 0 : r = r/(eq-r);
18560 0 : result = r+r;
18561 0 : return result;
18562 : }
18563 :
18564 :
18565 0 : double nucosm1(double x, ae_state *_state)
18566 : {
18567 : double xx;
18568 : double c;
18569 : double result;
18570 :
18571 :
18572 0 : if( ae_fp_less(x,-0.25*ae_pi)||ae_fp_greater(x,0.25*ae_pi) )
18573 : {
18574 0 : result = ae_cos(x, _state)-1;
18575 0 : return result;
18576 : }
18577 0 : xx = x*x;
18578 0 : c = 4.7377507964246204691685E-14;
18579 0 : c = c*xx-1.1470284843425359765671E-11;
18580 0 : c = c*xx+2.0876754287081521758361E-9;
18581 0 : c = c*xx-2.7557319214999787979814E-7;
18582 0 : c = c*xx+2.4801587301570552304991E-5;
18583 0 : c = c*xx-1.3888888888888872993737E-3;
18584 0 : c = c*xx+4.1666666666666666609054E-2;
18585 0 : result = -0.5*xx+xx*xx*c;
18586 0 : return result;
18587 : }
18588 :
18589 :
18590 : #endif
18591 : #if defined(AE_COMPILE_ALGLIBBASICS) || !defined(AE_PARTIAL_BUILD)
18592 :
18593 :
18594 : #endif
18595 :
18596 : }
18597 :
|
