1 #include "blas_extended.h"
2 #include "blas_extended_private.h"
3 #include "blas_extended_test.h"
4
BLAS_strsv_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,float * alpha,int alpha_flag,float * T,int lda,float * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)5 void BLAS_strsv_testgen(int norm, enum blas_order_type order,
6 enum blas_uplo_type uplo, enum blas_trans_type trans,
7 enum blas_diag_type diag, int n, float *alpha,
8 int alpha_flag, float *T, int lda, float *x,
9 int *seed, double *head_r_true, double *tail_r_true,
10 int row, enum blas_prec_type prec)
11
12 /*
13 * Purpose
14 * =======
15 *
16 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
17 *
18 * Arguments
19 * =========
20 *
21 * norm (input) blas_norm_type
22 *
23 * order (input) blas_order_type
24 * Order of T; row or column major
25 *
26 * uplo (input) blas_uplo_type
27 * Whether T is upper or lower
28 *
29 * trans (input) blas_trans_type
30 * No trans, trans, conj trans
31 *
32 * diag (input) blas_diag_type
33 * non unit, unit
34 *
35 * n (input) int
36 * Dimension of AP and the length of vector x
37 *
38 * alpha (input/output) float*
39 * If alpha_flag = 1, alpha is input.
40 * If alpha_flag = 0, alpha is output.
41 *
42 * alpha_flag (input) int
43 * = 0 : alpha is free, and is output.
44 * = 1 : alpha is fixed on input.
45 *
46 * T (output) float*
47 *
48 * x (input/output) float*
49 *
50 * seed (input/output) int
51 *
52 * head_r_true (output) double*
53 * The leading part of the truth in double-double.
54 *
55 * tail_r_true (output) double*
56 * The trailing part of the truth in double-double.
57 *
58 * row (input) int
59 * The true row being generated
60 *
61 * prec (input) blas_prec_type
62 * single, double, or extra precision
63 *
64 */
65 {
66 int start;
67 int length;
68 int i, j;
69 float alpha_i;
70 float minus_one;
71 float Tii;
72 float *temp;
73 float *xtemp2;
74
75 temp = (float *) blas_malloc(n * sizeof(float));
76 if (n > 0 && temp == NULL) {
77 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
78 }
79
80 xtemp2 = NULL;
81 if (prec != blas_prec_extra) {
82 xtemp2 = (float *) blas_malloc(n * sizeof(float));
83 if (n > 0 && xtemp2 == NULL) {
84 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
85 }
86 }
87
88 minus_one = -1.0;
89
90 /* if alpha_flag=0, gives a random value to alpha */
91 if (alpha_flag == 0) {
92 alpha_i = xrand(seed);
93 *alpha = alpha_i;
94 alpha_flag = 1;
95 }
96
97 for (i = 0; i < 4 * n * n; i++) {
98 T[i] = 0.0;
99 }
100
101 for (i = 0; i < n; i++) {
102
103 if (i != row) {
104 if (diag == blas_non_unit_diag) {
105 Tii = xrand(seed);
106 T[i * lda + i] = Tii;
107 } else {
108 Tii = 1.0;
109 T[i * lda + i] = Tii;
110 }
111
112 x[i] = xrand(seed);
113
114 switch (prec) {
115 case blas_prec_single:
116 {
117 float multemp;
118 float divtemp;
119
120 multemp = x[i] * *alpha;
121 divtemp = multemp / Tii;
122 head_r_true[i] = divtemp;
123 tail_r_true[i] = 0.0;
124 xtemp2[i] = divtemp;
125 break;
126 }
127 case blas_prec_double:
128 case blas_prec_indigenous:
129 {
130 double multemp;
131 double divtemp;
132
133 multemp = (double) x[i] * *alpha;
134 divtemp = (double) multemp / Tii;
135 head_r_true[i] = divtemp;
136 tail_r_true[i] = 0.0;
137 break;
138 }
139 case blas_prec_extra:
140 {
141 double head_multemp, tail_multemp;
142 double head_divtemp, tail_divtemp;
143
144 head_multemp = (double) x[i] * *alpha;
145 tail_multemp = 0.0;
146 {
147 double dt = (double) Tii;
148 {
149 /* Compute double-double = double-double / double,
150 using a Newton iteration scheme. */
151 double b1, b2, con, e, t1, t2, t11, t21, t12, t22;
152
153 /* Compute a DP approximation to the quotient. */
154 t1 = head_multemp / dt;
155
156 /* Split t1 and b into two parts with at most 26 bits each,
157 using the Dekker-Veltkamp method. */
158 con = t1 * split;
159 t11 = con - (con - t1);
160 t21 = t1 - t11;
161 con = dt * split;
162 b1 = con - (con - dt);
163 b2 = dt - b1;
164
165 /* Compute t1 * b using Dekker method. */
166 t12 = t1 * dt;
167 t22 = (((t11 * b1 - t12) + t11 * b2) + t21 * b1) + t21 * b2;
168
169 /* Compute dda - (t12, t22) using Knuth trick. */
170 t11 = head_multemp - t12;
171 e = t11 - head_multemp;
172 t21 =
173 ((-t12 - e) + (head_multemp - (t11 - e))) + tail_multemp -
174 t22;
175
176 /* Compute high-order word of (t11, t21) and divide by b. */
177 t2 = (t11 + t21) / dt;
178
179 /* The result is t1 + t2, after normalization. */
180 head_divtemp = t1 + t2;
181 tail_divtemp = t2 - (head_divtemp - t1);
182 }
183 }
184 head_r_true[i] = head_divtemp;
185 tail_r_true[i] = tail_divtemp;
186 break;
187 }
188 } /* case */
189 } /* if */
190 } /* for */
191
192 for (j = 0; j < n; j++) {
193 temp[j] = 0.0;
194 }
195
196 T[row * lda + row] = 1.0;
197
198 if ((uplo == blas_lower && trans == blas_no_trans) ||
199 (uplo == blas_upper && trans != blas_no_trans)) {
200 length = row;
201 start = 0;
202 } else {
203 length = n - row - 1;
204 start = row + 1;
205 }
206
207 if (length != 0) {
208
209
210 switch (prec) {
211 case blas_prec_single:
212 BLAS_sdot_testgen(length, 0, length, norm,
213 blas_no_conj, &minus_one, 1, alpha, 1,
214 &xtemp2[start], temp, seed, &x[row],
215 &head_r_true[row], &tail_r_true[row]);
216 break;
217 case blas_prec_double:
218 case blas_prec_indigenous:
219 case blas_prec_extra:
220 BLAS_sdot_x_testgen(length, 0, length, norm,
221 blas_no_conj, &minus_one, 1, alpha, 1,
222 &head_r_true[start], &tail_r_true[start], temp,
223 seed, &x[row], &head_r_true[row],
224 &tail_r_true[row]);
225 break;
226 }
227 strsv_commit(order, uplo, trans, length, T, lda, temp, row);
228 } else {
229 x[row] = xrand(seed);
230
231 switch (prec) {
232 case blas_prec_single:
233 {
234 float multemp;
235
236 multemp = x[row] * *alpha;
237 head_r_true[row] = multemp;
238 tail_r_true[row] = 0.0;
239 break;
240 }
241 case blas_prec_indigenous:
242 case blas_prec_double:
243 {
244 double multemp;
245
246 multemp = (double) x[row] * *alpha;
247 head_r_true[row] = multemp;
248 tail_r_true[row] = 0.0;
249 break;
250 }
251 case blas_prec_extra:
252 {
253 double head_multemp, tail_multemp;
254
255 head_multemp = (double) x[row] * *alpha;
256 tail_multemp = 0.0;
257 head_r_true[row] = head_multemp;
258 tail_r_true[row] = tail_multemp;
259 break;
260 }
261 }
262 }
263
264 blas_free(temp);
265
266 if (prec != blas_prec_extra)
267 blas_free(xtemp2);
268 }
BLAS_dtrsv_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,double * alpha,int alpha_flag,double * T,int lda,double * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)269 void BLAS_dtrsv_testgen(int norm, enum blas_order_type order,
270 enum blas_uplo_type uplo, enum blas_trans_type trans,
271 enum blas_diag_type diag, int n, double *alpha,
272 int alpha_flag, double *T, int lda, double *x,
273 int *seed, double *head_r_true, double *tail_r_true,
274 int row, enum blas_prec_type prec)
275
276 /*
277 * Purpose
278 * =======
279 *
280 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
281 *
282 * Arguments
283 * =========
284 *
285 * norm (input) blas_norm_type
286 *
287 * order (input) blas_order_type
288 * Order of T; row or column major
289 *
290 * uplo (input) blas_uplo_type
291 * Whether T is upper or lower
292 *
293 * trans (input) blas_trans_type
294 * No trans, trans, conj trans
295 *
296 * diag (input) blas_diag_type
297 * non unit, unit
298 *
299 * n (input) int
300 * Dimension of AP and the length of vector x
301 *
302 * alpha (input/output) double*
303 * If alpha_flag = 1, alpha is input.
304 * If alpha_flag = 0, alpha is output.
305 *
306 * alpha_flag (input) int
307 * = 0 : alpha is free, and is output.
308 * = 1 : alpha is fixed on input.
309 *
310 * T (output) double*
311 *
312 * x (input/output) double*
313 *
314 * seed (input/output) int
315 *
316 * head_r_true (output) double*
317 * The leading part of the truth in double-double.
318 *
319 * tail_r_true (output) double*
320 * The trailing part of the truth in double-double.
321 *
322 * row (input) int
323 * The true row being generated
324 *
325 * prec (input) blas_prec_type
326 * single, double, or extra precision
327 *
328 */
329 {
330 int start;
331 int length;
332 int i, j;
333 float alpha_i;
334 double minus_one;
335 double Tii;
336 double *temp;
337 double *xtemp2;
338
339 temp = (double *) blas_malloc(n * sizeof(double));
340 if (n > 0 && temp == NULL) {
341 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
342 }
343
344 xtemp2 = NULL;
345 if (prec != blas_prec_extra) {
346 xtemp2 = (double *) blas_malloc(n * sizeof(double));
347 if (n > 0 && xtemp2 == NULL) {
348 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
349 }
350 }
351
352 minus_one = -1.0;
353
354 /* if alpha_flag=0, gives a random value to alpha */
355 if (alpha_flag == 0) {
356 alpha_i = xrand(seed);
357 *alpha = alpha_i;
358 alpha_flag = 1;
359 }
360
361 for (i = 0; i < 4 * n * n; i++) {
362 T[i] = 0.0;
363 }
364
365 for (i = 0; i < n; i++) {
366
367 if (i != row) {
368 if (diag == blas_non_unit_diag) {
369 Tii = xrand(seed);
370 T[i * lda + i] = Tii;
371 } else {
372 Tii = 1.0;
373 T[i * lda + i] = Tii;
374 }
375
376 x[i] = xrand(seed);
377
378 switch (prec) {
379 case blas_prec_single:
380 {
381 double multemp;
382 double divtemp;
383
384 multemp = x[i] * *alpha;
385 divtemp = multemp / Tii;
386 head_r_true[i] = divtemp;
387 tail_r_true[i] = 0.0;
388 xtemp2[i] = divtemp;
389 break;
390 }
391 case blas_prec_double:
392 case blas_prec_indigenous:
393 {
394 double multemp;
395 double divtemp;
396
397 multemp = x[i] * *alpha;
398 divtemp = multemp / Tii;
399 head_r_true[i] = divtemp;
400 tail_r_true[i] = 0.0;
401 xtemp2[i] = divtemp;
402 break;
403 }
404 case blas_prec_extra:
405 {
406 double head_multemp, tail_multemp;
407 double head_divtemp, tail_divtemp;
408
409 {
410 /* Compute double_double = double * double. */
411 double a1, a2, b1, b2, con;
412
413 con = x[i] * split;
414 a1 = con - x[i];
415 a1 = con - a1;
416 a2 = x[i] - a1;
417 con = *alpha * split;
418 b1 = con - *alpha;
419 b1 = con - b1;
420 b2 = *alpha - b1;
421
422 head_multemp = x[i] * *alpha;
423 tail_multemp =
424 (((a1 * b1 - head_multemp) + a1 * b2) + a2 * b1) + a2 * b2;
425 }
426 {
427 /* Compute double-double = double-double / double,
428 using a Newton iteration scheme. */
429 double b1, b2, con, e, t1, t2, t11, t21, t12, t22;
430
431 /* Compute a DP approximation to the quotient. */
432 t1 = head_multemp / Tii;
433
434 /* Split t1 and b into two parts with at most 26 bits each,
435 using the Dekker-Veltkamp method. */
436 con = t1 * split;
437 t11 = con - (con - t1);
438 t21 = t1 - t11;
439 con = Tii * split;
440 b1 = con - (con - Tii);
441 b2 = Tii - b1;
442
443 /* Compute t1 * b using Dekker method. */
444 t12 = t1 * Tii;
445 t22 = (((t11 * b1 - t12) + t11 * b2) + t21 * b1) + t21 * b2;
446
447 /* Compute dda - (t12, t22) using Knuth trick. */
448 t11 = head_multemp - t12;
449 e = t11 - head_multemp;
450 t21 =
451 ((-t12 - e) + (head_multemp - (t11 - e))) + tail_multemp - t22;
452
453 /* Compute high-order word of (t11, t21) and divide by b. */
454 t2 = (t11 + t21) / Tii;
455
456 /* The result is t1 + t2, after normalization. */
457 head_divtemp = t1 + t2;
458 tail_divtemp = t2 - (head_divtemp - t1);
459 }
460 head_r_true[i] = head_divtemp;
461 tail_r_true[i] = tail_divtemp;
462 break;
463 }
464 } /* case */
465 } /* if */
466 } /* for */
467
468 for (j = 0; j < n; j++) {
469 temp[j] = 0.0;
470 }
471
472 T[row * lda + row] = 1.0;
473
474 if ((uplo == blas_lower && trans == blas_no_trans) ||
475 (uplo == blas_upper && trans != blas_no_trans)) {
476 length = row;
477 start = 0;
478 } else {
479 length = n - row - 1;
480 start = row + 1;
481 }
482
483 if (length != 0) {
484
485
486 switch (prec) {
487 case blas_prec_single:
488 BLAS_ddot_testgen(length, 0, length, norm,
489 blas_no_conj, &minus_one, 1, alpha, 1,
490 &xtemp2[start], temp, seed, &x[row],
491 &head_r_true[row], &tail_r_true[row]);
492 break;
493 case blas_prec_double:
494 case blas_prec_indigenous:
495 case blas_prec_extra:
496 BLAS_ddot_x_testgen(length, 0, length, norm,
497 blas_no_conj, &minus_one, 1, alpha, 1,
498 &head_r_true[start], &tail_r_true[start], temp,
499 seed, &x[row], &head_r_true[row],
500 &tail_r_true[row]);
501 break;
502 }
503 dtrsv_commit(order, uplo, trans, length, T, lda, temp, row);
504 } else {
505 x[row] = xrand(seed);
506
507 switch (prec) {
508 case blas_prec_single:
509 {
510 double multemp;
511
512 multemp = x[row] * *alpha;
513 head_r_true[row] = multemp;
514 tail_r_true[row] = 0.0;
515 break;
516 }
517 case blas_prec_indigenous:
518 case blas_prec_double:
519 {
520 double multemp;
521
522 multemp = x[row] * *alpha;
523 head_r_true[row] = multemp;
524 tail_r_true[row] = 0.0;
525 break;
526 }
527 case blas_prec_extra:
528 {
529 double head_multemp, tail_multemp;
530
531 {
532 /* Compute double_double = double * double. */
533 double a1, a2, b1, b2, con;
534
535 con = x[row] * split;
536 a1 = con - x[row];
537 a1 = con - a1;
538 a2 = x[row] - a1;
539 con = *alpha * split;
540 b1 = con - *alpha;
541 b1 = con - b1;
542 b2 = *alpha - b1;
543
544 head_multemp = x[row] * *alpha;
545 tail_multemp =
546 (((a1 * b1 - head_multemp) + a1 * b2) + a2 * b1) + a2 * b2;
547 }
548 head_r_true[row] = head_multemp;
549 tail_r_true[row] = tail_multemp;
550 break;
551 }
552 }
553 }
554
555 blas_free(temp);
556
557 if (prec != blas_prec_extra)
558 blas_free(xtemp2);
559 }
BLAS_dtrsv_s_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,double * alpha,int alpha_flag,float * T,int lda,double * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)560 void BLAS_dtrsv_s_testgen(int norm, enum blas_order_type order,
561 enum blas_uplo_type uplo,
562 enum blas_trans_type trans,
563 enum blas_diag_type diag, int n, double *alpha,
564 int alpha_flag, float *T, int lda, double *x,
565 int *seed, double *head_r_true, double *tail_r_true,
566 int row, enum blas_prec_type prec)
567
568 /*
569 * Purpose
570 * =======
571 *
572 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
573 *
574 * Arguments
575 * =========
576 *
577 * norm (input) blas_norm_type
578 *
579 * order (input) blas_order_type
580 * Order of T; row or column major
581 *
582 * uplo (input) blas_uplo_type
583 * Whether T is upper or lower
584 *
585 * trans (input) blas_trans_type
586 * No trans, trans, conj trans
587 *
588 * diag (input) blas_diag_type
589 * non unit, unit
590 *
591 * n (input) int
592 * Dimension of AP and the length of vector x
593 *
594 * alpha (input/output) double*
595 * If alpha_flag = 1, alpha is input.
596 * If alpha_flag = 0, alpha is output.
597 *
598 * alpha_flag (input) int
599 * = 0 : alpha is free, and is output.
600 * = 1 : alpha is fixed on input.
601 *
602 * T (output) float*
603 *
604 * x (input/output) double*
605 *
606 * seed (input/output) int
607 *
608 * head_r_true (output) double*
609 * The leading part of the truth in double-double.
610 *
611 * tail_r_true (output) double*
612 * The trailing part of the truth in double-double.
613 *
614 * row (input) int
615 * The true row being generated
616 *
617 * prec (input) blas_prec_type
618 * single, double, or extra precision
619 *
620 */
621 {
622 int start;
623 int length;
624 int i, j;
625 float alpha_i;
626 double minus_one;
627 float Tii;
628 float *temp;
629 double *xtemp2;
630
631 temp = (float *) blas_malloc(n * sizeof(float));
632 if (n > 0 && temp == NULL) {
633 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
634 }
635
636 xtemp2 = NULL;
637 if (prec != blas_prec_extra) {
638 xtemp2 = (double *) blas_malloc(n * sizeof(double));
639 if (n > 0 && xtemp2 == NULL) {
640 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
641 }
642 }
643
644 minus_one = -1.0;
645
646 /* if alpha_flag=0, gives a random value to alpha */
647 if (alpha_flag == 0) {
648 alpha_i = xrand(seed);
649 *alpha = alpha_i;
650 alpha_flag = 1;
651 }
652
653 for (i = 0; i < 4 * n * n; i++) {
654 T[i] = 0.0;
655 }
656
657 for (i = 0; i < n; i++) {
658
659 if (i != row) {
660 if (diag == blas_non_unit_diag) {
661 Tii = xrand(seed);
662 T[i * lda + i] = Tii;
663 } else {
664 Tii = 1.0;
665 T[i * lda + i] = Tii;
666 }
667
668 x[i] = xrand(seed);
669
670 switch (prec) {
671 case blas_prec_single:
672 {
673 double multemp;
674 double divtemp;
675
676 multemp = x[i] * *alpha;
677 divtemp = multemp / Tii;
678 head_r_true[i] = divtemp;
679 tail_r_true[i] = 0.0;
680 xtemp2[i] = divtemp;
681 break;
682 }
683 case blas_prec_double:
684 case blas_prec_indigenous:
685 {
686 double multemp;
687 double divtemp;
688
689 multemp = x[i] * *alpha;
690 divtemp = multemp / Tii;
691 head_r_true[i] = divtemp;
692 tail_r_true[i] = 0.0;
693 xtemp2[i] = divtemp;
694 break;
695 }
696 case blas_prec_extra:
697 {
698 double head_multemp, tail_multemp;
699 double head_divtemp, tail_divtemp;
700
701 {
702 /* Compute double_double = double * double. */
703 double a1, a2, b1, b2, con;
704
705 con = x[i] * split;
706 a1 = con - x[i];
707 a1 = con - a1;
708 a2 = x[i] - a1;
709 con = *alpha * split;
710 b1 = con - *alpha;
711 b1 = con - b1;
712 b2 = *alpha - b1;
713
714 head_multemp = x[i] * *alpha;
715 tail_multemp =
716 (((a1 * b1 - head_multemp) + a1 * b2) + a2 * b1) + a2 * b2;
717 }
718 {
719 double dt = (double) Tii;
720 {
721 /* Compute double-double = double-double / double,
722 using a Newton iteration scheme. */
723 double b1, b2, con, e, t1, t2, t11, t21, t12, t22;
724
725 /* Compute a DP approximation to the quotient. */
726 t1 = head_multemp / dt;
727
728 /* Split t1 and b into two parts with at most 26 bits each,
729 using the Dekker-Veltkamp method. */
730 con = t1 * split;
731 t11 = con - (con - t1);
732 t21 = t1 - t11;
733 con = dt * split;
734 b1 = con - (con - dt);
735 b2 = dt - b1;
736
737 /* Compute t1 * b using Dekker method. */
738 t12 = t1 * dt;
739 t22 = (((t11 * b1 - t12) + t11 * b2) + t21 * b1) + t21 * b2;
740
741 /* Compute dda - (t12, t22) using Knuth trick. */
742 t11 = head_multemp - t12;
743 e = t11 - head_multemp;
744 t21 =
745 ((-t12 - e) + (head_multemp - (t11 - e))) + tail_multemp -
746 t22;
747
748 /* Compute high-order word of (t11, t21) and divide by b. */
749 t2 = (t11 + t21) / dt;
750
751 /* The result is t1 + t2, after normalization. */
752 head_divtemp = t1 + t2;
753 tail_divtemp = t2 - (head_divtemp - t1);
754 }
755 }
756 head_r_true[i] = head_divtemp;
757 tail_r_true[i] = tail_divtemp;
758 break;
759 }
760 } /* case */
761 } /* if */
762 } /* for */
763
764 for (j = 0; j < n; j++) {
765 temp[j] = 0.0;
766 }
767
768 T[row * lda + row] = 1.0;
769
770 if ((uplo == blas_lower && trans == blas_no_trans) ||
771 (uplo == blas_upper && trans != blas_no_trans)) {
772 length = row;
773 start = 0;
774 } else {
775 length = n - row - 1;
776 start = row + 1;
777 }
778
779 if (length != 0) {
780
781 switch (prec) {
782 case blas_prec_single:
783 case blas_prec_double:
784 case blas_prec_indigenous:
785 /*BLAS_ddot_s_x_testgen(length, 0, length, norm,
786 blas_no_conj, &minus_one, 1, alpha, 1,
787 &head_r_true[start], &tail_r_true[start], temp,
788 seed, &x[row], &head_r_true[row], &tail_r_true[row]);
789 break; */
790 case blas_prec_extra:
791 BLAS_ddot_s_x_testgen(length, 0, length, norm,
792 blas_no_conj, &minus_one, 1, alpha, 1,
793 &head_r_true[start], &tail_r_true[start], temp,
794 seed, &x[row], &head_r_true[row],
795 &tail_r_true[row]);
796 break;
797 }
798 strsv_commit(order, uplo, trans, length, T, lda, temp, row);
799 } else {
800 x[row] = xrand(seed);
801
802 switch (prec) {
803 case blas_prec_single:
804 {
805 double multemp;
806
807 multemp = x[row] * *alpha;
808 head_r_true[row] = multemp;
809 tail_r_true[row] = 0.0;
810 break;
811 }
812 case blas_prec_indigenous:
813 case blas_prec_double:
814 {
815 double multemp;
816
817 multemp = x[row] * *alpha;
818 head_r_true[row] = multemp;
819 tail_r_true[row] = 0.0;
820 break;
821 }
822 case blas_prec_extra:
823 {
824 double head_multemp, tail_multemp;
825
826 {
827 /* Compute double_double = double * double. */
828 double a1, a2, b1, b2, con;
829
830 con = x[row] * split;
831 a1 = con - x[row];
832 a1 = con - a1;
833 a2 = x[row] - a1;
834 con = *alpha * split;
835 b1 = con - *alpha;
836 b1 = con - b1;
837 b2 = *alpha - b1;
838
839 head_multemp = x[row] * *alpha;
840 tail_multemp =
841 (((a1 * b1 - head_multemp) + a1 * b2) + a2 * b1) + a2 * b2;
842 }
843 head_r_true[row] = head_multemp;
844 tail_r_true[row] = tail_multemp;
845 break;
846 }
847 }
848 }
849
850 blas_free(temp);
851
852 if (prec != blas_prec_extra)
853 blas_free(xtemp2);
854 }
BLAS_ctrsv_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,void * alpha,int alpha_flag,void * T,int lda,void * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)855 void BLAS_ctrsv_testgen(int norm, enum blas_order_type order,
856 enum blas_uplo_type uplo, enum blas_trans_type trans,
857 enum blas_diag_type diag, int n, void *alpha,
858 int alpha_flag, void *T, int lda, void *x, int *seed,
859 double *head_r_true, double *tail_r_true, int row,
860 enum blas_prec_type prec)
861
862 /*
863 * Purpose
864 * =======
865 *
866 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
867 *
868 * Arguments
869 * =========
870 *
871 * norm (input) blas_norm_type
872 *
873 * order (input) blas_order_type
874 * Order of T; row or column major
875 *
876 * uplo (input) blas_uplo_type
877 * Whether T is upper or lower
878 *
879 * trans (input) blas_trans_type
880 * No trans, trans, conj trans
881 *
882 * diag (input) blas_diag_type
883 * non unit, unit
884 *
885 * n (input) int
886 * Dimension of AP and the length of vector x
887 *
888 * alpha (input/output) void*
889 * If alpha_flag = 1, alpha is input.
890 * If alpha_flag = 0, alpha is output.
891 *
892 * alpha_flag (input) int
893 * = 0 : alpha is free, and is output.
894 * = 1 : alpha is fixed on input.
895 *
896 * T (output) void*
897 *
898 * x (input/output) void*
899 *
900 * seed (input/output) int
901 *
902 * head_r_true (output) double*
903 * The leading part of the truth in double-double.
904 *
905 * tail_r_true (output) double*
906 * The trailing part of the truth in double-double.
907 *
908 * row (input) int
909 * The true row being generated
910 *
911 * prec (input) blas_prec_type
912 * single, double, or extra precision
913 *
914 */
915 {
916 float *x_i = (float *) x;
917 float *alpha_i = (float *) alpha;
918 float *T_i = (float *) T;
919 float alpha_r;
920 float *T_r;
921 float *x_r;
922 double *head_r_true_r, *tail_r_true_r;
923 int i, inc = 2, length;
924
925 T_r = (float *) blas_malloc(4 * n * n * sizeof(float));
926 if (4 * n * n > 0 && T_r == NULL) {
927 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
928 }
929 x_r = (float *) blas_malloc(n * sizeof(float));
930 if (n > 0 && x_r == NULL) {
931 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
932 }
933 head_r_true_r = (double *) blas_malloc(n * sizeof(double));
934 tail_r_true_r = (double *) blas_malloc(n * sizeof(double));
935 if (n > 0 && (head_r_true_r == NULL || tail_r_true_r == NULL)) {
936 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
937 }
938
939 if (alpha_flag == 1) {
940 alpha_r = alpha_i[0];
941 }
942
943 if ((uplo == blas_lower && trans == blas_no_trans) ||
944 (uplo == blas_upper && trans != blas_no_trans)) {
945 length = row;
946 } else {
947 length = n - row - 1;
948 }
949
950 BLAS_strsv_testgen(norm, order, uplo, trans, diag, n, &alpha_r,
951 alpha_flag, T_r, lda, x_r, seed, head_r_true_r,
952 tail_r_true_r, row, prec);
953
954 alpha_i[0] = alpha_r;
955 alpha_i[1] = alpha_r;
956
957 if (diag == blas_non_unit_diag) {
958 for (i = 0; i < n; i++) {
959 x_i[i * inc] = 0.0;
960 x_i[i * inc + 1] = x_r[i];
961
962 if (i != row) {
963 head_r_true[i * inc] = 0.0;
964 head_r_true[i * inc + 1] = head_r_true_r[i];
965 tail_r_true[i * inc] = 0.0;
966 tail_r_true[i * inc + 1] = tail_r_true_r[i];
967 } else {
968 head_r_true[i * inc] = -head_r_true_r[i];
969 head_r_true[i * inc + 1] = head_r_true_r[i];
970 tail_r_true[i * inc] = -tail_r_true_r[i];
971 tail_r_true[i * inc + 1] = tail_r_true_r[i];
972 }
973 }
974
975 for (i = 0; i < 4 * n * n; i++) {
976 T_i[i * inc] = T_r[i];
977
978 if (trans != blas_conj_trans)
979 T_i[i * inc + 1] = T_r[i];
980 else
981 T_i[i * inc + 1] = -T_r[i];
982 }
983
984 T_i[(row + lda * row) * inc + 1] = 0.0;
985 } else {
986 for (i = 0; i < n; i++) {
987 x_i[i * inc] = 0.0;
988 x_i[i * inc + 1] = x_r[i];
989
990 if (i != row || length == 0) {
991 head_r_true[i * inc] = -head_r_true_r[i];
992 head_r_true[i * inc + 1] = head_r_true_r[i];
993 tail_r_true[i * inc] = -tail_r_true_r[i];
994 tail_r_true[i * inc + 1] = tail_r_true_r[i];
995 } else {
996 x_i[i * inc] = x_r[i];
997 x_i[i * inc + 1] = x_r[i];
998
999 head_r_true[i * inc] = 0.0;
1000 head_r_true[i * inc + 1] = 2 * head_r_true_r[i];
1001 tail_r_true[i * inc] = 0.0;
1002 tail_r_true[i * inc + 1] = 2 * tail_r_true_r[i];
1003 }
1004 }
1005
1006 for (i = 0; i < 4 * n * n; i++) {
1007 T_i[i * inc] = T_r[i];
1008
1009 if (trans != blas_conj_trans)
1010 T_i[i * inc + 1] = -T_r[i];
1011 else
1012 T_i[i * inc + 1] = T_r[i];
1013 }
1014
1015 for (i = 0; i < n; i++) {
1016 T_i[(i + lda * i) * inc + 1] = 0.0;
1017 }
1018 }
1019
1020 blas_free(T_r);
1021 blas_free(x_r);
1022 blas_free(head_r_true_r);
1023 blas_free(tail_r_true_r);
1024 }
1025
BLAS_ztrsv_c_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,void * alpha,int alpha_flag,void * T,int lda,void * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)1026 void BLAS_ztrsv_c_testgen(int norm, enum blas_order_type order,
1027 enum blas_uplo_type uplo,
1028 enum blas_trans_type trans,
1029 enum blas_diag_type diag, int n, void *alpha,
1030 int alpha_flag, void *T, int lda, void *x,
1031 int *seed, double *head_r_true, double *tail_r_true,
1032 int row, enum blas_prec_type prec)
1033
1034 /*
1035 * Purpose
1036 * =======
1037 *
1038 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
1039 *
1040 * Arguments
1041 * =========
1042 *
1043 * norm (input) blas_norm_type
1044 *
1045 * order (input) blas_order_type
1046 * Order of T; row or column major
1047 *
1048 * uplo (input) blas_uplo_type
1049 * Whether T is upper or lower
1050 *
1051 * trans (input) blas_trans_type
1052 * No trans, trans, conj trans
1053 *
1054 * diag (input) blas_diag_type
1055 * non unit, unit
1056 *
1057 * n (input) int
1058 * Dimension of AP and the length of vector x
1059 *
1060 * alpha (input/output) void*
1061 * If alpha_flag = 1, alpha is input.
1062 * If alpha_flag = 0, alpha is output.
1063 *
1064 * alpha_flag (input) int
1065 * = 0 : alpha is free, and is output.
1066 * = 1 : alpha is fixed on input.
1067 *
1068 * T (output) void*
1069 *
1070 * x (input/output) void*
1071 *
1072 * seed (input/output) int
1073 *
1074 * head_r_true (output) double*
1075 * The leading part of the truth in double-double.
1076 *
1077 * tail_r_true (output) double*
1078 * The trailing part of the truth in double-double.
1079 *
1080 * row (input) int
1081 * The true row being generated
1082 *
1083 * prec (input) blas_prec_type
1084 * single, double, or extra precision
1085 *
1086 */
1087 {
1088 double *x_i = (double *) x;
1089 double *alpha_i = (double *) alpha;
1090 float *T_i = (float *) T;
1091 double alpha_r;
1092 float *T_r;
1093 double *x_r;
1094 double *head_r_true_r, *tail_r_true_r;
1095 int i, inc = 2, length;
1096
1097 T_r = (float *) blas_malloc(4 * n * n * sizeof(float));
1098 if (4 * n * n > 0 && T_r == NULL) {
1099 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1100 }
1101 x_r = (double *) blas_malloc(n * sizeof(double));
1102 if (n > 0 && x_r == NULL) {
1103 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1104 }
1105 head_r_true_r = (double *) blas_malloc(n * sizeof(double));
1106 tail_r_true_r = (double *) blas_malloc(n * sizeof(double));
1107 if (n > 0 && (head_r_true_r == NULL || tail_r_true_r == NULL)) {
1108 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1109 }
1110
1111 if (alpha_flag == 1) {
1112 alpha_r = alpha_i[0];
1113 }
1114
1115 if ((uplo == blas_lower && trans == blas_no_trans) ||
1116 (uplo == blas_upper && trans != blas_no_trans)) {
1117 length = row;
1118 } else {
1119 length = n - row - 1;
1120 }
1121
1122 BLAS_dtrsv_s_testgen(norm, order, uplo, trans, diag, n, &alpha_r,
1123 alpha_flag, T_r, lda, x_r, seed, head_r_true_r,
1124 tail_r_true_r, row, prec);
1125
1126 alpha_i[0] = alpha_r;
1127 alpha_i[1] = alpha_r;
1128
1129 if (diag == blas_non_unit_diag) {
1130 for (i = 0; i < n; i++) {
1131 x_i[i * inc] = 0.0;
1132 x_i[i * inc + 1] = x_r[i];
1133
1134 if (i != row) {
1135 head_r_true[i * inc] = 0.0;
1136 head_r_true[i * inc + 1] = head_r_true_r[i];
1137 tail_r_true[i * inc] = 0.0;
1138 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1139 } else {
1140 head_r_true[i * inc] = -head_r_true_r[i];
1141 head_r_true[i * inc + 1] = head_r_true_r[i];
1142 tail_r_true[i * inc] = -tail_r_true_r[i];
1143 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1144 }
1145 }
1146
1147 for (i = 0; i < 4 * n * n; i++) {
1148 T_i[i * inc] = T_r[i];
1149
1150 if (trans != blas_conj_trans)
1151 T_i[i * inc + 1] = T_r[i];
1152 else
1153 T_i[i * inc + 1] = -T_r[i];
1154 }
1155
1156 T_i[(row + lda * row) * inc + 1] = 0.0;
1157 } else {
1158 for (i = 0; i < n; i++) {
1159 x_i[i * inc] = 0.0;
1160 x_i[i * inc + 1] = x_r[i];
1161
1162 if (i != row || length == 0) {
1163 head_r_true[i * inc] = -head_r_true_r[i];
1164 head_r_true[i * inc + 1] = head_r_true_r[i];
1165 tail_r_true[i * inc] = -tail_r_true_r[i];
1166 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1167 } else {
1168 x_i[i * inc] = x_r[i];
1169 x_i[i * inc + 1] = x_r[i];
1170
1171 head_r_true[i * inc] = 0.0;
1172 head_r_true[i * inc + 1] = 2 * head_r_true_r[i];
1173 tail_r_true[i * inc] = 0.0;
1174 tail_r_true[i * inc + 1] = 2 * tail_r_true_r[i];
1175 }
1176 }
1177
1178 for (i = 0; i < 4 * n * n; i++) {
1179 T_i[i * inc] = T_r[i];
1180
1181 if (trans != blas_conj_trans)
1182 T_i[i * inc + 1] = -T_r[i];
1183 else
1184 T_i[i * inc + 1] = T_r[i];
1185 }
1186
1187 for (i = 0; i < n; i++) {
1188 T_i[(i + lda * i) * inc + 1] = 0.0;
1189 }
1190 }
1191
1192 blas_free(T_r);
1193 blas_free(x_r);
1194 blas_free(head_r_true_r);
1195 blas_free(tail_r_true_r);
1196 }
1197
BLAS_ztrsv_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,void * alpha,int alpha_flag,void * T,int lda,void * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)1198 void BLAS_ztrsv_testgen(int norm, enum blas_order_type order,
1199 enum blas_uplo_type uplo, enum blas_trans_type trans,
1200 enum blas_diag_type diag, int n, void *alpha,
1201 int alpha_flag, void *T, int lda, void *x, int *seed,
1202 double *head_r_true, double *tail_r_true, int row,
1203 enum blas_prec_type prec)
1204
1205 /*
1206 * Purpose
1207 * =======
1208 *
1209 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
1210 *
1211 * Arguments
1212 * =========
1213 *
1214 * norm (input) blas_norm_type
1215 *
1216 * order (input) blas_order_type
1217 * Order of T; row or column major
1218 *
1219 * uplo (input) blas_uplo_type
1220 * Whether T is upper or lower
1221 *
1222 * trans (input) blas_trans_type
1223 * No trans, trans, conj trans
1224 *
1225 * diag (input) blas_diag_type
1226 * non unit, unit
1227 *
1228 * n (input) int
1229 * Dimension of AP and the length of vector x
1230 *
1231 * alpha (input/output) void*
1232 * If alpha_flag = 1, alpha is input.
1233 * If alpha_flag = 0, alpha is output.
1234 *
1235 * alpha_flag (input) int
1236 * = 0 : alpha is free, and is output.
1237 * = 1 : alpha is fixed on input.
1238 *
1239 * T (output) void*
1240 *
1241 * x (input/output) void*
1242 *
1243 * seed (input/output) int
1244 *
1245 * head_r_true (output) double*
1246 * The leading part of the truth in double-double.
1247 *
1248 * tail_r_true (output) double*
1249 * The trailing part of the truth in double-double.
1250 *
1251 * row (input) int
1252 * The true row being generated
1253 *
1254 * prec (input) blas_prec_type
1255 * single, double, or extra precision
1256 *
1257 */
1258 {
1259 double *x_i = (double *) x;
1260 double *alpha_i = (double *) alpha;
1261 double *T_i = (double *) T;
1262 double alpha_r;
1263 double *T_r;
1264 double *x_r;
1265 double *head_r_true_r, *tail_r_true_r;
1266 int i, inc = 2, length;
1267
1268 T_r = (double *) blas_malloc(4 * n * n * sizeof(double));
1269 if (4 * n * n > 0 && T_r == NULL) {
1270 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1271 }
1272 x_r = (double *) blas_malloc(n * sizeof(double));
1273 if (n > 0 && x_r == NULL) {
1274 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1275 }
1276 head_r_true_r = (double *) blas_malloc(n * sizeof(double));
1277 tail_r_true_r = (double *) blas_malloc(n * sizeof(double));
1278 if (n > 0 && (head_r_true_r == NULL || tail_r_true_r == NULL)) {
1279 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1280 }
1281
1282 if (alpha_flag == 1) {
1283 alpha_r = alpha_i[0];
1284 }
1285
1286 if ((uplo == blas_lower && trans == blas_no_trans) ||
1287 (uplo == blas_upper && trans != blas_no_trans)) {
1288 length = row;
1289 } else {
1290 length = n - row - 1;
1291 }
1292
1293 BLAS_dtrsv_testgen(norm, order, uplo, trans, diag, n, &alpha_r,
1294 alpha_flag, T_r, lda, x_r, seed, head_r_true_r,
1295 tail_r_true_r, row, prec);
1296
1297 alpha_i[0] = alpha_r;
1298 alpha_i[1] = alpha_r;
1299
1300 if (diag == blas_non_unit_diag) {
1301 for (i = 0; i < n; i++) {
1302 x_i[i * inc] = 0.0;
1303 x_i[i * inc + 1] = x_r[i];
1304
1305 if (i != row) {
1306 head_r_true[i * inc] = 0.0;
1307 head_r_true[i * inc + 1] = head_r_true_r[i];
1308 tail_r_true[i * inc] = 0.0;
1309 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1310 } else {
1311 head_r_true[i * inc] = -head_r_true_r[i];
1312 head_r_true[i * inc + 1] = head_r_true_r[i];
1313 tail_r_true[i * inc] = -tail_r_true_r[i];
1314 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1315 }
1316 }
1317
1318 for (i = 0; i < 4 * n * n; i++) {
1319 T_i[i * inc] = T_r[i];
1320
1321 if (trans != blas_conj_trans)
1322 T_i[i * inc + 1] = T_r[i];
1323 else
1324 T_i[i * inc + 1] = -T_r[i];
1325 }
1326
1327 T_i[(row + lda * row) * inc + 1] = 0.0;
1328 } else {
1329 for (i = 0; i < n; i++) {
1330 x_i[i * inc] = 0.0;
1331 x_i[i * inc + 1] = x_r[i];
1332
1333 if (i != row || length == 0) {
1334 head_r_true[i * inc] = -head_r_true_r[i];
1335 head_r_true[i * inc + 1] = head_r_true_r[i];
1336 tail_r_true[i * inc] = -tail_r_true_r[i];
1337 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1338 } else {
1339 x_i[i * inc] = x_r[i];
1340 x_i[i * inc + 1] = x_r[i];
1341
1342 head_r_true[i * inc] = 0.0;
1343 head_r_true[i * inc + 1] = 2 * head_r_true_r[i];
1344 tail_r_true[i * inc] = 0.0;
1345 tail_r_true[i * inc + 1] = 2 * tail_r_true_r[i];
1346 }
1347 }
1348
1349 for (i = 0; i < 4 * n * n; i++) {
1350 T_i[i * inc] = T_r[i];
1351
1352 if (trans != blas_conj_trans)
1353 T_i[i * inc + 1] = -T_r[i];
1354 else
1355 T_i[i * inc + 1] = T_r[i];
1356 }
1357
1358 for (i = 0; i < n; i++) {
1359 T_i[(i + lda * i) * inc + 1] = 0.0;
1360 }
1361 }
1362
1363 blas_free(T_r);
1364 blas_free(x_r);
1365 blas_free(head_r_true_r);
1366 blas_free(tail_r_true_r);
1367 }
1368
BLAS_ctrsv_s_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,void * alpha,int alpha_flag,float * T,int lda,void * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)1369 void BLAS_ctrsv_s_testgen(int norm, enum blas_order_type order,
1370 enum blas_uplo_type uplo,
1371 enum blas_trans_type trans,
1372 enum blas_diag_type diag, int n, void *alpha,
1373 int alpha_flag, float *T, int lda, void *x,
1374 int *seed, double *head_r_true, double *tail_r_true,
1375 int row, enum blas_prec_type prec)
1376
1377 /*
1378 * Purpose
1379 * =======
1380 *
1381 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
1382 *
1383 * Arguments
1384 * =========
1385 *
1386 * norm (input) blas_norm_type
1387 *
1388 * order (input) blas_order_type
1389 * Order of T; row or column major
1390 *
1391 * uplo (input) blas_uplo_type
1392 * Whether T is upper or lower
1393 *
1394 * trans (input) blas_trans_type
1395 * No trans, trans, conj trans
1396 *
1397 * diag (input) blas_diag_type
1398 * non unit, unit
1399 *
1400 * n (input) int
1401 * Dimension of AP and the length of vector x
1402 *
1403 * alpha (input/output) void*
1404 * If alpha_flag = 1, alpha is input.
1405 * If alpha_flag = 0, alpha is output.
1406 *
1407 * alpha_flag (input) int
1408 * = 0 : alpha is free, and is output.
1409 * = 1 : alpha is fixed on input.
1410 *
1411 * T (output) float*
1412 *
1413 * x (input/output) void*
1414 *
1415 * seed (input/output) int
1416 *
1417 * head_r_true (output) double*
1418 * The leading part of the truth in double-double.
1419 *
1420 * tail_r_true (output) double*
1421 * The trailing part of the truth in double-double.
1422 *
1423 * row (input) int
1424 * The true row being generated
1425 *
1426 * prec (input) blas_prec_type
1427 * single, double, or extra precision
1428 *
1429 */
1430 {
1431 float *x_i = (float *) x;
1432 float *alpha_i = (float *) alpha;
1433 float *T_i = T;
1434 float alpha_r;
1435 float *x_r;
1436 double *head_r_true_r, *tail_r_true_r;
1437 int i, inc = 2;
1438
1439 x_r = (float *) blas_malloc(n * sizeof(float));
1440 if (n > 0 && x_r == NULL) {
1441 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1442 }
1443 head_r_true_r = (double *) blas_malloc(n * sizeof(double));
1444 if (n > 0 && head_r_true_r == NULL) {
1445 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1446 }
1447 tail_r_true_r = (double *) blas_malloc(n * sizeof(double));
1448 if (n > 0 && tail_r_true_r == NULL) {
1449 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1450 }
1451
1452 if (alpha_flag == 1) {
1453 alpha_r = alpha_i[0];
1454 }
1455
1456 BLAS_strsv_testgen(norm, order, uplo, trans, diag, n, &alpha_r,
1457 alpha_flag, T_i, lda, x_r, seed, head_r_true_r,
1458 tail_r_true_r, row, prec);
1459
1460 alpha_i[0] = alpha_r;
1461 alpha_i[1] = alpha_r;
1462
1463 for (i = 0; i < n; i++) {
1464 x_i[i * inc] = 0.0;
1465 x_i[i * inc + 1] = x_r[i];
1466
1467 head_r_true[i * inc] = -head_r_true_r[i];
1468 head_r_true[i * inc + 1] = head_r_true_r[i];
1469 tail_r_true[i * inc] = -tail_r_true_r[i];
1470 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1471 }
1472
1473 blas_free(x_r);
1474 blas_free(head_r_true_r);
1475 blas_free(tail_r_true_r);
1476 }
1477
BLAS_ztrsv_d_testgen(int norm,enum blas_order_type order,enum blas_uplo_type uplo,enum blas_trans_type trans,enum blas_diag_type diag,int n,void * alpha,int alpha_flag,double * T,int lda,void * x,int * seed,double * head_r_true,double * tail_r_true,int row,enum blas_prec_type prec)1478 void BLAS_ztrsv_d_testgen(int norm, enum blas_order_type order,
1479 enum blas_uplo_type uplo,
1480 enum blas_trans_type trans,
1481 enum blas_diag_type diag, int n, void *alpha,
1482 int alpha_flag, double *T, int lda, void *x,
1483 int *seed, double *head_r_true, double *tail_r_true,
1484 int row, enum blas_prec_type prec)
1485
1486 /*
1487 * Purpose
1488 * =======
1489 *
1490 * Generates alpha, x and T, where T is a triangular matrix; and computes r_true.
1491 *
1492 * Arguments
1493 * =========
1494 *
1495 * norm (input) blas_norm_type
1496 *
1497 * order (input) blas_order_type
1498 * Order of T; row or column major
1499 *
1500 * uplo (input) blas_uplo_type
1501 * Whether T is upper or lower
1502 *
1503 * trans (input) blas_trans_type
1504 * No trans, trans, conj trans
1505 *
1506 * diag (input) blas_diag_type
1507 * non unit, unit
1508 *
1509 * n (input) int
1510 * Dimension of AP and the length of vector x
1511 *
1512 * alpha (input/output) void*
1513 * If alpha_flag = 1, alpha is input.
1514 * If alpha_flag = 0, alpha is output.
1515 *
1516 * alpha_flag (input) int
1517 * = 0 : alpha is free, and is output.
1518 * = 1 : alpha is fixed on input.
1519 *
1520 * T (output) double*
1521 *
1522 * x (input/output) void*
1523 *
1524 * seed (input/output) int
1525 *
1526 * head_r_true (output) double*
1527 * The leading part of the truth in double-double.
1528 *
1529 * tail_r_true (output) double*
1530 * The trailing part of the truth in double-double.
1531 *
1532 * row (input) int
1533 * The true row being generated
1534 *
1535 * prec (input) blas_prec_type
1536 * single, double, or extra precision
1537 *
1538 */
1539 {
1540 double *x_i = (double *) x;
1541 double *alpha_i = (double *) alpha;
1542 double *T_i = T;
1543 double alpha_r;
1544 double *x_r;
1545 double *head_r_true_r, *tail_r_true_r;
1546 int i, inc = 2;
1547
1548 x_r = (double *) blas_malloc(n * sizeof(double));
1549 if (n > 0 && x_r == NULL) {
1550 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1551 }
1552 head_r_true_r = (double *) blas_malloc(n * sizeof(double));
1553 if (n > 0 && head_r_true_r == NULL) {
1554 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1555 }
1556 tail_r_true_r = (double *) blas_malloc(n * sizeof(double));
1557 if (n > 0 && tail_r_true_r == NULL) {
1558 BLAS_error("blas_malloc", 0, 0, "malloc failed.\n");
1559 }
1560
1561 if (alpha_flag == 1) {
1562 alpha_r = alpha_i[0];
1563 }
1564
1565 BLAS_dtrsv_testgen(norm, order, uplo, trans, diag, n, &alpha_r,
1566 alpha_flag, T_i, lda, x_r, seed, head_r_true_r,
1567 tail_r_true_r, row, prec);
1568
1569 alpha_i[0] = alpha_r;
1570 alpha_i[1] = alpha_r;
1571
1572 for (i = 0; i < n; i++) {
1573 x_i[i * inc] = 0.0;
1574 x_i[i * inc + 1] = x_r[i];
1575
1576 head_r_true[i * inc] = -head_r_true_r[i];
1577 head_r_true[i * inc + 1] = head_r_true_r[i];
1578 tail_r_true[i * inc] = -tail_r_true_r[i];
1579 tail_r_true[i * inc + 1] = tail_r_true_r[i];
1580 }
1581
1582 blas_free(x_r);
1583 blas_free(head_r_true_r);
1584 blas_free(tail_r_true_r);
1585 }
1586