1 /*
3 BLIS
4 An object-based framework for developing high-performance BLAS-like
5 libraries.
7 Copyright (C) 2014, The University of Texas at Austin
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions are
11 met:
12 - Redistributions of source code must retain the above copyright
13 notice, this list of conditions and the following disclaimer.
14 - Redistributions in binary form must reproduce the above copyright
15 notice, this list of conditions and the following disclaimer in the
16 documentation and/or other materials provided with the distribution.
17 - Neither the name of The University of Texas at Austin nor the names
18 of its contributors may be used to endorse or promote products
19 derived from this software without specific prior written permission.
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33 */
35 #include "blis.h"
37 #ifdef BLIS_ENABLE_BLAS2BLIS
39 /* chpr.f -- translated by f2c (version 19991025).
40 You must link the resulting object file with the libraries:
41 -lf2c -lm (in that order)
42 */
44 /* Subroutine */ int PASTEF77(c,hpr)(character *uplo, integer *n, real *alpha, singlecomplex *x, integer *incx, singlecomplex *ap)
45 {
46 /* System generated locals */
47 integer i__1, i__2, i__3, i__4, i__5;
48 real r__1;
49 singlecomplex q__1, q__2;
51 /* Builtin functions */
52 void bla_r_cnjg(singlecomplex *, singlecomplex *);
54 /* Local variables */
55 integer info;
56 singlecomplex temp;
57 integer i__, j, k;
58 extern logical PASTEF770(lsame)(character *, character *, ftnlen, ftnlen);
59 integer kk, ix, jx, kx = 0;
60 extern /* Subroutine */ int PASTEF770(xerbla)(character *, integer *, ftnlen);
62 /* .. Scalar Arguments .. */
63 /* .. Array Arguments .. */
64 /* .. */
66 /* Purpose */
67 /* ======= */
69 /* CHPR performs the hermitian rank 1 operation */
71 /* A := alpha*x*conjg( x' ) + A, */
73 /* where alpha is a real scalar, x is an n element vector and A is an */
74 /* n by n hermitian matrix, supplied in packed form. */
76 /* Parameters */
77 /* ========== */
79 /* UPLO - CHARACTER*1. */
80 /* On entry, UPLO specifies whether the upper or lower */
81 /* triangular part of the matrix A is supplied in the packed */
82 /* array AP as follows: */
84 /* UPLO = 'U' or 'u' The upper triangular part of A is */
85 /* supplied in AP. */
87 /* UPLO = 'L' or 'l' The lower triangular part of A is */
88 /* supplied in AP. */
90 /* Unchanged on exit. */
92 /* N - INTEGER. */
93 /* On entry, N specifies the order of the matrix A. */
94 /* N must be at least zero. */
95 /* Unchanged on exit. */
97 /* ALPHA - REAL . */
98 /* On entry, ALPHA specifies the scalar alpha. */
99 /* Unchanged on exit. */
101 /* X - COMPLEX array of dimension at least */
102 /* ( 1 + ( n - 1 )*abs( INCX ) ). */
103 /* Before entry, the incremented array X must contain the n */
104 /* element vector x. */
105 /* Unchanged on exit. */
107 /* INCX - INTEGER. */
108 /* On entry, INCX specifies the increment for the elements of */
109 /* X. INCX must not be zero. */
110 /* Unchanged on exit. */
112 /* AP - COMPLEX array of DIMENSION at least */
113 /* ( ( n*( n + 1 ) )/2 ). */
114 /* Before entry with UPLO = 'U' or 'u', the array AP must */
115 /* contain the upper triangular part of the hermitian matrix */
116 /* packed sequentially, column by column, so that AP( 1 ) */
117 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
118 /* and a( 2, 2 ) respectively, and so on. On exit, the array */
119 /* AP is overwritten by the upper triangular part of the */
120 /* updated matrix. */
121 /* Before entry with UPLO = 'L' or 'l', the array AP must */
122 /* contain the lower triangular part of the hermitian matrix */
123 /* packed sequentially, column by column, so that AP( 1 ) */
124 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
125 /* and a( 3, 1 ) respectively, and so on. On exit, the array */
126 /* AP is overwritten by the lower triangular part of the */
127 /* updated matrix. */
128 /* Note that the imaginary parts of the diagonal elements need */
129 /* not be set, they are assumed to be zero, and on exit they */
130 /* are set to zero. */
133 /* Level 2 Blas routine. */
135 /* -- Written on 22-October-1986. */
136 /* Jack Dongarra, Argonne National Lab. */
137 /* Jeremy Du Croz, Nag Central Office. */
138 /* Sven Hammarling, Nag Central Office. */
139 /* Richard Hanson, Sandia National Labs. */
142 /* .. Parameters .. */
143 /* .. Local Scalars .. */
144 /* .. External Functions .. */
145 /* .. External Subroutines .. */
146 /* .. Intrinsic Functions .. */
147 /* .. */
148 /* .. Executable Statements .. */
150 /* Test the input parameters. */
152 /* Parameter adjustments */
153 --ap;
154 --x;
156 /* Function Body */
157 info = 0;
158 if (! PASTEF770(lsame)(uplo, "U", (ftnlen)1, (ftnlen)1) && ! PASTEF770(lsame)(uplo, "L", (
159 ftnlen)1, (ftnlen)1)) {
160 info = 1;
161 } else if (*n < 0) {
162 info = 2;
163 } else if (*incx == 0) {
164 info = 5;
165 }
166 if (info != 0) {
167 PASTEF770(xerbla)("CHPR ", &info, (ftnlen)6);
168 return 0;
169 }
171 /* Quick return if possible. */
173 if (*n == 0 || *alpha == 0.f) {
174 return 0;
175 }
177 /* Set the start point in X if the increment is not unity. */
179 if (*incx <= 0) {
180 kx = 1 - (*n - 1) * *incx;
181 } else if (*incx != 1) {
182 kx = 1;
183 }
185 /* Start the operations. In this version the elements of the array AP */
186 /* are accessed sequentially with one pass through AP. */
188 kk = 1;
189 if (PASTEF770(lsame)(uplo, "U", (ftnlen)1, (ftnlen)1)) {
191 /* Form A when upper triangle is stored in AP. */
193 if (*incx == 1) {
194 i__1 = *n;
195 for (j = 1; j <= i__1; ++j) {
196 i__2 = j;
197 if (bli_creal(x[i__2]) != 0.f || bli_cimag(x[i__2]) != 0.f) {
198 bla_r_cnjg(&q__2, &x[j]);
199 bli_csets( (*alpha * bli_creal(q__2)), (*alpha * bli_cimag(q__2)), q__1 );
200 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), temp );
201 k = kk;
202 i__2 = j - 1;
203 for (i__ = 1; i__ <= i__2; ++i__) {
204 i__3 = k;
205 i__4 = k;
206 i__5 = i__;
207 bli_csets( (bli_creal(x[i__5]) * bli_creal(temp) - bli_cimag(x[i__5]) * bli_cimag(temp)), (bli_creal(x[i__5]) * bli_cimag(temp) + bli_cimag(x[i__5]) * bli_creal(temp)), q__2 );
208 bli_csets( (bli_creal(ap[i__4]) + bli_creal(q__2)), (bli_cimag(ap[i__4]) + bli_cimag(q__2)), q__1 );
209 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), ap[i__3] );
210 ++k;
211 /* L10: */
212 }
213 i__2 = kk + j - 1;
214 i__3 = kk + j - 1;
215 i__4 = j;
216 bli_csets( (bli_creal(x[i__4]) * bli_creal(temp) - bli_cimag(x[i__4]) * bli_cimag(temp)), (bli_creal(x[i__4]) * bli_cimag(temp) + bli_cimag(x[i__4]) * bli_creal(temp)), q__1 );
217 r__1 = bli_creal(ap[i__3]) + bli_creal(q__1);
218 bli_csets( (r__1), (0.f), ap[i__2] );
219 } else {
220 i__2 = kk + j - 1;
221 i__3 = kk + j - 1;
222 r__1 = bli_creal(ap[i__3]);
223 bli_csets( (r__1), (0.f), ap[i__2] );
224 }
225 kk += j;
226 /* L20: */
227 }
228 } else {
229 jx = kx;
230 i__1 = *n;
231 for (j = 1; j <= i__1; ++j) {
232 i__2 = jx;
233 if (bli_creal(x[i__2]) != 0.f || bli_cimag(x[i__2]) != 0.f) {
234 bla_r_cnjg(&q__2, &x[jx]);
235 bli_csets( (*alpha * bli_creal(q__2)), (*alpha * bli_cimag(q__2)), q__1 );
236 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), temp );
237 ix = kx;
238 i__2 = kk + j - 2;
239 for (k = kk; k <= i__2; ++k) {
240 i__3 = k;
241 i__4 = k;
242 i__5 = ix;
243 bli_csets( (bli_creal(x[i__5]) * bli_creal(temp) - bli_cimag(x[i__5]) * bli_cimag(temp)), (bli_creal(x[i__5]) * bli_cimag(temp) + bli_cimag(x[i__5]) * bli_creal(temp)), q__2 );
244 bli_csets( (bli_creal(ap[i__4]) + bli_creal(q__2)), (bli_cimag(ap[i__4]) + bli_cimag(q__2)), q__1 );
245 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), ap[i__3] );
246 ix += *incx;
247 /* L30: */
248 }
249 i__2 = kk + j - 1;
250 i__3 = kk + j - 1;
251 i__4 = jx;
252 bli_csets( (bli_creal(x[i__4]) * bli_creal(temp) - bli_cimag(x[i__4]) * bli_cimag(temp)), (bli_creal(x[i__4]) * bli_cimag(temp) + bli_cimag(x[i__4]) * bli_creal(temp)), q__1 );
253 r__1 = bli_creal(ap[i__3]) + bli_creal(q__1);
254 bli_csets( (r__1), (0.f), ap[i__2] );
255 } else {
256 i__2 = kk + j - 1;
257 i__3 = kk + j - 1;
258 r__1 = bli_creal(ap[i__3]);
259 bli_csets( (r__1), (0.f), ap[i__2] );
260 }
261 jx += *incx;
262 kk += j;
263 /* L40: */
264 }
265 }
266 } else {
268 /* Form A when lower triangle is stored in AP. */
270 if (*incx == 1) {
271 i__1 = *n;
272 for (j = 1; j <= i__1; ++j) {
273 i__2 = j;
274 if (bli_creal(x[i__2]) != 0.f || bli_cimag(x[i__2]) != 0.f) {
275 bla_r_cnjg(&q__2, &x[j]);
276 bli_csets( (*alpha * bli_creal(q__2)), (*alpha * bli_cimag(q__2)), q__1 );
277 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), temp );
278 i__2 = kk;
279 i__3 = kk;
280 i__4 = j;
281 bli_csets( (bli_creal(temp) * bli_creal(x[i__4]) - bli_cimag(temp) * bli_cimag(x[i__4])), (bli_creal(temp) * bli_cimag(x[i__4]) + bli_cimag(temp) * bli_creal(x[i__4])), q__1 );
282 r__1 = bli_creal(ap[i__3]) + bli_creal(q__1);
283 bli_csets( (r__1), (0.f), ap[i__2] );
284 k = kk + 1;
285 i__2 = *n;
286 for (i__ = j + 1; i__ <= i__2; ++i__) {
287 i__3 = k;
288 i__4 = k;
289 i__5 = i__;
290 bli_csets( (bli_creal(x[i__5]) * bli_creal(temp) - bli_cimag(x[i__5]) * bli_cimag(temp)), (bli_creal(x[i__5]) * bli_cimag(temp) + bli_cimag(x[i__5]) * bli_creal(temp)), q__2 );
291 bli_csets( (bli_creal(ap[i__4]) + bli_creal(q__2)), (bli_cimag(ap[i__4]) + bli_cimag(q__2)), q__1 );
292 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), ap[i__3] );
293 ++k;
294 /* L50: */
295 }
296 } else {
297 i__2 = kk;
298 i__3 = kk;
299 r__1 = bli_creal(ap[i__3]);
300 bli_csets( (r__1), (0.f), ap[i__2] );
301 }
302 kk = kk + *n - j + 1;
303 /* L60: */
304 }
305 } else {
306 jx = kx;
307 i__1 = *n;
308 for (j = 1; j <= i__1; ++j) {
309 i__2 = jx;
310 if (bli_creal(x[i__2]) != 0.f || bli_cimag(x[i__2]) != 0.f) {
311 bla_r_cnjg(&q__2, &x[jx]);
312 bli_csets( (*alpha * bli_creal(q__2)), (*alpha * bli_cimag(q__2)), q__1 );
313 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), temp );
314 i__2 = kk;
315 i__3 = kk;
316 i__4 = jx;
317 bli_csets( (bli_creal(temp) * bli_creal(x[i__4]) - bli_cimag(temp) * bli_cimag(x[i__4])), (bli_creal(temp) * bli_cimag(x[i__4]) + bli_cimag(temp) * bli_creal(x[i__4])), q__1 );
318 r__1 = bli_creal(ap[i__3]) + bli_creal(q__1);
319 bli_csets( (r__1), (0.f), ap[i__2] );
320 ix = jx;
321 i__2 = kk + *n - j;
322 for (k = kk + 1; k <= i__2; ++k) {
323 ix += *incx;
324 i__3 = k;
325 i__4 = k;
326 i__5 = ix;
327 bli_csets( (bli_creal(x[i__5]) * bli_creal(temp) - bli_cimag(x[i__5]) * bli_cimag(temp)), (bli_creal(x[i__5]) * bli_cimag(temp) + bli_cimag(x[i__5]) * bli_creal(temp)), q__2 );
328 bli_csets( (bli_creal(ap[i__4]) + bli_creal(q__2)), (bli_cimag(ap[i__4]) + bli_cimag(q__2)), q__1 );
329 bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), ap[i__3] );
330 /* L70: */
331 }
332 } else {
333 i__2 = kk;
334 i__3 = kk;
335 r__1 = bli_creal(ap[i__3]);
336 bli_csets( (r__1), (0.f), ap[i__2] );
337 }
338 jx += *incx;
339 kk = kk + *n - j + 1;
340 /* L80: */
341 }
342 }
343 }
345 return 0;
347 /* End of CHPR . */
349 } /* chpr_ */
351 /* zhpr.f -- translated by f2c (version 19991025).
352 You must link the resulting object file with the libraries:
353 -lf2c -lm (in that order)
354 */
356 /* Subroutine */ int PASTEF77(z,hpr)(character *uplo, integer *n, doublereal *alpha, doublecomplex *x, integer *incx, doublecomplex *ap)
357 {
358 /* System generated locals */
359 integer i__1, i__2, i__3, i__4, i__5;
360 doublereal d__1;
361 doublecomplex z__1, z__2;
363 /* Builtin functions */
364 void bla_d_cnjg(doublecomplex *, doublecomplex *);
366 /* Local variables */
367 integer info;
368 doublecomplex temp;
369 integer i__, j, k;
370 extern logical PASTEF770(lsame)(character *, character *, ftnlen, ftnlen);
371 integer kk, ix, jx, kx = 0;
372 extern /* Subroutine */ int PASTEF770(xerbla)(character *, integer *, ftnlen);
374 /* .. Scalar Arguments .. */
375 /* .. Array Arguments .. */
376 /* .. */
378 /* Purpose */
379 /* ======= */
381 /* ZHPR performs the hermitian rank 1 operation */
383 /* A := alpha*x*conjg( x' ) + A, */
385 /* where alpha is a real scalar, x is an n element vector and A is an */
386 /* n by n hermitian matrix, supplied in packed form. */
388 /* Parameters */
389 /* ========== */
391 /* UPLO - CHARACTER*1. */
392 /* On entry, UPLO specifies whether the upper or lower */
393 /* triangular part of the matrix A is supplied in the packed */
394 /* array AP as follows: */
396 /* UPLO = 'U' or 'u' The upper triangular part of A is */
397 /* supplied in AP. */
399 /* UPLO = 'L' or 'l' The lower triangular part of A is */
400 /* supplied in AP. */
402 /* Unchanged on exit. */
404 /* N - INTEGER. */
405 /* On entry, N specifies the order of the matrix A. */
406 /* N must be at least zero. */
407 /* Unchanged on exit. */
409 /* ALPHA - DOUBLE PRECISION. */
410 /* On entry, ALPHA specifies the scalar alpha. */
411 /* Unchanged on exit. */
413 /* X - COMPLEX*16 array of dimension at least */
414 /* ( 1 + ( n - 1 )*abs( INCX ) ). */
415 /* Before entry, the incremented array X must contain the n */
416 /* element vector x. */
417 /* Unchanged on exit. */
419 /* INCX - INTEGER. */
420 /* On entry, INCX specifies the increment for the elements of */
421 /* X. INCX must not be zero. */
422 /* Unchanged on exit. */
424 /* AP - COMPLEX*16 array of DIMENSION at least */
425 /* ( ( n*( n + 1 ) )/2 ). */
426 /* Before entry with UPLO = 'U' or 'u', the array AP must */
427 /* contain the upper triangular part of the hermitian matrix */
428 /* packed sequentially, column by column, so that AP( 1 ) */
429 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
430 /* and a( 2, 2 ) respectively, and so on. On exit, the array */
431 /* AP is overwritten by the upper triangular part of the */
432 /* updated matrix. */
433 /* Before entry with UPLO = 'L' or 'l', the array AP must */
434 /* contain the lower triangular part of the hermitian matrix */
435 /* packed sequentially, column by column, so that AP( 1 ) */
436 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
437 /* and a( 3, 1 ) respectively, and so on. On exit, the array */
438 /* AP is overwritten by the lower triangular part of the */
439 /* updated matrix. */
440 /* Note that the imaginary parts of the diagonal elements need */
441 /* not be set, they are assumed to be zero, and on exit they */
442 /* are set to zero. */
445 /* Level 2 Blas routine. */
447 /* -- Written on 22-October-1986. */
448 /* Jack Dongarra, Argonne National Lab. */
449 /* Jeremy Du Croz, Nag Central Office. */
450 /* Sven Hammarling, Nag Central Office. */
451 /* Richard Hanson, Sandia National Labs. */
454 /* .. Parameters .. */
455 /* .. Local Scalars .. */
456 /* .. External Functions .. */
457 /* .. External Subroutines .. */
458 /* .. Intrinsic Functions .. */
459 /* .. */
460 /* .. Executable Statements .. */
462 /* Test the input parameters. */
464 /* Parameter adjustments */
465 --ap;
466 --x;
468 /* Function Body */
469 info = 0;
470 if (! PASTEF770(lsame)(uplo, "U", (ftnlen)1, (ftnlen)1) && ! PASTEF770(lsame)(uplo, "L", (
471 ftnlen)1, (ftnlen)1)) {
472 info = 1;
473 } else if (*n < 0) {
474 info = 2;
475 } else if (*incx == 0) {
476 info = 5;
477 }
478 if (info != 0) {
479 PASTEF770(xerbla)("ZHPR ", &info, (ftnlen)6);
480 return 0;
481 }
483 /* Quick return if possible. */
485 if (*n == 0 || *alpha == 0.) {
486 return 0;
487 }
489 /* Set the start point in X if the increment is not unity. */
491 if (*incx <= 0) {
492 kx = 1 - (*n - 1) * *incx;
493 } else if (*incx != 1) {
494 kx = 1;
495 }
497 /* Start the operations. In this version the elements of the array AP */
498 /* are accessed sequentially with one pass through AP. */
500 kk = 1;
501 if (PASTEF770(lsame)(uplo, "U", (ftnlen)1, (ftnlen)1)) {
503 /* Form A when upper triangle is stored in AP. */
505 if (*incx == 1) {
506 i__1 = *n;
507 for (j = 1; j <= i__1; ++j) {
508 i__2 = j;
509 if (bli_zreal(x[i__2]) != 0. || bli_zimag(x[i__2]) != 0.) {
510 bla_d_cnjg(&z__2, &x[j]);
511 bli_zsets( (*alpha * bli_zreal(z__2)), (*alpha * bli_zimag(z__2)), z__1 );
512 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), temp );
513 k = kk;
514 i__2 = j - 1;
515 for (i__ = 1; i__ <= i__2; ++i__) {
516 i__3 = k;
517 i__4 = k;
518 i__5 = i__;
519 bli_zsets( (bli_zreal(x[i__5]) * bli_zreal(temp) - bli_zimag(x[i__5]) * bli_zimag(temp)), (bli_zreal(x[i__5]) * bli_zimag(temp) + bli_zimag(x[i__5]) * bli_zreal(temp)), z__2 );
520 bli_zsets( (bli_zreal(ap[i__4]) + bli_zreal(z__2)), (bli_zimag(ap[i__4]) + bli_zimag(z__2)), z__1 );
521 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), ap[i__3] );
522 ++k;
523 /* L10: */
524 }
525 i__2 = kk + j - 1;
526 i__3 = kk + j - 1;
527 i__4 = j;
528 bli_zsets( (bli_zreal(x[i__4]) * bli_zreal(temp) - bli_zimag(x[i__4]) * bli_zimag(temp)), (bli_zreal(x[i__4]) * bli_zimag(temp) + bli_zimag(x[i__4]) * bli_zreal(temp)), z__1 );
529 d__1 = bli_zreal(ap[i__3]) + bli_zreal(z__1);
530 bli_zsets( (d__1), (0.), ap[i__2] );
531 } else {
532 i__2 = kk + j - 1;
533 i__3 = kk + j - 1;
534 d__1 = bli_zreal(ap[i__3]);
535 bli_zsets( (d__1), (0.), ap[i__2] );
536 }
537 kk += j;
538 /* L20: */
539 }
540 } else {
541 jx = kx;
542 i__1 = *n;
543 for (j = 1; j <= i__1; ++j) {
544 i__2 = jx;
545 if (bli_zreal(x[i__2]) != 0. || bli_zimag(x[i__2]) != 0.) {
546 bla_d_cnjg(&z__2, &x[jx]);
547 bli_zsets( (*alpha * bli_zreal(z__2)), (*alpha * bli_zimag(z__2)), z__1 );
548 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), temp );
549 ix = kx;
550 i__2 = kk + j - 2;
551 for (k = kk; k <= i__2; ++k) {
552 i__3 = k;
553 i__4 = k;
554 i__5 = ix;
555 bli_zsets( (bli_zreal(x[i__5]) * bli_zreal(temp) - bli_zimag(x[i__5]) * bli_zimag(temp)), (bli_zreal(x[i__5]) * bli_zimag(temp) + bli_zimag(x[i__5]) * bli_zreal(temp)), z__2 );
556 bli_zsets( (bli_zreal(ap[i__4]) + bli_zreal(z__2)), (bli_zimag(ap[i__4]) + bli_zimag(z__2)), z__1 );
557 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), ap[i__3] );
558 ix += *incx;
559 /* L30: */
560 }
561 i__2 = kk + j - 1;
562 i__3 = kk + j - 1;
563 i__4 = jx;
564 bli_zsets( (bli_zreal(x[i__4]) * bli_zreal(temp) - bli_zimag(x[i__4]) * bli_zimag(temp)), (bli_zreal(x[i__4]) * bli_zimag(temp) + bli_zimag(x[i__4]) * bli_zreal(temp)), z__1 );
565 d__1 = bli_zreal(ap[i__3]) + bli_zreal(z__1);
566 bli_zsets( (d__1), (0.), ap[i__2] );
567 } else {
568 i__2 = kk + j - 1;
569 i__3 = kk + j - 1;
570 d__1 = bli_zreal(ap[i__3]);
571 bli_zsets( (d__1), (0.), ap[i__2] );
572 }
573 jx += *incx;
574 kk += j;
575 /* L40: */
576 }
577 }
578 } else {
580 /* Form A when lower triangle is stored in AP. */
582 if (*incx == 1) {
583 i__1 = *n;
584 for (j = 1; j <= i__1; ++j) {
585 i__2 = j;
586 if (bli_zreal(x[i__2]) != 0. || bli_zimag(x[i__2]) != 0.) {
587 bla_d_cnjg(&z__2, &x[j]);
588 bli_zsets( (*alpha * bli_zreal(z__2)), (*alpha * bli_zimag(z__2)), z__1 );
589 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), temp );
590 i__2 = kk;
591 i__3 = kk;
592 i__4 = j;
593 bli_zsets( (bli_zreal(temp) * bli_zreal(x[i__4]) - bli_zimag(temp) * bli_zimag(x[i__4])), (bli_zreal(temp) * bli_zimag(x[i__4]) + bli_zimag(temp) * bli_zreal(x[i__4])), z__1 );
594 d__1 = bli_zreal(ap[i__3]) + bli_zreal(z__1);
595 bli_zsets( (d__1), (0.), ap[i__2] );
596 k = kk + 1;
597 i__2 = *n;
598 for (i__ = j + 1; i__ <= i__2; ++i__) {
599 i__3 = k;
600 i__4 = k;
601 i__5 = i__;
602 bli_zsets( (bli_zreal(x[i__5]) * bli_zreal(temp) - bli_zimag(x[i__5]) * bli_zimag(temp)), (bli_zreal(x[i__5]) * bli_zimag(temp) + bli_zimag(x[i__5]) * bli_zreal(temp)), z__2 );
603 bli_zsets( (bli_zreal(ap[i__4]) + bli_zreal(z__2)), (bli_zimag(ap[i__4]) + bli_zimag(z__2)), z__1 );
604 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), ap[i__3] );
605 ++k;
606 /* L50: */
607 }
608 } else {
609 i__2 = kk;
610 i__3 = kk;
611 d__1 = bli_zreal(ap[i__3]);
612 bli_zsets( (d__1), (0.), ap[i__2] );
613 }
614 kk = kk + *n - j + 1;
615 /* L60: */
616 }
617 } else {
618 jx = kx;
619 i__1 = *n;
620 for (j = 1; j <= i__1; ++j) {
621 i__2 = jx;
622 if (bli_zreal(x[i__2]) != 0. || bli_zimag(x[i__2]) != 0.) {
623 bla_d_cnjg(&z__2, &x[jx]);
624 bli_zsets( (*alpha * bli_zreal(z__2)), (*alpha * bli_zimag(z__2)), z__1 );
625 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), temp );
626 i__2 = kk;
627 i__3 = kk;
628 i__4 = jx;
629 bli_zsets( (bli_zreal(temp) * bli_zreal(x[i__4]) - bli_zimag(temp) * bli_zimag(x[i__4])), (bli_zreal(temp) * bli_zimag(x[i__4]) + bli_zimag(temp) * bli_zreal(x[i__4])), z__1 );
630 d__1 = bli_zreal(ap[i__3]) + bli_zreal(z__1);
631 bli_zsets( (d__1), (0.), ap[i__2] );
632 ix = jx;
633 i__2 = kk + *n - j;
634 for (k = kk + 1; k <= i__2; ++k) {
635 ix += *incx;
636 i__3 = k;
637 i__4 = k;
638 i__5 = ix;
639 bli_zsets( (bli_zreal(x[i__5]) * bli_zreal(temp) - bli_zimag(x[i__5]) * bli_zimag(temp)), (bli_zreal(x[i__5]) * bli_zimag(temp) + bli_zimag(x[i__5]) * bli_zreal(temp)), z__2 );
640 bli_zsets( (bli_zreal(ap[i__4]) + bli_zreal(z__2)), (bli_zimag(ap[i__4]) + bli_zimag(z__2)), z__1 );
641 bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), ap[i__3] );
642 /* L70: */
643 }
644 } else {
645 i__2 = kk;
646 i__3 = kk;
647 d__1 = bli_zreal(ap[i__3]);
648 bli_zsets( (d__1), (0.), ap[i__2] );
649 }
650 jx += *incx;
651 kk = kk + *n - j + 1;
652 /* L80: */
653 }
654 }
655 }
657 return 0;
659 /* End of ZHPR . */
661 } /* zhpr_ */
663 #endif