« back to all changes in this revision
Viewing changes to numpy/linalg/blas_lite.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Matthias Klose
- Date: 2006-07-12 10:00:24 UTC
- Revision ID: james.westby@ubuntu.com-20060712100024-5lw9q2yczlisqcrt
Tags: upstream-0.9.8
Import upstream version 0.9.8
- files added:
- numpy
- numpy/core
- numpy/core/blasdot
- numpy/core/code_generators
- numpy/core/include
- numpy/core/include/numpy
- numpy/core/include/numpy/fenv
- numpy/core/src
- numpy/core/tests
- numpy/dft
- numpy/dft/tests
- numpy/distutils
- numpy/distutils/command
- numpy/distutils/fcompiler
- numpy/distutils/tests
- numpy/distutils/tests/f2py_ext
- numpy/distutils/tests/f2py_ext/src
- numpy/distutils/tests/f2py_ext/tests
- numpy/distutils/tests/f2py_f90_ext
- numpy/distutils/tests/f2py_f90_ext/include
- numpy/distutils/tests/f2py_f90_ext/src
- numpy/distutils/tests/f2py_f90_ext/tests
- numpy/distutils/tests/gen_ext
- numpy/distutils/tests/gen_ext/tests
- numpy/distutils/tests/pyrex_ext
- numpy/distutils/tests/pyrex_ext/tests
- numpy/distutils/tests/swig_ext
- numpy/distutils/tests/swig_ext/src
- numpy/distutils/tests/swig_ext/tests
- numpy/doc
- numpy/doc/pyrex
- numpy/doc/swig
- numpy/f2py
- numpy/f2py/docs
- numpy/f2py/docs/usersguide
- numpy/f2py/src
- numpy/lib
- numpy/lib/src
- numpy/lib/tests
- numpy/linalg
- numpy/random
- numpy/random/mtrand
- numpy/testing
added
removed
numpy/linalg/blas_lite.c
1
/*
2
NOTE: This is generated code. Look in Misc/lapack_lite for information on
3
remaking this file.
4
*/
5
#include "f2c.h"
6
7
#ifdef HAVE_CONFIG
8
#include "config.h"
9
#else
10
extern doublereal dlamch_(char *);
11
#define EPSILON dlamch_("Epsilon")
12
#define SAFEMINIMUM dlamch_("Safe minimum")
13
#define PRECISION dlamch_("Precision")
14
#define BASE dlamch_("Base")
15
#endif
16
17
extern doublereal dlapy2_(doublereal *x, doublereal *y);
18
19
20
21
/* Table of constant values */
22
23
static integer c__1 = 1;
24
static doublecomplex c_b359 = {1.,0.};
25
26
/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
27
integer *incx, doublereal *dy, integer *incy)
28
{
29
/* System generated locals */
30
integer i__1;
31
32
/* Local variables */
33
static integer i__, m, ix, iy, mp1;
34
35
36
/*
37
constant times a vector plus a vector.
38
uses unrolled loops for increments equal to one.
39
jack dongarra, linpack, 3/11/78.
40
modified 12/3/93, array(1) declarations changed to array(*)
41
*/
42
43
44
/* Parameter adjustments */
45
--dy;
46
--dx;
47
48
/* Function Body */
49
if (*n <= 0) {
50
return 0;
51
}
52
if (*da == 0.) {
53
return 0;
54
}
55
if ((*incx == 1 && *incy == 1)) {
56
goto L20;
57
}
58
59
/*
60
code for unequal increments or equal increments
61
not equal to 1
62
*/
63
64
ix = 1;
65
iy = 1;
66
if (*incx < 0) {
67
ix = (-(*n) + 1) * *incx + 1;
68
}
69
if (*incy < 0) {
70
iy = (-(*n) + 1) * *incy + 1;
71
}
72
i__1 = *n;
73
for (i__ = 1; i__ <= i__1; ++i__) {
74
dy[iy] += *da * dx[ix];
75
ix += *incx;
76
iy += *incy;
77
/* L10: */
78
}
79
return 0;
80
81
/*
82
code for both increments equal to 1
83
84
85
clean-up loop
86
*/
87
88
L20:
89
m = *n % 4;
90
if (m == 0) {
91
goto L40;
92
}
93
i__1 = m;
94
for (i__ = 1; i__ <= i__1; ++i__) {
95
dy[i__] += *da * dx[i__];
96
/* L30: */
97
}
98
if (*n < 4) {
99
return 0;
100
}
101
L40:
102
mp1 = m + 1;
103
i__1 = *n;
104
for (i__ = mp1; i__ <= i__1; i__ += 4) {
105
dy[i__] += *da * dx[i__];
106
dy[i__ + 1] += *da * dx[i__ + 1];
107
dy[i__ + 2] += *da * dx[i__ + 2];
108
dy[i__ + 3] += *da * dx[i__ + 3];
109
/* L50: */
110
}
111
return 0;
112
} /* daxpy_ */
113
114
doublereal dcabs1_(doublecomplex *z__)
115
{
116
/* System generated locals */
117
doublereal ret_val;
118
static doublecomplex equiv_0[1];
119
120
/* Local variables */
121
#define t ((doublereal *)equiv_0)
122
#define zz (equiv_0)
123
124
zz->r = z__->r, zz->i = z__->i;
125
ret_val = abs(t[0]) + abs(t[1]);
126
return ret_val;
127
} /* dcabs1_ */
128
129
#undef zz
130
#undef t
131
132
133
/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
134
doublereal *dy, integer *incy)
135
{
136
/* System generated locals */
137
integer i__1;
138
139
/* Local variables */
140
static integer i__, m, ix, iy, mp1;
141
142
143
/*
144
copies a vector, x, to a vector, y.
145
uses unrolled loops for increments equal to one.
146
jack dongarra, linpack, 3/11/78.
147
modified 12/3/93, array(1) declarations changed to array(*)
148
*/
149
150
151
/* Parameter adjustments */
152
--dy;
153
--dx;
154
155
/* Function Body */
156
if (*n <= 0) {
157
return 0;
158
}
159
if ((*incx == 1 && *incy == 1)) {
160
goto L20;
161
}
162
163
/*
164
code for unequal increments or equal increments
165
not equal to 1
166
*/
167
168
ix = 1;
169
iy = 1;
170
if (*incx < 0) {
171
ix = (-(*n) + 1) * *incx + 1;
172
}
173
if (*incy < 0) {
174
iy = (-(*n) + 1) * *incy + 1;
175
}
176
i__1 = *n;
177
for (i__ = 1; i__ <= i__1; ++i__) {
178
dy[iy] = dx[ix];
179
ix += *incx;
180
iy += *incy;
181
/* L10: */
182
}
183
return 0;
184
185
/*
186
code for both increments equal to 1
187
188
189
clean-up loop
190
*/
191
192
L20:
193
m = *n % 7;
194
if (m == 0) {
195
goto L40;
196
}
197
i__1 = m;
198
for (i__ = 1; i__ <= i__1; ++i__) {
199
dy[i__] = dx[i__];
200
/* L30: */
201
}
202
if (*n < 7) {
203
return 0;
204
}
205
L40:
206
mp1 = m + 1;
207
i__1 = *n;
208
for (i__ = mp1; i__ <= i__1; i__ += 7) {
209
dy[i__] = dx[i__];
210
dy[i__ + 1] = dx[i__ + 1];
211
dy[i__ + 2] = dx[i__ + 2];
212
dy[i__ + 3] = dx[i__ + 3];
213
dy[i__ + 4] = dx[i__ + 4];
214
dy[i__ + 5] = dx[i__ + 5];
215
dy[i__ + 6] = dx[i__ + 6];
216
/* L50: */
217
}
218
return 0;
219
} /* dcopy_ */
220
221
doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
222
integer *incy)
223
{
224
/* System generated locals */
225
integer i__1;
226
doublereal ret_val;
227
228
/* Local variables */
229
static integer i__, m, ix, iy, mp1;
230
static doublereal dtemp;
231
232
233
/*
234
forms the dot product of two vectors.
235
uses unrolled loops for increments equal to one.
236
jack dongarra, linpack, 3/11/78.
237
modified 12/3/93, array(1) declarations changed to array(*)
238
*/
239
240
241
/* Parameter adjustments */
242
--dy;
243
--dx;
244
245
/* Function Body */
246
ret_val = 0.;
247
dtemp = 0.;
248
if (*n <= 0) {
249
return ret_val;
250
}
251
if ((*incx == 1 && *incy == 1)) {
252
goto L20;
253
}
254
255
/*
256
code for unequal increments or equal increments
257
not equal to 1
258
*/
259
260
ix = 1;
261
iy = 1;
262
if (*incx < 0) {
263
ix = (-(*n) + 1) * *incx + 1;
264
}
265
if (*incy < 0) {
266
iy = (-(*n) + 1) * *incy + 1;
267
}
268
i__1 = *n;
269
for (i__ = 1; i__ <= i__1; ++i__) {
270
dtemp += dx[ix] * dy[iy];
271
ix += *incx;
272
iy += *incy;
273
/* L10: */
274
}
275
ret_val = dtemp;
276
return ret_val;
277
278
/*
279
code for both increments equal to 1
280
281
282
clean-up loop
283
*/
284
285
L20:
286
m = *n % 5;
287
if (m == 0) {
288
goto L40;
289
}
290
i__1 = m;
291
for (i__ = 1; i__ <= i__1; ++i__) {
292
dtemp += dx[i__] * dy[i__];
293
/* L30: */
294
}
295
if (*n < 5) {
296
goto L60;
297
}
298
L40:
299
mp1 = m + 1;
300
i__1 = *n;
301
for (i__ = mp1; i__ <= i__1; i__ += 5) {
302
dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[
303
i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ +
304
4] * dy[i__ + 4];
305
/* L50: */
306
}
307
L60:
308
ret_val = dtemp;
309
return ret_val;
310
} /* ddot_ */
311
312
/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
313
n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
314
doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
315
integer *ldc)
316
{
317
/* System generated locals */
318
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
319
i__3;
320
321
/* Local variables */
322
static integer i__, j, l, info;
323
static logical nota, notb;
324
static doublereal temp;
325
static integer ncola;
326
extern logical lsame_(char *, char *);
327
static integer nrowa, nrowb;
328
extern /* Subroutine */ int xerbla_(char *, integer *);
329
330
331
/*
332
Purpose
333
=======
334
335
DGEMM performs one of the matrix-matrix operations
336
337
C := alpha*op( A )*op( B ) + beta*C,
338
339
where op( X ) is one of
340
341
op( X ) = X or op( X ) = X',
342
343
alpha and beta are scalars, and A, B and C are matrices, with op( A )
344
an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
345
346
Parameters
347
==========
348
349
TRANSA - CHARACTER*1.
350
On entry, TRANSA specifies the form of op( A ) to be used in
351
the matrix multiplication as follows:
352
353
TRANSA = 'N' or 'n', op( A ) = A.
354
355
TRANSA = 'T' or 't', op( A ) = A'.
356
357
TRANSA = 'C' or 'c', op( A ) = A'.
358
359
Unchanged on exit.
360
361
TRANSB - CHARACTER*1.
362
On entry, TRANSB specifies the form of op( B ) to be used in
363
the matrix multiplication as follows:
364
365
TRANSB = 'N' or 'n', op( B ) = B.
366
367
TRANSB = 'T' or 't', op( B ) = B'.
368
369
TRANSB = 'C' or 'c', op( B ) = B'.
370
371
Unchanged on exit.
372
373
M - INTEGER.
374
On entry, M specifies the number of rows of the matrix
375
op( A ) and of the matrix C. M must be at least zero.
376
Unchanged on exit.
377
378
N - INTEGER.
379
On entry, N specifies the number of columns of the matrix
380
op( B ) and the number of columns of the matrix C. N must be
381
at least zero.
382
Unchanged on exit.
383
384
K - INTEGER.
385
On entry, K specifies the number of columns of the matrix
386
op( A ) and the number of rows of the matrix op( B ). K must
387
be at least zero.
388
Unchanged on exit.
389
390
ALPHA - DOUBLE PRECISION.
391
On entry, ALPHA specifies the scalar alpha.
392
Unchanged on exit.
393
394
A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
395
k when TRANSA = 'N' or 'n', and is m otherwise.
396
Before entry with TRANSA = 'N' or 'n', the leading m by k
397
part of the array A must contain the matrix A, otherwise
398
the leading k by m part of the array A must contain the
399
matrix A.
400
Unchanged on exit.
401
402
LDA - INTEGER.
403
On entry, LDA specifies the first dimension of A as declared
404
in the calling (sub) program. When TRANSA = 'N' or 'n' then
405
LDA must be at least max( 1, m ), otherwise LDA must be at
406
least max( 1, k ).
407
Unchanged on exit.
408
409
B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
410
n when TRANSB = 'N' or 'n', and is k otherwise.
411
Before entry with TRANSB = 'N' or 'n', the leading k by n
412
part of the array B must contain the matrix B, otherwise
413
the leading n by k part of the array B must contain the
414
matrix B.
415
Unchanged on exit.
416
417
LDB - INTEGER.
418
On entry, LDB specifies the first dimension of B as declared
419
in the calling (sub) program. When TRANSB = 'N' or 'n' then
420
LDB must be at least max( 1, k ), otherwise LDB must be at
421
least max( 1, n ).
422
Unchanged on exit.
423
424
BETA - DOUBLE PRECISION.
425
On entry, BETA specifies the scalar beta. When BETA is
426
supplied as zero then C need not be set on input.
427
Unchanged on exit.
428
429
C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
430
Before entry, the leading m by n part of the array C must
431
contain the matrix C, except when beta is zero, in which
432
case C need not be set on entry.
433
On exit, the array C is overwritten by the m by n matrix
434
( alpha*op( A )*op( B ) + beta*C ).
435
436
LDC - INTEGER.
437
On entry, LDC specifies the first dimension of C as declared
438
in the calling (sub) program. LDC must be at least
439
max( 1, m ).
440
Unchanged on exit.
441
442
443
Level 3 Blas routine.
444
445
-- Written on 8-February-1989.
446
Jack Dongarra, Argonne National Laboratory.
447
Iain Duff, AERE Harwell.
448
Jeremy Du Croz, Numerical Algorithms Group Ltd.
449
Sven Hammarling, Numerical Algorithms Group Ltd.
450
451
452
Set NOTA and NOTB as true if A and B respectively are not
453
transposed and set NROWA, NCOLA and NROWB as the number of rows
454
and columns of A and the number of rows of B respectively.
455
*/
456
457
/* Parameter adjustments */
458
a_dim1 = *lda;
459
a_offset = 1 + a_dim1 * 1;
460
a -= a_offset;
461
b_dim1 = *ldb;
462
b_offset = 1 + b_dim1 * 1;
463
b -= b_offset;
464
c_dim1 = *ldc;
465
c_offset = 1 + c_dim1 * 1;
466
c__ -= c_offset;
467
468
/* Function Body */
469
nota = lsame_(transa, "N");
470
notb = lsame_(transb, "N");
471
if (nota) {
472
nrowa = *m;
473
ncola = *k;
474
} else {
475
nrowa = *k;
476
ncola = *m;
477
}
478
if (notb) {
479
nrowb = *k;
480
} else {
481
nrowb = *n;
482
}
483
484
/* Test the input parameters. */
485
486
info = 0;
487
if (((! nota && ! lsame_(transa, "C")) && ! lsame_(
488
transa, "T"))) {
489
info = 1;
490
} else if (((! notb && ! lsame_(transb, "C")) && !
491
lsame_(transb, "T"))) {
492
info = 2;
493
} else if (*m < 0) {
494
info = 3;
495
} else if (*n < 0) {
496
info = 4;
497
} else if (*k < 0) {
498
info = 5;
499
} else if (*lda < max(1,nrowa)) {
500
info = 8;
501
} else if (*ldb < max(1,nrowb)) {
502
info = 10;
503
} else if (*ldc < max(1,*m)) {
504
info = 13;
505
}
506
if (info != 0) {
507
xerbla_("DGEMM ", &info);
508
return 0;
509
}
510
511
/* Quick return if possible. */
512
513
if (*m == 0 || *n == 0 || ((*alpha == 0. || *k == 0) && *beta == 1.)) {
514
return 0;
515
}
516
517
/* And if alpha.eq.zero. */
518
519
if (*alpha == 0.) {
520
if (*beta == 0.) {
521
i__1 = *n;
522
for (j = 1; j <= i__1; ++j) {
523
i__2 = *m;
524
for (i__ = 1; i__ <= i__2; ++i__) {
525
c__[i__ + j * c_dim1] = 0.;
526
/* L10: */
527
}
528
/* L20: */
529
}
530
} else {
531
i__1 = *n;
532
for (j = 1; j <= i__1; ++j) {
533
i__2 = *m;
534
for (i__ = 1; i__ <= i__2; ++i__) {
535
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
536
/* L30: */
537
}
538
/* L40: */
539
}
540
}
541
return 0;
542
}
543
544
/* Start the operations. */
545
546
if (notb) {
547
if (nota) {
548
549
/* Form C := alpha*A*B + beta*C. */
550
551
i__1 = *n;
552
for (j = 1; j <= i__1; ++j) {
553
if (*beta == 0.) {
554
i__2 = *m;
555
for (i__ = 1; i__ <= i__2; ++i__) {
556
c__[i__ + j * c_dim1] = 0.;
557
/* L50: */
558
}
559
} else if (*beta != 1.) {
560
i__2 = *m;
561
for (i__ = 1; i__ <= i__2; ++i__) {
562
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
563
/* L60: */
564
}
565
}
566
i__2 = *k;
567
for (l = 1; l <= i__2; ++l) {
568
if (b[l + j * b_dim1] != 0.) {
569
temp = *alpha * b[l + j * b_dim1];
570
i__3 = *m;
571
for (i__ = 1; i__ <= i__3; ++i__) {
572
c__[i__ + j * c_dim1] += temp * a[i__ + l *
573
a_dim1];
574
/* L70: */
575
}
576
}
577
/* L80: */
578
}
579
/* L90: */
580
}
581
} else {
582
583
/* Form C := alpha*A'*B + beta*C */
584
585
i__1 = *n;
586
for (j = 1; j <= i__1; ++j) {
587
i__2 = *m;
588
for (i__ = 1; i__ <= i__2; ++i__) {
589
temp = 0.;
590
i__3 = *k;
591
for (l = 1; l <= i__3; ++l) {
592
temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
593
/* L100: */
594
}
595
if (*beta == 0.) {
596
c__[i__ + j * c_dim1] = *alpha * temp;
597
} else {
598
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
599
i__ + j * c_dim1];
600
}
601
/* L110: */
602
}
603
/* L120: */
604
}
605
}
606
} else {
607
if (nota) {
608
609
/* Form C := alpha*A*B' + beta*C */
610
611
i__1 = *n;
612
for (j = 1; j <= i__1; ++j) {
613
if (*beta == 0.) {
614
i__2 = *m;
615
for (i__ = 1; i__ <= i__2; ++i__) {
616
c__[i__ + j * c_dim1] = 0.;
617
/* L130: */
618
}
619
} else if (*beta != 1.) {
620
i__2 = *m;
621
for (i__ = 1; i__ <= i__2; ++i__) {
622
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
623
/* L140: */
624
}
625
}
626
i__2 = *k;
627
for (l = 1; l <= i__2; ++l) {
628
if (b[j + l * b_dim1] != 0.) {
629
temp = *alpha * b[j + l * b_dim1];
630
i__3 = *m;
631
for (i__ = 1; i__ <= i__3; ++i__) {
632
c__[i__ + j * c_dim1] += temp * a[i__ + l *
633
a_dim1];
634
/* L150: */
635
}
636
}
637
/* L160: */
638
}
639
/* L170: */
640
}
641
} else {
642
643
/* Form C := alpha*A'*B' + beta*C */
644
645
i__1 = *n;
646
for (j = 1; j <= i__1; ++j) {
647
i__2 = *m;
648
for (i__ = 1; i__ <= i__2; ++i__) {
649
temp = 0.;
650
i__3 = *k;
651
for (l = 1; l <= i__3; ++l) {
652
temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
653
/* L180: */
654
}
655
if (*beta == 0.) {
656
c__[i__ + j * c_dim1] = *alpha * temp;
657
} else {
658
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
659
i__ + j * c_dim1];
660
}
661
/* L190: */
662
}
663
/* L200: */
664
}
665
}
666
}
667
668
return 0;
669
670
/* End of DGEMM . */
671
672
} /* dgemm_ */
673
674
/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
675
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
676
doublereal *beta, doublereal *y, integer *incy)
677
{
678
/* System generated locals */
679
integer a_dim1, a_offset, i__1, i__2;
680
681
/* Local variables */
682
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
683
static doublereal temp;
684
static integer lenx, leny;
685
extern logical lsame_(char *, char *);
686
extern /* Subroutine */ int xerbla_(char *, integer *);
687
688
689
/*
690
Purpose
691
=======
692
693
DGEMV performs one of the matrix-vector operations
694
695
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
696
697
where alpha and beta are scalars, x and y are vectors and A is an
698
m by n matrix.
699
700
Parameters
701
==========
702
703
TRANS - CHARACTER*1.
704
On entry, TRANS specifies the operation to be performed as
705
follows:
706
707
TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
708
709
TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
710
711
TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
712
713
Unchanged on exit.
714
715
M - INTEGER.
716
On entry, M specifies the number of rows of the matrix A.
717
M must be at least zero.
718
Unchanged on exit.
719
720
N - INTEGER.
721
On entry, N specifies the number of columns of the matrix A.
722
N must be at least zero.
723
Unchanged on exit.
724
725
ALPHA - DOUBLE PRECISION.
726
On entry, ALPHA specifies the scalar alpha.
727
Unchanged on exit.
728
729
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
730
Before entry, the leading m by n part of the array A must
731
contain the matrix of coefficients.
732
Unchanged on exit.
733
734
LDA - INTEGER.
735
On entry, LDA specifies the first dimension of A as declared
736
in the calling (sub) program. LDA must be at least
737
max( 1, m ).
738
Unchanged on exit.
739
740
X - DOUBLE PRECISION array of DIMENSION at least
741
( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
742
and at least
743
( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
744
Before entry, the incremented array X must contain the
745
vector x.
746
Unchanged on exit.
747
748
INCX - INTEGER.
749
On entry, INCX specifies the increment for the elements of
750
X. INCX must not be zero.
751
Unchanged on exit.
752
753
BETA - DOUBLE PRECISION.
754
On entry, BETA specifies the scalar beta. When BETA is
755
supplied as zero then Y need not be set on input.
756
Unchanged on exit.
757
758
Y - DOUBLE PRECISION array of DIMENSION at least
759
( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
760
and at least
761
( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
762
Before entry with BETA non-zero, the incremented array Y
763
must contain the vector y. On exit, Y is overwritten by the
764
updated vector y.
765
766
INCY - INTEGER.
767
On entry, INCY specifies the increment for the elements of
768
Y. INCY must not be zero.
769
Unchanged on exit.
770
771
772
Level 2 Blas routine.
773
774
-- Written on 22-October-1986.
775
Jack Dongarra, Argonne National Lab.
776
Jeremy Du Croz, Nag Central Office.
777
Sven Hammarling, Nag Central Office.
778
Richard Hanson, Sandia National Labs.
779
780
781
Test the input parameters.
782
*/
783
784
/* Parameter adjustments */
785
a_dim1 = *lda;
786
a_offset = 1 + a_dim1 * 1;
787
a -= a_offset;
788
--x;
789
--y;
790
791
/* Function Body */
792
info = 0;
793
if (((! lsame_(trans, "N") && ! lsame_(trans, "T")) && ! lsame_(trans, "C"))) {
794
info = 1;
795
} else if (*m < 0) {
796
info = 2;
797
} else if (*n < 0) {
798
info = 3;
799
} else if (*lda < max(1,*m)) {
800
info = 6;
801
} else if (*incx == 0) {
802
info = 8;
803
} else if (*incy == 0) {
804
info = 11;
805
}
806
if (info != 0) {
807
xerbla_("DGEMV ", &info);
808
return 0;
809
}
810
811
/* Quick return if possible. */
812
813
if (*m == 0 || *n == 0 || (*alpha == 0. && *beta == 1.)) {
814
return 0;
815
}
816
817
/*
818
Set LENX and LENY, the lengths of the vectors x and y, and set
819
up the start points in X and Y.
820
*/
821
822
if (lsame_(trans, "N")) {
823
lenx = *n;
824
leny = *m;
825
} else {
826
lenx = *m;
827
leny = *n;
828
}
829
if (*incx > 0) {
830
kx = 1;
831
} else {
832
kx = 1 - (lenx - 1) * *incx;
833
}
834
if (*incy > 0) {
835
ky = 1;
836
} else {
837
ky = 1 - (leny - 1) * *incy;
838
}
839
840
/*
841
Start the operations. In this version the elements of A are
842
accessed sequentially with one pass through A.
843
844
First form y := beta*y.
845
*/
846
847
if (*beta != 1.) {
848
if (*incy == 1) {
849
if (*beta == 0.) {
850
i__1 = leny;
851
for (i__ = 1; i__ <= i__1; ++i__) {
852
y[i__] = 0.;
853
/* L10: */
854
}
855
} else {
856
i__1 = leny;
857
for (i__ = 1; i__ <= i__1; ++i__) {
858
y[i__] = *beta * y[i__];
859
/* L20: */
860
}
861
}
862
} else {
863
iy = ky;
864
if (*beta == 0.) {
865
i__1 = leny;
866
for (i__ = 1; i__ <= i__1; ++i__) {
867
y[iy] = 0.;
868
iy += *incy;
869
/* L30: */
870
}
871
} else {
872
i__1 = leny;
873
for (i__ = 1; i__ <= i__1; ++i__) {
874
y[iy] = *beta * y[iy];
875
iy += *incy;
876
/* L40: */
877
}
878
}
879
}
880
}
881
if (*alpha == 0.) {
882
return 0;
883
}
884
if (lsame_(trans, "N")) {
885
886
/* Form y := alpha*A*x + y. */
887
888
jx = kx;
889
if (*incy == 1) {
890
i__1 = *n;
891
for (j = 1; j <= i__1; ++j) {
892
if (x[jx] != 0.) {
893
temp = *alpha * x[jx];
894
i__2 = *m;
895
for (i__ = 1; i__ <= i__2; ++i__) {
896
y[i__] += temp * a[i__ + j * a_dim1];
897
/* L50: */
898
}
899
}
900
jx += *incx;
901
/* L60: */
902
}
903
} else {
904
i__1 = *n;
905
for (j = 1; j <= i__1; ++j) {
906
if (x[jx] != 0.) {
907
temp = *alpha * x[jx];
908
iy = ky;
909
i__2 = *m;
910
for (i__ = 1; i__ <= i__2; ++i__) {
911
y[iy] += temp * a[i__ + j * a_dim1];
912
iy += *incy;
913
/* L70: */
914
}
915
}
916
jx += *incx;
917
/* L80: */
918
}
919
}
920
} else {
921
922
/* Form y := alpha*A'*x + y. */
923
924
jy = ky;
925
if (*incx == 1) {
926
i__1 = *n;
927
for (j = 1; j <= i__1; ++j) {
928
temp = 0.;
929
i__2 = *m;
930
for (i__ = 1; i__ <= i__2; ++i__) {
931
temp += a[i__ + j * a_dim1] * x[i__];
932
/* L90: */
933
}
934
y[jy] += *alpha * temp;
935
jy += *incy;
936
/* L100: */
937
}
938
} else {
939
i__1 = *n;
940
for (j = 1; j <= i__1; ++j) {
941
temp = 0.;
942
ix = kx;
943
i__2 = *m;
944
for (i__ = 1; i__ <= i__2; ++i__) {
945
temp += a[i__ + j * a_dim1] * x[ix];
946
ix += *incx;
947
/* L110: */
948
}
949
y[jy] += *alpha * temp;
950
jy += *incy;
951
/* L120: */
952
}
953
}
954
}
955
956
return 0;
957
958
/* End of DGEMV . */
959
960
} /* dgemv_ */
961
962
/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
963
doublereal *x, integer *incx, doublereal *y, integer *incy,
964
doublereal *a, integer *lda)
965
{
966
/* System generated locals */
967
integer a_dim1, a_offset, i__1, i__2;
968
969
/* Local variables */
970
static integer i__, j, ix, jy, kx, info;
971
static doublereal temp;
972
extern /* Subroutine */ int xerbla_(char *, integer *);
973
974
975
/*
976
Purpose
977
=======
978
979
DGER performs the rank 1 operation
980
981
A := alpha*x*y' + A,
982
983
where alpha is a scalar, x is an m element vector, y is an n element
984
vector and A is an m by n matrix.
985
986
Parameters
987
==========
988
989
M - INTEGER.
990
On entry, M specifies the number of rows of the matrix A.
991
M must be at least zero.
992
Unchanged on exit.
993
994
N - INTEGER.
995
On entry, N specifies the number of columns of the matrix A.
996
N must be at least zero.
997
Unchanged on exit.
998
999
ALPHA - DOUBLE PRECISION.
1000
On entry, ALPHA specifies the scalar alpha.
1001
Unchanged on exit.
1002
1003
X - DOUBLE PRECISION array of dimension at least
1004
( 1 + ( m - 1 )*abs( INCX ) ).
1005
Before entry, the incremented array X must contain the m
1006
element vector x.
1007
Unchanged on exit.
1008
1009
INCX - INTEGER.
1010
On entry, INCX specifies the increment for the elements of
1011
X. INCX must not be zero.
1012
Unchanged on exit.
1013
1014
Y - DOUBLE PRECISION array of dimension at least
1015
( 1 + ( n - 1 )*abs( INCY ) ).
1016
Before entry, the incremented array Y must contain the n
1017
element vector y.
1018
Unchanged on exit.
1019
1020
INCY - INTEGER.
1021
On entry, INCY specifies the increment for the elements of
1022
Y. INCY must not be zero.
1023
Unchanged on exit.
1024
1025
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
1026
Before entry, the leading m by n part of the array A must
1027
contain the matrix of coefficients. On exit, A is
1028
overwritten by the updated matrix.
1029
1030
LDA - INTEGER.
1031
On entry, LDA specifies the first dimension of A as declared
1032
in the calling (sub) program. LDA must be at least
1033
max( 1, m ).
1034
Unchanged on exit.
1035
1036
1037
Level 2 Blas routine.
1038
1039
-- Written on 22-October-1986.
1040
Jack Dongarra, Argonne National Lab.
1041
Jeremy Du Croz, Nag Central Office.
1042
Sven Hammarling, Nag Central Office.
1043
Richard Hanson, Sandia National Labs.
1044
1045
1046
Test the input parameters.
1047
*/
1048
1049
/* Parameter adjustments */
1050
--x;
1051
--y;
1052
a_dim1 = *lda;
1053
a_offset = 1 + a_dim1 * 1;
1054
a -= a_offset;
1055
1056
/* Function Body */
1057
info = 0;
1058
if (*m < 0) {
1059
info = 1;
1060
} else if (*n < 0) {
1061
info = 2;
1062
} else if (*incx == 0) {
1063
info = 5;
1064
} else if (*incy == 0) {
1065
info = 7;
1066
} else if (*lda < max(1,*m)) {
1067
info = 9;
1068
}
1069
if (info != 0) {
1070
xerbla_("DGER ", &info);
1071
return 0;
1072
}
1073
1074
/* Quick return if possible. */
1075
1076
if (*m == 0 || *n == 0 || *alpha == 0.) {
1077
return 0;
1078
}
1079
1080
/*
1081
Start the operations. In this version the elements of A are
1082
accessed sequentially with one pass through A.
1083
*/
1084
1085
if (*incy > 0) {
1086
jy = 1;
1087
} else {
1088
jy = 1 - (*n - 1) * *incy;
1089
}
1090
if (*incx == 1) {
1091
i__1 = *n;
1092
for (j = 1; j <= i__1; ++j) {
1093
if (y[jy] != 0.) {
1094
temp = *alpha * y[jy];
1095
i__2 = *m;
1096
for (i__ = 1; i__ <= i__2; ++i__) {
1097
a[i__ + j * a_dim1] += x[i__] * temp;
1098
/* L10: */
1099
}
1100
}
1101
jy += *incy;
1102
/* L20: */
1103
}
1104
} else {
1105
if (*incx > 0) {
1106
kx = 1;
1107
} else {
1108
kx = 1 - (*m - 1) * *incx;
1109
}
1110
i__1 = *n;
1111
for (j = 1; j <= i__1; ++j) {
1112
if (y[jy] != 0.) {
1113
temp = *alpha * y[jy];
1114
ix = kx;
1115
i__2 = *m;
1116
for (i__ = 1; i__ <= i__2; ++i__) {
1117
a[i__ + j * a_dim1] += x[ix] * temp;
1118
ix += *incx;
1119
/* L30: */
1120
}
1121
}
1122
jy += *incy;
1123
/* L40: */
1124
}
1125
}
1126
1127
return 0;
1128
1129
/* End of DGER . */
1130
1131
} /* dger_ */
1132
1133
doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
1134
{
1135
/* System generated locals */
1136
integer i__1, i__2;
1137
doublereal ret_val, d__1;
1138
1139
/* Builtin functions */
1140
double sqrt(doublereal);
1141
1142
/* Local variables */
1143
static integer ix;
1144
static doublereal ssq, norm, scale, absxi;
1145
1146
1147
/*
1148
DNRM2 returns the euclidean norm of a vector via the function
1149
name, so that
1150
1151
DNRM2 := sqrt( x'*x )
1152
1153
1154
-- This version written on 25-October-1982.
1155
Modified on 14-October-1993 to inline the call to DLASSQ.
1156
Sven Hammarling, Nag Ltd.
1157
*/
1158
1159
1160
/* Parameter adjustments */
1161
--x;
1162
1163
/* Function Body */
1164
if (*n < 1 || *incx < 1) {
1165
norm = 0.;
1166
} else if (*n == 1) {
1167
norm = abs(x[1]);
1168
} else {
1169
scale = 0.;
1170
ssq = 1.;
1171
/*
1172
The following loop is equivalent to this call to the LAPACK
1173
auxiliary routine:
1174
CALL DLASSQ( N, X, INCX, SCALE, SSQ )
1175
*/
1176
1177
i__1 = (*n - 1) * *incx + 1;
1178
i__2 = *incx;
1179
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
1180
if (x[ix] != 0.) {
1181
absxi = (d__1 = x[ix], abs(d__1));
1182
if (scale < absxi) {
1183
/* Computing 2nd power */
1184
d__1 = scale / absxi;
1185
ssq = ssq * (d__1 * d__1) + 1.;
1186
scale = absxi;
1187
} else {
1188
/* Computing 2nd power */
1189
d__1 = absxi / scale;
1190
ssq += d__1 * d__1;
1191
}
1192
}
1193
/* L10: */
1194
}
1195
norm = scale * sqrt(ssq);
1196
}
1197
1198
ret_val = norm;
1199
return ret_val;
1200
1201
/* End of DNRM2. */
1202
1203
} /* dnrm2_ */
1204
1205
/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx,
1206
doublereal *dy, integer *incy, doublereal *c__, doublereal *s)
1207
{
1208
/* System generated locals */
1209
integer i__1;
1210
1211
/* Local variables */
1212
static integer i__, ix, iy;
1213
static doublereal dtemp;
1214
1215
1216
/*
1217
applies a plane rotation.
1218
jack dongarra, linpack, 3/11/78.
1219
modified 12/3/93, array(1) declarations changed to array(*)
1220
*/
1221
1222
1223
/* Parameter adjustments */
1224
--dy;
1225
--dx;
1226
1227
/* Function Body */
1228
if (*n <= 0) {
1229
return 0;
1230
}
1231
if ((*incx == 1 && *incy == 1)) {
1232
goto L20;
1233
}
1234
1235
/*
1236
code for unequal increments or equal increments not equal
1237
to 1
1238
*/
1239
1240
ix = 1;
1241
iy = 1;
1242
if (*incx < 0) {
1243
ix = (-(*n) + 1) * *incx + 1;
1244
}
1245
if (*incy < 0) {
1246
iy = (-(*n) + 1) * *incy + 1;
1247
}
1248
i__1 = *n;
1249
for (i__ = 1; i__ <= i__1; ++i__) {
1250
dtemp = *c__ * dx[ix] + *s * dy[iy];
1251
dy[iy] = *c__ * dy[iy] - *s * dx[ix];
1252
dx[ix] = dtemp;
1253
ix += *incx;
1254
iy += *incy;
1255
/* L10: */
1256
}
1257
return 0;
1258
1259
/* code for both increments equal to 1 */
1260
1261
L20:
1262
i__1 = *n;
1263
for (i__ = 1; i__ <= i__1; ++i__) {
1264
dtemp = *c__ * dx[i__] + *s * dy[i__];
1265
dy[i__] = *c__ * dy[i__] - *s * dx[i__];
1266
dx[i__] = dtemp;
1267
/* L30: */
1268
}
1269
return 0;
1270
} /* drot_ */
1271
1272
/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx,
1273
integer *incx)
1274
{
1275
/* System generated locals */
1276
integer i__1, i__2;
1277
1278
/* Local variables */
1279
static integer i__, m, mp1, nincx;
1280
1281
1282
/*
1283
scales a vector by a constant.
1284
uses unrolled loops for increment equal to one.
1285
jack dongarra, linpack, 3/11/78.
1286
modified 3/93 to return if incx .le. 0.
1287
modified 12/3/93, array(1) declarations changed to array(*)
1288
*/
1289
1290
1291
/* Parameter adjustments */
1292
--dx;
1293
1294
/* Function Body */
1295
if (*n <= 0 || *incx <= 0) {
1296
return 0;
1297
}
1298
if (*incx == 1) {
1299
goto L20;
1300
}
1301
1302
/* code for increment not equal to 1 */
1303
1304
nincx = *n * *incx;
1305
i__1 = nincx;
1306
i__2 = *incx;
1307
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
1308
dx[i__] = *da * dx[i__];
1309
/* L10: */
1310
}
1311
return 0;
1312
1313
/*
1314
code for increment equal to 1
1315
1316
1317
clean-up loop
1318
*/
1319
1320
L20:
1321
m = *n % 5;
1322
if (m == 0) {
1323
goto L40;
1324
}
1325
i__2 = m;
1326
for (i__ = 1; i__ <= i__2; ++i__) {
1327
dx[i__] = *da * dx[i__];
1328
/* L30: */
1329
}
1330
if (*n < 5) {
1331
return 0;
1332
}
1333
L40:
1334
mp1 = m + 1;
1335
i__2 = *n;
1336
for (i__ = mp1; i__ <= i__2; i__ += 5) {
1337
dx[i__] = *da * dx[i__];
1338
dx[i__ + 1] = *da * dx[i__ + 1];
1339
dx[i__ + 2] = *da * dx[i__ + 2];
1340
dx[i__ + 3] = *da * dx[i__ + 3];
1341
dx[i__ + 4] = *da * dx[i__ + 4];
1342
/* L50: */
1343
}
1344
return 0;
1345
} /* dscal_ */
1346
1347
/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx,
1348
doublereal *dy, integer *incy)
1349
{
1350
/* System generated locals */
1351
integer i__1;
1352
1353
/* Local variables */
1354
static integer i__, m, ix, iy, mp1;
1355
static doublereal dtemp;
1356
1357
1358
/*
1359
interchanges two vectors.
1360
uses unrolled loops for increments equal one.
1361
jack dongarra, linpack, 3/11/78.
1362
modified 12/3/93, array(1) declarations changed to array(*)
1363
*/
1364
1365
1366
/* Parameter adjustments */
1367
--dy;
1368
--dx;
1369
1370
/* Function Body */
1371
if (*n <= 0) {
1372
return 0;
1373
}
1374
if ((*incx == 1 && *incy == 1)) {
1375
goto L20;
1376
}
1377
1378
/*
1379
code for unequal increments or equal increments not equal
1380
to 1
1381
*/
1382
1383
ix = 1;
1384
iy = 1;
1385
if (*incx < 0) {
1386
ix = (-(*n) + 1) * *incx + 1;
1387
}
1388
if (*incy < 0) {
1389
iy = (-(*n) + 1) * *incy + 1;
1390
}
1391
i__1 = *n;
1392
for (i__ = 1; i__ <= i__1; ++i__) {
1393
dtemp = dx[ix];
1394
dx[ix] = dy[iy];
1395
dy[iy] = dtemp;
1396
ix += *incx;
1397
iy += *incy;
1398
/* L10: */
1399
}
1400
return 0;
1401
1402
/*
1403
code for both increments equal to 1
1404
1405
1406
clean-up loop
1407
*/
1408
1409
L20:
1410
m = *n % 3;
1411
if (m == 0) {
1412
goto L40;
1413
}
1414
i__1 = m;
1415
for (i__ = 1; i__ <= i__1; ++i__) {
1416
dtemp = dx[i__];
1417
dx[i__] = dy[i__];
1418
dy[i__] = dtemp;
1419
/* L30: */
1420
}
1421
if (*n < 3) {
1422
return 0;
1423
}
1424
L40:
1425
mp1 = m + 1;
1426
i__1 = *n;
1427
for (i__ = mp1; i__ <= i__1; i__ += 3) {
1428
dtemp = dx[i__];
1429
dx[i__] = dy[i__];
1430
dy[i__] = dtemp;
1431
dtemp = dx[i__ + 1];
1432
dx[i__ + 1] = dy[i__ + 1];
1433
dy[i__ + 1] = dtemp;
1434
dtemp = dx[i__ + 2];
1435
dx[i__ + 2] = dy[i__ + 2];
1436
dy[i__ + 2] = dtemp;
1437
/* L50: */
1438
}
1439
return 0;
1440
} /* dswap_ */
1441
1442
/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha,
1443
doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal
1444
*beta, doublereal *y, integer *incy)
1445
{
1446
/* System generated locals */
1447
integer a_dim1, a_offset, i__1, i__2;
1448
1449
/* Local variables */
1450
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
1451
static doublereal temp1, temp2;
1452
extern logical lsame_(char *, char *);
1453
extern /* Subroutine */ int xerbla_(char *, integer *);
1454
1455
1456
/*
1457
Purpose
1458
=======
1459
1460
DSYMV performs the matrix-vector operation
1461
1462
y := alpha*A*x + beta*y,
1463
1464
where alpha and beta are scalars, x and y are n element vectors and
1465
A is an n by n symmetric matrix.
1466
1467
Parameters
1468
==========
1469
1470
UPLO - CHARACTER*1.
1471
On entry, UPLO specifies whether the upper or lower
1472
triangular part of the array A is to be referenced as
1473
follows:
1474
1475
UPLO = 'U' or 'u' Only the upper triangular part of A
1476
is to be referenced.
1477
1478
UPLO = 'L' or 'l' Only the lower triangular part of A
1479
is to be referenced.
1480
1481
Unchanged on exit.
1482
1483
N - INTEGER.
1484
On entry, N specifies the order of the matrix A.
1485
N must be at least zero.
1486
Unchanged on exit.
1487
1488
ALPHA - DOUBLE PRECISION.
1489
On entry, ALPHA specifies the scalar alpha.
1490
Unchanged on exit.
1491
1492
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
1493
Before entry with UPLO = 'U' or 'u', the leading n by n
1494
upper triangular part of the array A must contain the upper
1495
triangular part of the symmetric matrix and the strictly
1496
lower triangular part of A is not referenced.
1497
Before entry with UPLO = 'L' or 'l', the leading n by n
1498
lower triangular part of the array A must contain the lower
1499
triangular part of the symmetric matrix and the strictly
1500
upper triangular part of A is not referenced.
1501
Unchanged on exit.
1502
1503
LDA - INTEGER.
1504
On entry, LDA specifies the first dimension of A as declared
1505
in the calling (sub) program. LDA must be at least
1506
max( 1, n ).
1507
Unchanged on exit.
1508
1509
X - DOUBLE PRECISION array of dimension at least
1510
( 1 + ( n - 1 )*abs( INCX ) ).
1511
Before entry, the incremented array X must contain the n
1512
element vector x.
1513
Unchanged on exit.
1514
1515
INCX - INTEGER.
1516
On entry, INCX specifies the increment for the elements of
1517
X. INCX must not be zero.
1518
Unchanged on exit.
1519
1520
BETA - DOUBLE PRECISION.
1521
On entry, BETA specifies the scalar beta. When BETA is
1522
supplied as zero then Y need not be set on input.
1523
Unchanged on exit.
1524
1525
Y - DOUBLE PRECISION array of dimension at least
1526
( 1 + ( n - 1 )*abs( INCY ) ).
1527
Before entry, the incremented array Y must contain the n
1528
element vector y. On exit, Y is overwritten by the updated
1529
vector y.
1530
1531
INCY - INTEGER.
1532
On entry, INCY specifies the increment for the elements of
1533
Y. INCY must not be zero.
1534
Unchanged on exit.
1535
1536
1537
Level 2 Blas routine.
1538
1539
-- Written on 22-October-1986.
1540
Jack Dongarra, Argonne National Lab.
1541
Jeremy Du Croz, Nag Central Office.
1542
Sven Hammarling, Nag Central Office.
1543
Richard Hanson, Sandia National Labs.
1544
1545
1546
Test the input parameters.
1547
*/
1548
1549
/* Parameter adjustments */
1550
a_dim1 = *lda;
1551
a_offset = 1 + a_dim1 * 1;
1552
a -= a_offset;
1553
--x;
1554
--y;
1555
1556
/* Function Body */
1557
info = 0;
1558
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
1559
info = 1;
1560
} else if (*n < 0) {
1561
info = 2;
1562
} else if (*lda < max(1,*n)) {
1563
info = 5;
1564
} else if (*incx == 0) {
1565
info = 7;
1566
} else if (*incy == 0) {
1567
info = 10;
1568
}
1569
if (info != 0) {
1570
xerbla_("DSYMV ", &info);
1571
return 0;
1572
}
1573
1574
/* Quick return if possible. */
1575
1576
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
1577
return 0;
1578
}
1579
1580
/* Set up the start points in X and Y. */
1581
1582
if (*incx > 0) {
1583
kx = 1;
1584
} else {
1585
kx = 1 - (*n - 1) * *incx;
1586
}
1587
if (*incy > 0) {
1588
ky = 1;
1589
} else {
1590
ky = 1 - (*n - 1) * *incy;
1591
}
1592
1593
/*
1594
Start the operations. In this version the elements of A are
1595
accessed sequentially with one pass through the triangular part
1596
of A.
1597
1598
First form y := beta*y.
1599
*/
1600
1601
if (*beta != 1.) {
1602
if (*incy == 1) {
1603
if (*beta == 0.) {
1604
i__1 = *n;
1605
for (i__ = 1; i__ <= i__1; ++i__) {
1606
y[i__] = 0.;
1607
/* L10: */
1608
}
1609
} else {
1610
i__1 = *n;
1611
for (i__ = 1; i__ <= i__1; ++i__) {
1612
y[i__] = *beta * y[i__];
1613
/* L20: */
1614
}
1615
}
1616
} else {
1617
iy = ky;
1618
if (*beta == 0.) {
1619
i__1 = *n;
1620
for (i__ = 1; i__ <= i__1; ++i__) {
1621
y[iy] = 0.;
1622
iy += *incy;
1623
/* L30: */
1624
}
1625
} else {
1626
i__1 = *n;
1627
for (i__ = 1; i__ <= i__1; ++i__) {
1628
y[iy] = *beta * y[iy];
1629
iy += *incy;
1630
/* L40: */
1631
}
1632
}
1633
}
1634
}
1635
if (*alpha == 0.) {
1636
return 0;
1637
}
1638
if (lsame_(uplo, "U")) {
1639
1640
/* Form y when A is stored in upper triangle. */
1641
1642
if ((*incx == 1 && *incy == 1)) {
1643
i__1 = *n;
1644
for (j = 1; j <= i__1; ++j) {
1645
temp1 = *alpha * x[j];
1646
temp2 = 0.;
1647
i__2 = j - 1;
1648
for (i__ = 1; i__ <= i__2; ++i__) {
1649
y[i__] += temp1 * a[i__ + j * a_dim1];
1650
temp2 += a[i__ + j * a_dim1] * x[i__];
1651
/* L50: */
1652
}
1653
y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
1654
/* L60: */
1655
}
1656
} else {
1657
jx = kx;
1658
jy = ky;
1659
i__1 = *n;
1660
for (j = 1; j <= i__1; ++j) {
1661
temp1 = *alpha * x[jx];
1662
temp2 = 0.;
1663
ix = kx;
1664
iy = ky;
1665
i__2 = j - 1;
1666
for (i__ = 1; i__ <= i__2; ++i__) {
1667
y[iy] += temp1 * a[i__ + j * a_dim1];
1668
temp2 += a[i__ + j * a_dim1] * x[ix];
1669
ix += *incx;
1670
iy += *incy;
1671
/* L70: */
1672
}
1673
y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
1674
jx += *incx;
1675
jy += *incy;
1676
/* L80: */
1677
}
1678
}
1679
} else {
1680
1681
/* Form y when A is stored in lower triangle. */
1682
1683
if ((*incx == 1 && *incy == 1)) {
1684
i__1 = *n;
1685
for (j = 1; j <= i__1; ++j) {
1686
temp1 = *alpha * x[j];
1687
temp2 = 0.;
1688
y[j] += temp1 * a[j + j * a_dim1];
1689
i__2 = *n;
1690
for (i__ = j + 1; i__ <= i__2; ++i__) {
1691
y[i__] += temp1 * a[i__ + j * a_dim1];
1692
temp2 += a[i__ + j * a_dim1] * x[i__];
1693
/* L90: */
1694
}
1695
y[j] += *alpha * temp2;
1696
/* L100: */
1697
}
1698
} else {
1699
jx = kx;
1700
jy = ky;
1701
i__1 = *n;
1702
for (j = 1; j <= i__1; ++j) {
1703
temp1 = *alpha * x[jx];
1704
temp2 = 0.;
1705
y[jy] += temp1 * a[j + j * a_dim1];
1706
ix = jx;
1707
iy = jy;
1708
i__2 = *n;
1709
for (i__ = j + 1; i__ <= i__2; ++i__) {
1710
ix += *incx;
1711
iy += *incy;
1712
y[iy] += temp1 * a[i__ + j * a_dim1];
1713
temp2 += a[i__ + j * a_dim1] * x[ix];
1714
/* L110: */
1715
}
1716
y[jy] += *alpha * temp2;
1717
jx += *incx;
1718
jy += *incy;
1719
/* L120: */
1720
}
1721
}
1722
}
1723
1724
return 0;
1725
1726
/* End of DSYMV . */
1727
1728
} /* dsymv_ */
1729
1730
/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha,
1731
doublereal *x, integer *incx, doublereal *y, integer *incy,
1732
doublereal *a, integer *lda)
1733
{
1734
/* System generated locals */
1735
integer a_dim1, a_offset, i__1, i__2;
1736
1737
/* Local variables */
1738
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
1739
static doublereal temp1, temp2;
1740
extern logical lsame_(char *, char *);
1741
extern /* Subroutine */ int xerbla_(char *, integer *);
1742
1743
1744
/*
1745
Purpose
1746
=======
1747
1748
DSYR2 performs the symmetric rank 2 operation
1749
1750
A := alpha*x*y' + alpha*y*x' + A,
1751
1752
where alpha is a scalar, x and y are n element vectors and A is an n
1753
by n symmetric matrix.
1754
1755
Parameters
1756
==========
1757
1758
UPLO - CHARACTER*1.
1759
On entry, UPLO specifies whether the upper or lower
1760
triangular part of the array A is to be referenced as
1761
follows:
1762
1763
UPLO = 'U' or 'u' Only the upper triangular part of A
1764
is to be referenced.
1765
1766
UPLO = 'L' or 'l' Only the lower triangular part of A
1767
is to be referenced.
1768
1769
Unchanged on exit.
1770
1771
N - INTEGER.
1772
On entry, N specifies the order of the matrix A.
1773
N must be at least zero.
1774
Unchanged on exit.
1775
1776
ALPHA - DOUBLE PRECISION.
1777
On entry, ALPHA specifies the scalar alpha.
1778
Unchanged on exit.
1779
1780
X - DOUBLE PRECISION array of dimension at least
1781
( 1 + ( n - 1 )*abs( INCX ) ).
1782
Before entry, the incremented array X must contain the n
1783
element vector x.
1784
Unchanged on exit.
1785
1786
INCX - INTEGER.
1787
On entry, INCX specifies the increment for the elements of
1788
X. INCX must not be zero.
1789
Unchanged on exit.
1790
1791
Y - DOUBLE PRECISION array of dimension at least
1792
( 1 + ( n - 1 )*abs( INCY ) ).
1793
Before entry, the incremented array Y must contain the n
1794
element vector y.
1795
Unchanged on exit.
1796
1797
INCY - INTEGER.
1798
On entry, INCY specifies the increment for the elements of
1799
Y. INCY must not be zero.
1800
Unchanged on exit.
1801
1802
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
1803
Before entry with UPLO = 'U' or 'u', the leading n by n
1804
upper triangular part of the array A must contain the upper
1805
triangular part of the symmetric matrix and the strictly
1806
lower triangular part of A is not referenced. On exit, the
1807
upper triangular part of the array A is overwritten by the
1808
upper triangular part of the updated matrix.
1809
Before entry with UPLO = 'L' or 'l', the leading n by n
1810
lower triangular part of the array A must contain the lower
1811
triangular part of the symmetric matrix and the strictly
1812
upper triangular part of A is not referenced. On exit, the
1813
lower triangular part of the array A is overwritten by the
1814
lower triangular part of the updated matrix.
1815
1816
LDA - INTEGER.
1817
On entry, LDA specifies the first dimension of A as declared
1818
in the calling (sub) program. LDA must be at least
1819
max( 1, n ).
1820
Unchanged on exit.
1821
1822
1823
Level 2 Blas routine.
1824
1825
-- Written on 22-October-1986.
1826
Jack Dongarra, Argonne National Lab.
1827
Jeremy Du Croz, Nag Central Office.
1828
Sven Hammarling, Nag Central Office.
1829
Richard Hanson, Sandia National Labs.
1830
1831
1832
Test the input parameters.
1833
*/
1834
1835
/* Parameter adjustments */
1836
--x;
1837
--y;
1838
a_dim1 = *lda;
1839
a_offset = 1 + a_dim1 * 1;
1840
a -= a_offset;
1841
1842
/* Function Body */
1843
info = 0;
1844
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
1845
info = 1;
1846
} else if (*n < 0) {
1847
info = 2;
1848
} else if (*incx == 0) {
1849
info = 5;
1850
} else if (*incy == 0) {
1851
info = 7;
1852
} else if (*lda < max(1,*n)) {
1853
info = 9;
1854
}
1855
if (info != 0) {
1856
xerbla_("DSYR2 ", &info);
1857
return 0;
1858
}
1859
1860
/* Quick return if possible. */
1861
1862
if (*n == 0 || *alpha == 0.) {
1863
return 0;
1864
}
1865
1866
/*
1867
Set up the start points in X and Y if the increments are not both
1868
unity.
1869
*/
1870
1871
if (*incx != 1 || *incy != 1) {
1872
if (*incx > 0) {
1873
kx = 1;
1874
} else {
1875
kx = 1 - (*n - 1) * *incx;
1876
}
1877
if (*incy > 0) {
1878
ky = 1;
1879
} else {
1880
ky = 1 - (*n - 1) * *incy;
1881
}
1882
jx = kx;
1883
jy = ky;
1884
}
1885
1886
/*
1887
Start the operations. In this version the elements of A are
1888
accessed sequentially with one pass through the triangular part
1889
of A.
1890
*/
1891
1892
if (lsame_(uplo, "U")) {
1893
1894
/* Form A when A is stored in the upper triangle. */
1895
1896
if ((*incx == 1 && *incy == 1)) {
1897
i__1 = *n;
1898
for (j = 1; j <= i__1; ++j) {
1899
if (x[j] != 0. || y[j] != 0.) {
1900
temp1 = *alpha * y[j];
1901
temp2 = *alpha * x[j];
1902
i__2 = j;
1903
for (i__ = 1; i__ <= i__2; ++i__) {
1904
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
1905
temp1 + y[i__] * temp2;
1906
/* L10: */
1907
}
1908
}
1909
/* L20: */
1910
}
1911
} else {
1912
i__1 = *n;
1913
for (j = 1; j <= i__1; ++j) {
1914
if (x[jx] != 0. || y[jy] != 0.) {
1915
temp1 = *alpha * y[jy];
1916
temp2 = *alpha * x[jx];
1917
ix = kx;
1918
iy = ky;
1919
i__2 = j;
1920
for (i__ = 1; i__ <= i__2; ++i__) {
1921
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
1922
temp1 + y[iy] * temp2;
1923
ix += *incx;
1924
iy += *incy;
1925
/* L30: */
1926
}
1927
}
1928
jx += *incx;
1929
jy += *incy;
1930
/* L40: */
1931
}
1932
}
1933
} else {
1934
1935
/* Form A when A is stored in the lower triangle. */
1936
1937
if ((*incx == 1 && *incy == 1)) {
1938
i__1 = *n;
1939
for (j = 1; j <= i__1; ++j) {
1940
if (x[j] != 0. || y[j] != 0.) {
1941
temp1 = *alpha * y[j];
1942
temp2 = *alpha * x[j];
1943
i__2 = *n;
1944
for (i__ = j; i__ <= i__2; ++i__) {
1945
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
1946
temp1 + y[i__] * temp2;
1947
/* L50: */
1948
}
1949
}
1950
/* L60: */
1951
}
1952
} else {
1953
i__1 = *n;
1954
for (j = 1; j <= i__1; ++j) {
1955
if (x[jx] != 0. || y[jy] != 0.) {
1956
temp1 = *alpha * y[jy];
1957
temp2 = *alpha * x[jx];
1958
ix = jx;
1959
iy = jy;
1960
i__2 = *n;
1961
for (i__ = j; i__ <= i__2; ++i__) {
1962
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
1963
temp1 + y[iy] * temp2;
1964
ix += *incx;
1965
iy += *incy;
1966
/* L70: */
1967
}
1968
}
1969
jx += *incx;
1970
jy += *incy;
1971
/* L80: */
1972
}
1973
}
1974
}
1975
1976
return 0;
1977
1978
/* End of DSYR2 . */
1979
1980
} /* dsyr2_ */
1981
1982
/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k,
1983
doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
1984
integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
1985
{
1986
/* System generated locals */
1987
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
1988
i__3;
1989
1990
/* Local variables */
1991
static integer i__, j, l, info;
1992
static doublereal temp1, temp2;
1993
extern logical lsame_(char *, char *);
1994
static integer nrowa;
1995
static logical upper;
1996
extern /* Subroutine */ int xerbla_(char *, integer *);
1997
1998
1999
/*
2000
Purpose
2001
=======
2002
2003
DSYR2K performs one of the symmetric rank 2k operations
2004
2005
C := alpha*A*B' + alpha*B*A' + beta*C,
2006
2007
or
2008
2009
C := alpha*A'*B + alpha*B'*A + beta*C,
2010
2011
where alpha and beta are scalars, C is an n by n symmetric matrix
2012
and A and B are n by k matrices in the first case and k by n
2013
matrices in the second case.
2014
2015
Parameters
2016
==========
2017
2018
UPLO - CHARACTER*1.
2019
On entry, UPLO specifies whether the upper or lower
2020
triangular part of the array C is to be referenced as
2021
follows:
2022
2023
UPLO = 'U' or 'u' Only the upper triangular part of C
2024
is to be referenced.
2025
2026
UPLO = 'L' or 'l' Only the lower triangular part of C
2027
is to be referenced.
2028
2029
Unchanged on exit.
2030
2031
TRANS - CHARACTER*1.
2032
On entry, TRANS specifies the operation to be performed as
2033
follows:
2034
2035
TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
2036
beta*C.
2037
2038
TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
2039
beta*C.
2040
2041
TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
2042
beta*C.
2043
2044
Unchanged on exit.
2045
2046
N - INTEGER.
2047
On entry, N specifies the order of the matrix C. N must be
2048
at least zero.
2049
Unchanged on exit.
2050
2051
K - INTEGER.
2052
On entry with TRANS = 'N' or 'n', K specifies the number
2053
of columns of the matrices A and B, and on entry with
2054
TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
2055
of rows of the matrices A and B. K must be at least zero.
2056
Unchanged on exit.
2057
2058
ALPHA - DOUBLE PRECISION.
2059
On entry, ALPHA specifies the scalar alpha.
2060
Unchanged on exit.
2061
2062
A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
2063
k when TRANS = 'N' or 'n', and is n otherwise.
2064
Before entry with TRANS = 'N' or 'n', the leading n by k
2065
part of the array A must contain the matrix A, otherwise
2066
the leading k by n part of the array A must contain the
2067
matrix A.
2068
Unchanged on exit.
2069
2070
LDA - INTEGER.
2071
On entry, LDA specifies the first dimension of A as declared
2072
in the calling (sub) program. When TRANS = 'N' or 'n'
2073
then LDA must be at least max( 1, n ), otherwise LDA must
2074
be at least max( 1, k ).
2075
Unchanged on exit.
2076
2077
B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
2078
k when TRANS = 'N' or 'n', and is n otherwise.
2079
Before entry with TRANS = 'N' or 'n', the leading n by k
2080
part of the array B must contain the matrix B, otherwise
2081
the leading k by n part of the array B must contain the
2082
matrix B.
2083
Unchanged on exit.
2084
2085
LDB - INTEGER.
2086
On entry, LDB specifies the first dimension of B as declared
2087
in the calling (sub) program. When TRANS = 'N' or 'n'
2088
then LDB must be at least max( 1, n ), otherwise LDB must
2089
be at least max( 1, k ).
2090
Unchanged on exit.
2091
2092
BETA - DOUBLE PRECISION.
2093
On entry, BETA specifies the scalar beta.
2094
Unchanged on exit.
2095
2096
C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
2097
Before entry with UPLO = 'U' or 'u', the leading n by n
2098
upper triangular part of the array C must contain the upper
2099
triangular part of the symmetric matrix and the strictly
2100
lower triangular part of C is not referenced. On exit, the
2101
upper triangular part of the array C is overwritten by the
2102
upper triangular part of the updated matrix.
2103
Before entry with UPLO = 'L' or 'l', the leading n by n
2104
lower triangular part of the array C must contain the lower
2105
triangular part of the symmetric matrix and the strictly
2106
upper triangular part of C is not referenced. On exit, the
2107
lower triangular part of the array C is overwritten by the
2108
lower triangular part of the updated matrix.
2109
2110
LDC - INTEGER.
2111
On entry, LDC specifies the first dimension of C as declared
2112
in the calling (sub) program. LDC must be at least
2113
max( 1, n ).
2114
Unchanged on exit.
2115
2116
2117
Level 3 Blas routine.
2118
2119
2120
-- Written on 8-February-1989.
2121
Jack Dongarra, Argonne National Laboratory.
2122
Iain Duff, AERE Harwell.
2123
Jeremy Du Croz, Numerical Algorithms Group Ltd.
2124
Sven Hammarling, Numerical Algorithms Group Ltd.
2125
2126
2127
Test the input parameters.
2128
*/
2129
2130
/* Parameter adjustments */
2131
a_dim1 = *lda;
2132
a_offset = 1 + a_dim1 * 1;
2133
a -= a_offset;
2134
b_dim1 = *ldb;
2135
b_offset = 1 + b_dim1 * 1;
2136
b -= b_offset;
2137
c_dim1 = *ldc;
2138
c_offset = 1 + c_dim1 * 1;
2139
c__ -= c_offset;
2140
2141
/* Function Body */
2142
if (lsame_(trans, "N")) {
2143
nrowa = *n;
2144
} else {
2145
nrowa = *k;
2146
}
2147
upper = lsame_(uplo, "U");
2148
2149
info = 0;
2150
if ((! upper && ! lsame_(uplo, "L"))) {
2151
info = 1;
2152
} else if (((! lsame_(trans, "N") && ! lsame_(trans,
2153
"T")) && ! lsame_(trans, "C"))) {
2154
info = 2;
2155
} else if (*n < 0) {
2156
info = 3;
2157
} else if (*k < 0) {
2158
info = 4;
2159
} else if (*lda < max(1,nrowa)) {
2160
info = 7;
2161
} else if (*ldb < max(1,nrowa)) {
2162
info = 9;
2163
} else if (*ldc < max(1,*n)) {
2164
info = 12;
2165
}
2166
if (info != 0) {
2167
xerbla_("DSYR2K", &info);
2168
return 0;
2169
}
2170
2171
/* Quick return if possible. */
2172
2173
if (*n == 0 || ((*alpha == 0. || *k == 0) && *beta == 1.)) {
2174
return 0;
2175
}
2176
2177
/* And when alpha.eq.zero. */
2178
2179
if (*alpha == 0.) {
2180
if (upper) {
2181
if (*beta == 0.) {
2182
i__1 = *n;
2183
for (j = 1; j <= i__1; ++j) {
2184
i__2 = j;
2185
for (i__ = 1; i__ <= i__2; ++i__) {
2186
c__[i__ + j * c_dim1] = 0.;
2187
/* L10: */
2188
}
2189
/* L20: */
2190
}
2191
} else {
2192
i__1 = *n;
2193
for (j = 1; j <= i__1; ++j) {
2194
i__2 = j;
2195
for (i__ = 1; i__ <= i__2; ++i__) {
2196
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2197
/* L30: */
2198
}
2199
/* L40: */
2200
}
2201
}
2202
} else {
2203
if (*beta == 0.) {
2204
i__1 = *n;
2205
for (j = 1; j <= i__1; ++j) {
2206
i__2 = *n;
2207
for (i__ = j; i__ <= i__2; ++i__) {
2208
c__[i__ + j * c_dim1] = 0.;
2209
/* L50: */
2210
}
2211
/* L60: */
2212
}
2213
} else {
2214
i__1 = *n;
2215
for (j = 1; j <= i__1; ++j) {
2216
i__2 = *n;
2217
for (i__ = j; i__ <= i__2; ++i__) {
2218
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2219
/* L70: */
2220
}
2221
/* L80: */
2222
}
2223
}
2224
}
2225
return 0;
2226
}
2227
2228
/* Start the operations. */
2229
2230
if (lsame_(trans, "N")) {
2231
2232
/* Form C := alpha*A*B' + alpha*B*A' + C. */
2233
2234
if (upper) {
2235
i__1 = *n;
2236
for (j = 1; j <= i__1; ++j) {
2237
if (*beta == 0.) {
2238
i__2 = j;
2239
for (i__ = 1; i__ <= i__2; ++i__) {
2240
c__[i__ + j * c_dim1] = 0.;
2241
/* L90: */
2242
}
2243
} else if (*beta != 1.) {
2244
i__2 = j;
2245
for (i__ = 1; i__ <= i__2; ++i__) {
2246
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2247
/* L100: */
2248
}
2249
}
2250
i__2 = *k;
2251
for (l = 1; l <= i__2; ++l) {
2252
if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
2253
temp1 = *alpha * b[j + l * b_dim1];
2254
temp2 = *alpha * a[j + l * a_dim1];
2255
i__3 = j;
2256
for (i__ = 1; i__ <= i__3; ++i__) {
2257
c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
2258
i__ + l * a_dim1] * temp1 + b[i__ + l *
2259
b_dim1] * temp2;
2260
/* L110: */
2261
}
2262
}
2263
/* L120: */
2264
}
2265
/* L130: */
2266
}
2267
} else {
2268
i__1 = *n;
2269
for (j = 1; j <= i__1; ++j) {
2270
if (*beta == 0.) {
2271
i__2 = *n;
2272
for (i__ = j; i__ <= i__2; ++i__) {
2273
c__[i__ + j * c_dim1] = 0.;
2274
/* L140: */
2275
}
2276
} else if (*beta != 1.) {
2277
i__2 = *n;
2278
for (i__ = j; i__ <= i__2; ++i__) {
2279
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2280
/* L150: */
2281
}
2282
}
2283
i__2 = *k;
2284
for (l = 1; l <= i__2; ++l) {
2285
if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
2286
temp1 = *alpha * b[j + l * b_dim1];
2287
temp2 = *alpha * a[j + l * a_dim1];
2288
i__3 = *n;
2289
for (i__ = j; i__ <= i__3; ++i__) {
2290
c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
2291
i__ + l * a_dim1] * temp1 + b[i__ + l *
2292
b_dim1] * temp2;
2293
/* L160: */
2294
}
2295
}
2296
/* L170: */
2297
}
2298
/* L180: */
2299
}
2300
}
2301
} else {
2302
2303
/* Form C := alpha*A'*B + alpha*B'*A + C. */
2304
2305
if (upper) {
2306
i__1 = *n;
2307
for (j = 1; j <= i__1; ++j) {
2308
i__2 = j;
2309
for (i__ = 1; i__ <= i__2; ++i__) {
2310
temp1 = 0.;
2311
temp2 = 0.;
2312
i__3 = *k;
2313
for (l = 1; l <= i__3; ++l) {
2314
temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
2315
temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
2316
/* L190: */
2317
}
2318
if (*beta == 0.) {
2319
c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
2320
temp2;
2321
} else {
2322
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
2323
+ *alpha * temp1 + *alpha * temp2;
2324
}
2325
/* L200: */
2326
}
2327
/* L210: */
2328
}
2329
} else {
2330
i__1 = *n;
2331
for (j = 1; j <= i__1; ++j) {
2332
i__2 = *n;
2333
for (i__ = j; i__ <= i__2; ++i__) {
2334
temp1 = 0.;
2335
temp2 = 0.;
2336
i__3 = *k;
2337
for (l = 1; l <= i__3; ++l) {
2338
temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
2339
temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
2340
/* L220: */
2341
}
2342
if (*beta == 0.) {
2343
c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
2344
temp2;
2345
} else {
2346
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
2347
+ *alpha * temp1 + *alpha * temp2;
2348
}
2349
/* L230: */
2350
}
2351
/* L240: */
2352
}
2353
}
2354
}
2355
2356
return 0;
2357
2358
/* End of DSYR2K. */
2359
2360
} /* dsyr2k_ */
2361
2362
/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k,
2363
doublereal *alpha, doublereal *a, integer *lda, doublereal *beta,
2364
doublereal *c__, integer *ldc)
2365
{
2366
/* System generated locals */
2367
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
2368
2369
/* Local variables */
2370
static integer i__, j, l, info;
2371
static doublereal temp;
2372
extern logical lsame_(char *, char *);
2373
static integer nrowa;
2374
static logical upper;
2375
extern /* Subroutine */ int xerbla_(char *, integer *);
2376
2377
2378
/*
2379
Purpose
2380
=======
2381
2382
DSYRK performs one of the symmetric rank k operations
2383
2384
C := alpha*A*A' + beta*C,
2385
2386
or
2387
2388
C := alpha*A'*A + beta*C,
2389
2390
where alpha and beta are scalars, C is an n by n symmetric matrix
2391
and A is an n by k matrix in the first case and a k by n matrix
2392
in the second case.
2393
2394
Parameters
2395
==========
2396
2397
UPLO - CHARACTER*1.
2398
On entry, UPLO specifies whether the upper or lower
2399
triangular part of the array C is to be referenced as
2400
follows:
2401
2402
UPLO = 'U' or 'u' Only the upper triangular part of C
2403
is to be referenced.
2404
2405
UPLO = 'L' or 'l' Only the lower triangular part of C
2406
is to be referenced.
2407
2408
Unchanged on exit.
2409
2410
TRANS - CHARACTER*1.
2411
On entry, TRANS specifies the operation to be performed as
2412
follows:
2413
2414
TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
2415
2416
TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
2417
2418
TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
2419
2420
Unchanged on exit.
2421
2422
N - INTEGER.
2423
On entry, N specifies the order of the matrix C. N must be
2424
at least zero.
2425
Unchanged on exit.
2426
2427
K - INTEGER.
2428
On entry with TRANS = 'N' or 'n', K specifies the number
2429
of columns of the matrix A, and on entry with
2430
TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
2431
of rows of the matrix A. K must be at least zero.
2432
Unchanged on exit.
2433
2434
ALPHA - DOUBLE PRECISION.
2435
On entry, ALPHA specifies the scalar alpha.
2436
Unchanged on exit.
2437
2438
A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
2439
k when TRANS = 'N' or 'n', and is n otherwise.
2440
Before entry with TRANS = 'N' or 'n', the leading n by k
2441
part of the array A must contain the matrix A, otherwise
2442
the leading k by n part of the array A must contain the
2443
matrix A.
2444
Unchanged on exit.
2445
2446
LDA - INTEGER.
2447
On entry, LDA specifies the first dimension of A as declared
2448
in the calling (sub) program. When TRANS = 'N' or 'n'
2449
then LDA must be at least max( 1, n ), otherwise LDA must
2450
be at least max( 1, k ).
2451
Unchanged on exit.
2452
2453
BETA - DOUBLE PRECISION.
2454
On entry, BETA specifies the scalar beta.
2455
Unchanged on exit.
2456
2457
C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
2458
Before entry with UPLO = 'U' or 'u', the leading n by n
2459
upper triangular part of the array C must contain the upper
2460
triangular part of the symmetric matrix and the strictly
2461
lower triangular part of C is not referenced. On exit, the
2462
upper triangular part of the array C is overwritten by the
2463
upper triangular part of the updated matrix.
2464
Before entry with UPLO = 'L' or 'l', the leading n by n
2465
lower triangular part of the array C must contain the lower
2466
triangular part of the symmetric matrix and the strictly
2467
upper triangular part of C is not referenced. On exit, the
2468
lower triangular part of the array C is overwritten by the
2469
lower triangular part of the updated matrix.
2470
2471
LDC - INTEGER.
2472
On entry, LDC specifies the first dimension of C as declared
2473
in the calling (sub) program. LDC must be at least
2474
max( 1, n ).
2475
Unchanged on exit.
2476
2477
2478
Level 3 Blas routine.
2479
2480
-- Written on 8-February-1989.
2481
Jack Dongarra, Argonne National Laboratory.
2482
Iain Duff, AERE Harwell.
2483
Jeremy Du Croz, Numerical Algorithms Group Ltd.
2484
Sven Hammarling, Numerical Algorithms Group Ltd.
2485
2486
2487
Test the input parameters.
2488
*/
2489
2490
/* Parameter adjustments */
2491
a_dim1 = *lda;
2492
a_offset = 1 + a_dim1 * 1;
2493
a -= a_offset;
2494
c_dim1 = *ldc;
2495
c_offset = 1 + c_dim1 * 1;
2496
c__ -= c_offset;
2497
2498
/* Function Body */
2499
if (lsame_(trans, "N")) {
2500
nrowa = *n;
2501
} else {
2502
nrowa = *k;
2503
}
2504
upper = lsame_(uplo, "U");
2505
2506
info = 0;
2507
if ((! upper && ! lsame_(uplo, "L"))) {
2508
info = 1;
2509
} else if (((! lsame_(trans, "N") && ! lsame_(trans,
2510
"T")) && ! lsame_(trans, "C"))) {
2511
info = 2;
2512
} else if (*n < 0) {
2513
info = 3;
2514
} else if (*k < 0) {
2515
info = 4;
2516
} else if (*lda < max(1,nrowa)) {
2517
info = 7;
2518
} else if (*ldc < max(1,*n)) {
2519
info = 10;
2520
}
2521
if (info != 0) {
2522
xerbla_("DSYRK ", &info);
2523
return 0;
2524
}
2525
2526
/* Quick return if possible. */
2527
2528
if (*n == 0 || ((*alpha == 0. || *k == 0) && *beta == 1.)) {
2529
return 0;
2530
}
2531
2532
/* And when alpha.eq.zero. */
2533
2534
if (*alpha == 0.) {
2535
if (upper) {
2536
if (*beta == 0.) {
2537
i__1 = *n;
2538
for (j = 1; j <= i__1; ++j) {
2539
i__2 = j;
2540
for (i__ = 1; i__ <= i__2; ++i__) {
2541
c__[i__ + j * c_dim1] = 0.;
2542
/* L10: */
2543
}
2544
/* L20: */
2545
}
2546
} else {
2547
i__1 = *n;
2548
for (j = 1; j <= i__1; ++j) {
2549
i__2 = j;
2550
for (i__ = 1; i__ <= i__2; ++i__) {
2551
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2552
/* L30: */
2553
}
2554
/* L40: */
2555
}
2556
}
2557
} else {
2558
if (*beta == 0.) {
2559
i__1 = *n;
2560
for (j = 1; j <= i__1; ++j) {
2561
i__2 = *n;
2562
for (i__ = j; i__ <= i__2; ++i__) {
2563
c__[i__ + j * c_dim1] = 0.;
2564
/* L50: */
2565
}
2566
/* L60: */
2567
}
2568
} else {
2569
i__1 = *n;
2570
for (j = 1; j <= i__1; ++j) {
2571
i__2 = *n;
2572
for (i__ = j; i__ <= i__2; ++i__) {
2573
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2574
/* L70: */
2575
}
2576
/* L80: */
2577
}
2578
}
2579
}
2580
return 0;
2581
}
2582
2583
/* Start the operations. */
2584
2585
if (lsame_(trans, "N")) {
2586
2587
/* Form C := alpha*A*A' + beta*C. */
2588
2589
if (upper) {
2590
i__1 = *n;
2591
for (j = 1; j <= i__1; ++j) {
2592
if (*beta == 0.) {
2593
i__2 = j;
2594
for (i__ = 1; i__ <= i__2; ++i__) {
2595
c__[i__ + j * c_dim1] = 0.;
2596
/* L90: */
2597
}
2598
} else if (*beta != 1.) {
2599
i__2 = j;
2600
for (i__ = 1; i__ <= i__2; ++i__) {
2601
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2602
/* L100: */
2603
}
2604
}
2605
i__2 = *k;
2606
for (l = 1; l <= i__2; ++l) {
2607
if (a[j + l * a_dim1] != 0.) {
2608
temp = *alpha * a[j + l * a_dim1];
2609
i__3 = j;
2610
for (i__ = 1; i__ <= i__3; ++i__) {
2611
c__[i__ + j * c_dim1] += temp * a[i__ + l *
2612
a_dim1];
2613
/* L110: */
2614
}
2615
}
2616
/* L120: */
2617
}
2618
/* L130: */
2619
}
2620
} else {
2621
i__1 = *n;
2622
for (j = 1; j <= i__1; ++j) {
2623
if (*beta == 0.) {
2624
i__2 = *n;
2625
for (i__ = j; i__ <= i__2; ++i__) {
2626
c__[i__ + j * c_dim1] = 0.;
2627
/* L140: */
2628
}
2629
} else if (*beta != 1.) {
2630
i__2 = *n;
2631
for (i__ = j; i__ <= i__2; ++i__) {
2632
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
2633
/* L150: */
2634
}
2635
}
2636
i__2 = *k;
2637
for (l = 1; l <= i__2; ++l) {
2638
if (a[j + l * a_dim1] != 0.) {
2639
temp = *alpha * a[j + l * a_dim1];
2640
i__3 = *n;
2641
for (i__ = j; i__ <= i__3; ++i__) {
2642
c__[i__ + j * c_dim1] += temp * a[i__ + l *
2643
a_dim1];
2644
/* L160: */
2645
}
2646
}
2647
/* L170: */
2648
}
2649
/* L180: */
2650
}
2651
}
2652
} else {
2653
2654
/* Form C := alpha*A'*A + beta*C. */
2655
2656
if (upper) {
2657
i__1 = *n;
2658
for (j = 1; j <= i__1; ++j) {
2659
i__2 = j;
2660
for (i__ = 1; i__ <= i__2; ++i__) {
2661
temp = 0.;
2662
i__3 = *k;
2663
for (l = 1; l <= i__3; ++l) {
2664
temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
2665
/* L190: */
2666
}
2667
if (*beta == 0.) {
2668
c__[i__ + j * c_dim1] = *alpha * temp;
2669
} else {
2670
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
2671
i__ + j * c_dim1];
2672
}
2673
/* L200: */
2674
}
2675
/* L210: */
2676
}
2677
} else {
2678
i__1 = *n;
2679
for (j = 1; j <= i__1; ++j) {
2680
i__2 = *n;
2681
for (i__ = j; i__ <= i__2; ++i__) {
2682
temp = 0.;
2683
i__3 = *k;
2684
for (l = 1; l <= i__3; ++l) {
2685
temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
2686
/* L220: */
2687
}
2688
if (*beta == 0.) {
2689
c__[i__ + j * c_dim1] = *alpha * temp;
2690
} else {
2691
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
2692
i__ + j * c_dim1];
2693
}
2694
/* L230: */
2695
}
2696
/* L240: */
2697
}
2698
}
2699
}
2700
2701
return 0;
2702
2703
/* End of DSYRK . */
2704
2705
} /* dsyrk_ */
2706
2707
/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag,
2708
integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
2709
lda, doublereal *b, integer *ldb)
2710
{
2711
/* System generated locals */
2712
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
2713
2714
/* Local variables */
2715
static integer i__, j, k, info;
2716
static doublereal temp;
2717
static logical lside;
2718
extern logical lsame_(char *, char *);
2719
static integer nrowa;
2720
static logical upper;
2721
extern /* Subroutine */ int xerbla_(char *, integer *);
2722
static logical nounit;
2723
2724
2725
/*
2726
Purpose
2727
=======
2728
2729
DTRMM performs one of the matrix-matrix operations
2730
2731
B := alpha*op( A )*B, or B := alpha*B*op( A ),
2732
2733
where alpha is a scalar, B is an m by n matrix, A is a unit, or
2734
non-unit, upper or lower triangular matrix and op( A ) is one of
2735
2736
op( A ) = A or op( A ) = A'.
2737
2738
Parameters
2739
==========
2740
2741
SIDE - CHARACTER*1.
2742
On entry, SIDE specifies whether op( A ) multiplies B from
2743
the left or right as follows:
2744
2745
SIDE = 'L' or 'l' B := alpha*op( A )*B.
2746
2747
SIDE = 'R' or 'r' B := alpha*B*op( A ).
2748
2749
Unchanged on exit.
2750
2751
UPLO - CHARACTER*1.
2752
On entry, UPLO specifies whether the matrix A is an upper or
2753
lower triangular matrix as follows:
2754
2755
UPLO = 'U' or 'u' A is an upper triangular matrix.
2756
2757
UPLO = 'L' or 'l' A is a lower triangular matrix.
2758
2759
Unchanged on exit.
2760
2761
TRANSA - CHARACTER*1.
2762
On entry, TRANSA specifies the form of op( A ) to be used in
2763
the matrix multiplication as follows:
2764
2765
TRANSA = 'N' or 'n' op( A ) = A.
2766
2767
TRANSA = 'T' or 't' op( A ) = A'.
2768
2769
TRANSA = 'C' or 'c' op( A ) = A'.
2770
2771
Unchanged on exit.
2772
2773
DIAG - CHARACTER*1.
2774
On entry, DIAG specifies whether or not A is unit triangular
2775
as follows:
2776
2777
DIAG = 'U' or 'u' A is assumed to be unit triangular.
2778
2779
DIAG = 'N' or 'n' A is not assumed to be unit
2780
triangular.
2781
2782
Unchanged on exit.
2783
2784
M - INTEGER.
2785
On entry, M specifies the number of rows of B. M must be at
2786
least zero.
2787
Unchanged on exit.
2788
2789
N - INTEGER.
2790
On entry, N specifies the number of columns of B. N must be
2791
at least zero.
2792
Unchanged on exit.
2793
2794
ALPHA - DOUBLE PRECISION.
2795
On entry, ALPHA specifies the scalar alpha. When alpha is
2796
zero then A is not referenced and B need not be set before
2797
entry.
2798
Unchanged on exit.
2799
2800
A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
2801
when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
2802
Before entry with UPLO = 'U' or 'u', the leading k by k
2803
upper triangular part of the array A must contain the upper
2804
triangular matrix and the strictly lower triangular part of
2805
A is not referenced.
2806
Before entry with UPLO = 'L' or 'l', the leading k by k
2807
lower triangular part of the array A must contain the lower
2808
triangular matrix and the strictly upper triangular part of
2809
A is not referenced.
2810
Note that when DIAG = 'U' or 'u', the diagonal elements of
2811
A are not referenced either, but are assumed to be unity.
2812
Unchanged on exit.
2813
2814
LDA - INTEGER.
2815
On entry, LDA specifies the first dimension of A as declared
2816
in the calling (sub) program. When SIDE = 'L' or 'l' then
2817
LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
2818
then LDA must be at least max( 1, n ).
2819
Unchanged on exit.
2820
2821
B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
2822
Before entry, the leading m by n part of the array B must
2823
contain the matrix B, and on exit is overwritten by the
2824
transformed matrix.
2825
2826
LDB - INTEGER.
2827
On entry, LDB specifies the first dimension of B as declared
2828
in the calling (sub) program. LDB must be at least
2829
max( 1, m ).
2830
Unchanged on exit.
2831
2832
2833
Level 3 Blas routine.
2834
2835
-- Written on 8-February-1989.
2836
Jack Dongarra, Argonne National Laboratory.
2837
Iain Duff, AERE Harwell.
2838
Jeremy Du Croz, Numerical Algorithms Group Ltd.
2839
Sven Hammarling, Numerical Algorithms Group Ltd.
2840
2841
2842
Test the input parameters.
2843
*/
2844
2845
/* Parameter adjustments */
2846
a_dim1 = *lda;
2847
a_offset = 1 + a_dim1 * 1;
2848
a -= a_offset;
2849
b_dim1 = *ldb;
2850
b_offset = 1 + b_dim1 * 1;
2851
b -= b_offset;
2852
2853
/* Function Body */
2854
lside = lsame_(side, "L");
2855
if (lside) {
2856
nrowa = *m;
2857
} else {
2858
nrowa = *n;
2859
}
2860
nounit = lsame_(diag, "N");
2861
upper = lsame_(uplo, "U");
2862
2863
info = 0;
2864
if ((! lside && ! lsame_(side, "R"))) {
2865
info = 1;
2866
} else if ((! upper && ! lsame_(uplo, "L"))) {
2867
info = 2;
2868
} else if (((! lsame_(transa, "N") && ! lsame_(
2869
transa, "T")) && ! lsame_(transa, "C"))) {
2870
info = 3;
2871
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
2872
"N"))) {
2873
info = 4;
2874
} else if (*m < 0) {
2875
info = 5;
2876
} else if (*n < 0) {
2877
info = 6;
2878
} else if (*lda < max(1,nrowa)) {
2879
info = 9;
2880
} else if (*ldb < max(1,*m)) {
2881
info = 11;
2882
}
2883
if (info != 0) {
2884
xerbla_("DTRMM ", &info);
2885
return 0;
2886
}
2887
2888
/* Quick return if possible. */
2889
2890
if (*n == 0) {
2891
return 0;
2892
}
2893
2894
/* And when alpha.eq.zero. */
2895
2896
if (*alpha == 0.) {
2897
i__1 = *n;
2898
for (j = 1; j <= i__1; ++j) {
2899
i__2 = *m;
2900
for (i__ = 1; i__ <= i__2; ++i__) {
2901
b[i__ + j * b_dim1] = 0.;
2902
/* L10: */
2903
}
2904
/* L20: */
2905
}
2906
return 0;
2907
}
2908
2909
/* Start the operations. */
2910
2911
if (lside) {
2912
if (lsame_(transa, "N")) {
2913
2914
/* Form B := alpha*A*B. */
2915
2916
if (upper) {
2917
i__1 = *n;
2918
for (j = 1; j <= i__1; ++j) {
2919
i__2 = *m;
2920
for (k = 1; k <= i__2; ++k) {
2921
if (b[k + j * b_dim1] != 0.) {
2922
temp = *alpha * b[k + j * b_dim1];
2923
i__3 = k - 1;
2924
for (i__ = 1; i__ <= i__3; ++i__) {
2925
b[i__ + j * b_dim1] += temp * a[i__ + k *
2926
a_dim1];
2927
/* L30: */
2928
}
2929
if (nounit) {
2930
temp *= a[k + k * a_dim1];
2931
}
2932
b[k + j * b_dim1] = temp;
2933
}
2934
/* L40: */
2935
}
2936
/* L50: */
2937
}
2938
} else {
2939
i__1 = *n;
2940
for (j = 1; j <= i__1; ++j) {
2941
for (k = *m; k >= 1; --k) {
2942
if (b[k + j * b_dim1] != 0.) {
2943
temp = *alpha * b[k + j * b_dim1];
2944
b[k + j * b_dim1] = temp;
2945
if (nounit) {
2946
b[k + j * b_dim1] *= a[k + k * a_dim1];
2947
}
2948
i__2 = *m;
2949
for (i__ = k + 1; i__ <= i__2; ++i__) {
2950
b[i__ + j * b_dim1] += temp * a[i__ + k *
2951
a_dim1];
2952
/* L60: */
2953
}
2954
}
2955
/* L70: */
2956
}
2957
/* L80: */
2958
}
2959
}
2960
} else {
2961
2962
/* Form B := alpha*A'*B. */
2963
2964
if (upper) {
2965
i__1 = *n;
2966
for (j = 1; j <= i__1; ++j) {
2967
for (i__ = *m; i__ >= 1; --i__) {
2968
temp = b[i__ + j * b_dim1];
2969
if (nounit) {
2970
temp *= a[i__ + i__ * a_dim1];
2971
}
2972
i__2 = i__ - 1;
2973
for (k = 1; k <= i__2; ++k) {
2974
temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
2975
/* L90: */
2976
}
2977
b[i__ + j * b_dim1] = *alpha * temp;
2978
/* L100: */
2979
}
2980
/* L110: */
2981
}
2982
} else {
2983
i__1 = *n;
2984
for (j = 1; j <= i__1; ++j) {
2985
i__2 = *m;
2986
for (i__ = 1; i__ <= i__2; ++i__) {
2987
temp = b[i__ + j * b_dim1];
2988
if (nounit) {
2989
temp *= a[i__ + i__ * a_dim1];
2990
}
2991
i__3 = *m;
2992
for (k = i__ + 1; k <= i__3; ++k) {
2993
temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
2994
/* L120: */
2995
}
2996
b[i__ + j * b_dim1] = *alpha * temp;
2997
/* L130: */
2998
}
2999
/* L140: */
3000
}
3001
}
3002
}
3003
} else {
3004
if (lsame_(transa, "N")) {
3005
3006
/* Form B := alpha*B*A. */
3007
3008
if (upper) {
3009
for (j = *n; j >= 1; --j) {
3010
temp = *alpha;
3011
if (nounit) {
3012
temp *= a[j + j * a_dim1];
3013
}
3014
i__1 = *m;
3015
for (i__ = 1; i__ <= i__1; ++i__) {
3016
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
3017
/* L150: */
3018
}
3019
i__1 = j - 1;
3020
for (k = 1; k <= i__1; ++k) {
3021
if (a[k + j * a_dim1] != 0.) {
3022
temp = *alpha * a[k + j * a_dim1];
3023
i__2 = *m;
3024
for (i__ = 1; i__ <= i__2; ++i__) {
3025
b[i__ + j * b_dim1] += temp * b[i__ + k *
3026
b_dim1];
3027
/* L160: */
3028
}
3029
}
3030
/* L170: */
3031
}
3032
/* L180: */
3033
}
3034
} else {
3035
i__1 = *n;
3036
for (j = 1; j <= i__1; ++j) {
3037
temp = *alpha;
3038
if (nounit) {
3039
temp *= a[j + j * a_dim1];
3040
}
3041
i__2 = *m;
3042
for (i__ = 1; i__ <= i__2; ++i__) {
3043
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
3044
/* L190: */
3045
}
3046
i__2 = *n;
3047
for (k = j + 1; k <= i__2; ++k) {
3048
if (a[k + j * a_dim1] != 0.) {
3049
temp = *alpha * a[k + j * a_dim1];
3050
i__3 = *m;
3051
for (i__ = 1; i__ <= i__3; ++i__) {
3052
b[i__ + j * b_dim1] += temp * b[i__ + k *
3053
b_dim1];
3054
/* L200: */
3055
}
3056
}
3057
/* L210: */
3058
}
3059
/* L220: */
3060
}
3061
}
3062
} else {
3063
3064
/* Form B := alpha*B*A'. */
3065
3066
if (upper) {
3067
i__1 = *n;
3068
for (k = 1; k <= i__1; ++k) {
3069
i__2 = k - 1;
3070
for (j = 1; j <= i__2; ++j) {
3071
if (a[j + k * a_dim1] != 0.) {
3072
temp = *alpha * a[j + k * a_dim1];
3073
i__3 = *m;
3074
for (i__ = 1; i__ <= i__3; ++i__) {
3075
b[i__ + j * b_dim1] += temp * b[i__ + k *
3076
b_dim1];
3077
/* L230: */
3078
}
3079
}
3080
/* L240: */
3081
}
3082
temp = *alpha;
3083
if (nounit) {
3084
temp *= a[k + k * a_dim1];
3085
}
3086
if (temp != 1.) {
3087
i__2 = *m;
3088
for (i__ = 1; i__ <= i__2; ++i__) {
3089
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
3090
/* L250: */
3091
}
3092
}
3093
/* L260: */
3094
}
3095
} else {
3096
for (k = *n; k >= 1; --k) {
3097
i__1 = *n;
3098
for (j = k + 1; j <= i__1; ++j) {
3099
if (a[j + k * a_dim1] != 0.) {
3100
temp = *alpha * a[j + k * a_dim1];
3101
i__2 = *m;
3102
for (i__ = 1; i__ <= i__2; ++i__) {
3103
b[i__ + j * b_dim1] += temp * b[i__ + k *
3104
b_dim1];
3105
/* L270: */
3106
}
3107
}
3108
/* L280: */
3109
}
3110
temp = *alpha;
3111
if (nounit) {
3112
temp *= a[k + k * a_dim1];
3113
}
3114
if (temp != 1.) {
3115
i__1 = *m;
3116
for (i__ = 1; i__ <= i__1; ++i__) {
3117
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
3118
/* L290: */
3119
}
3120
}
3121
/* L300: */
3122
}
3123
}
3124
}
3125
}
3126
3127
return 0;
3128
3129
/* End of DTRMM . */
3130
3131
} /* dtrmm_ */
3132
3133
/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n,
3134
doublereal *a, integer *lda, doublereal *x, integer *incx)
3135
{
3136
/* System generated locals */
3137
integer a_dim1, a_offset, i__1, i__2;
3138
3139
/* Local variables */
3140
static integer i__, j, ix, jx, kx, info;
3141
static doublereal temp;
3142
extern logical lsame_(char *, char *);
3143
extern /* Subroutine */ int xerbla_(char *, integer *);
3144
static logical nounit;
3145
3146
3147
/*
3148
Purpose
3149
=======
3150
3151
DTRMV performs one of the matrix-vector operations
3152
3153
x := A*x, or x := A'*x,
3154
3155
where x is an n element vector and A is an n by n unit, or non-unit,
3156
upper or lower triangular matrix.
3157
3158
Parameters
3159
==========
3160
3161
UPLO - CHARACTER*1.
3162
On entry, UPLO specifies whether the matrix is an upper or
3163
lower triangular matrix as follows:
3164
3165
UPLO = 'U' or 'u' A is an upper triangular matrix.
3166
3167
UPLO = 'L' or 'l' A is a lower triangular matrix.
3168
3169
Unchanged on exit.
3170
3171
TRANS - CHARACTER*1.
3172
On entry, TRANS specifies the operation to be performed as
3173
follows:
3174
3175
TRANS = 'N' or 'n' x := A*x.
3176
3177
TRANS = 'T' or 't' x := A'*x.
3178
3179
TRANS = 'C' or 'c' x := A'*x.
3180
3181
Unchanged on exit.
3182
3183
DIAG - CHARACTER*1.
3184
On entry, DIAG specifies whether or not A is unit
3185
triangular as follows:
3186
3187
DIAG = 'U' or 'u' A is assumed to be unit triangular.
3188
3189
DIAG = 'N' or 'n' A is not assumed to be unit
3190
triangular.
3191
3192
Unchanged on exit.
3193
3194
N - INTEGER.
3195
On entry, N specifies the order of the matrix A.
3196
N must be at least zero.
3197
Unchanged on exit.
3198
3199
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
3200
Before entry with UPLO = 'U' or 'u', the leading n by n
3201
upper triangular part of the array A must contain the upper
3202
triangular matrix and the strictly lower triangular part of
3203
A is not referenced.
3204
Before entry with UPLO = 'L' or 'l', the leading n by n
3205
lower triangular part of the array A must contain the lower
3206
triangular matrix and the strictly upper triangular part of
3207
A is not referenced.
3208
Note that when DIAG = 'U' or 'u', the diagonal elements of
3209
A are not referenced either, but are assumed to be unity.
3210
Unchanged on exit.
3211
3212
LDA - INTEGER.
3213
On entry, LDA specifies the first dimension of A as declared
3214
in the calling (sub) program. LDA must be at least
3215
max( 1, n ).
3216
Unchanged on exit.
3217
3218
X - DOUBLE PRECISION array of dimension at least
3219
( 1 + ( n - 1 )*abs( INCX ) ).
3220
Before entry, the incremented array X must contain the n
3221
element vector x. On exit, X is overwritten with the
3222
tranformed vector x.
3223
3224
INCX - INTEGER.
3225
On entry, INCX specifies the increment for the elements of
3226
X. INCX must not be zero.
3227
Unchanged on exit.
3228
3229
3230
Level 2 Blas routine.
3231
3232
-- Written on 22-October-1986.
3233
Jack Dongarra, Argonne National Lab.
3234
Jeremy Du Croz, Nag Central Office.
3235
Sven Hammarling, Nag Central Office.
3236
Richard Hanson, Sandia National Labs.
3237
3238
3239
Test the input parameters.
3240
*/
3241
3242
/* Parameter adjustments */
3243
a_dim1 = *lda;
3244
a_offset = 1 + a_dim1 * 1;
3245
a -= a_offset;
3246
--x;
3247
3248
/* Function Body */
3249
info = 0;
3250
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
3251
info = 1;
3252
} else if (((! lsame_(trans, "N") && ! lsame_(trans,
3253
"T")) && ! lsame_(trans, "C"))) {
3254
info = 2;
3255
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
3256
"N"))) {
3257
info = 3;
3258
} else if (*n < 0) {
3259
info = 4;
3260
} else if (*lda < max(1,*n)) {
3261
info = 6;
3262
} else if (*incx == 0) {
3263
info = 8;
3264
}
3265
if (info != 0) {
3266
xerbla_("DTRMV ", &info);
3267
return 0;
3268
}
3269
3270
/* Quick return if possible. */
3271
3272
if (*n == 0) {
3273
return 0;
3274
}
3275
3276
nounit = lsame_(diag, "N");
3277
3278
/*
3279
Set up the start point in X if the increment is not unity. This
3280
will be ( N - 1 )*INCX too small for descending loops.
3281
*/
3282
3283
if (*incx <= 0) {
3284
kx = 1 - (*n - 1) * *incx;
3285
} else if (*incx != 1) {
3286
kx = 1;
3287
}
3288
3289
/*
3290
Start the operations. In this version the elements of A are
3291
accessed sequentially with one pass through A.
3292
*/
3293
3294
if (lsame_(trans, "N")) {
3295
3296
/* Form x := A*x. */
3297
3298
if (lsame_(uplo, "U")) {
3299
if (*incx == 1) {
3300
i__1 = *n;
3301
for (j = 1; j <= i__1; ++j) {
3302
if (x[j] != 0.) {
3303
temp = x[j];
3304
i__2 = j - 1;
3305
for (i__ = 1; i__ <= i__2; ++i__) {
3306
x[i__] += temp * a[i__ + j * a_dim1];
3307
/* L10: */
3308
}
3309
if (nounit) {
3310
x[j] *= a[j + j * a_dim1];
3311
}
3312
}
3313
/* L20: */
3314
}
3315
} else {
3316
jx = kx;
3317
i__1 = *n;
3318
for (j = 1; j <= i__1; ++j) {
3319
if (x[jx] != 0.) {
3320
temp = x[jx];
3321
ix = kx;
3322
i__2 = j - 1;
3323
for (i__ = 1; i__ <= i__2; ++i__) {
3324
x[ix] += temp * a[i__ + j * a_dim1];
3325
ix += *incx;
3326
/* L30: */
3327
}
3328
if (nounit) {
3329
x[jx] *= a[j + j * a_dim1];
3330
}
3331
}
3332
jx += *incx;
3333
/* L40: */
3334
}
3335
}
3336
} else {
3337
if (*incx == 1) {
3338
for (j = *n; j >= 1; --j) {
3339
if (x[j] != 0.) {
3340
temp = x[j];
3341
i__1 = j + 1;
3342
for (i__ = *n; i__ >= i__1; --i__) {
3343
x[i__] += temp * a[i__ + j * a_dim1];
3344
/* L50: */
3345
}
3346
if (nounit) {
3347
x[j] *= a[j + j * a_dim1];
3348
}
3349
}
3350
/* L60: */
3351
}
3352
} else {
3353
kx += (*n - 1) * *incx;
3354
jx = kx;
3355
for (j = *n; j >= 1; --j) {
3356
if (x[jx] != 0.) {
3357
temp = x[jx];
3358
ix = kx;
3359
i__1 = j + 1;
3360
for (i__ = *n; i__ >= i__1; --i__) {
3361
x[ix] += temp * a[i__ + j * a_dim1];
3362
ix -= *incx;
3363
/* L70: */
3364
}
3365
if (nounit) {
3366
x[jx] *= a[j + j * a_dim1];
3367
}
3368
}
3369
jx -= *incx;
3370
/* L80: */
3371
}
3372
}
3373
}
3374
} else {
3375
3376
/* Form x := A'*x. */
3377
3378
if (lsame_(uplo, "U")) {
3379
if (*incx == 1) {
3380
for (j = *n; j >= 1; --j) {
3381
temp = x[j];
3382
if (nounit) {
3383
temp *= a[j + j * a_dim1];
3384
}
3385
for (i__ = j - 1; i__ >= 1; --i__) {
3386
temp += a[i__ + j * a_dim1] * x[i__];
3387
/* L90: */
3388
}
3389
x[j] = temp;
3390
/* L100: */
3391
}
3392
} else {
3393
jx = kx + (*n - 1) * *incx;
3394
for (j = *n; j >= 1; --j) {
3395
temp = x[jx];
3396
ix = jx;
3397
if (nounit) {
3398
temp *= a[j + j * a_dim1];
3399
}
3400
for (i__ = j - 1; i__ >= 1; --i__) {
3401
ix -= *incx;
3402
temp += a[i__ + j * a_dim1] * x[ix];
3403
/* L110: */
3404
}
3405
x[jx] = temp;
3406
jx -= *incx;
3407
/* L120: */
3408
}
3409
}
3410
} else {
3411
if (*incx == 1) {
3412
i__1 = *n;
3413
for (j = 1; j <= i__1; ++j) {
3414
temp = x[j];
3415
if (nounit) {
3416
temp *= a[j + j * a_dim1];
3417
}
3418
i__2 = *n;
3419
for (i__ = j + 1; i__ <= i__2; ++i__) {
3420
temp += a[i__ + j * a_dim1] * x[i__];
3421
/* L130: */
3422
}
3423
x[j] = temp;
3424
/* L140: */
3425
}
3426
} else {
3427
jx = kx;
3428
i__1 = *n;
3429
for (j = 1; j <= i__1; ++j) {
3430
temp = x[jx];
3431
ix = jx;
3432
if (nounit) {
3433
temp *= a[j + j * a_dim1];
3434
}
3435
i__2 = *n;
3436
for (i__ = j + 1; i__ <= i__2; ++i__) {
3437
ix += *incx;
3438
temp += a[i__ + j * a_dim1] * x[ix];
3439
/* L150: */
3440
}
3441
x[jx] = temp;
3442
jx += *incx;
3443
/* L160: */
3444
}
3445
}
3446
}
3447
}
3448
3449
return 0;
3450
3451
/* End of DTRMV . */
3452
3453
} /* dtrmv_ */
3454
3455
/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag,
3456
integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
3457
lda, doublereal *b, integer *ldb)
3458
{
3459
/* System generated locals */
3460
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
3461
3462
/* Local variables */
3463
static integer i__, j, k, info;
3464
static doublereal temp;
3465
static logical lside;
3466
extern logical lsame_(char *, char *);
3467
static integer nrowa;
3468
static logical upper;
3469
extern /* Subroutine */ int xerbla_(char *, integer *);
3470
static logical nounit;
3471
3472
3473
/*
3474
Purpose
3475
=======
3476
3477
DTRSM solves one of the matrix equations
3478
3479
op( A )*X = alpha*B, or X*op( A ) = alpha*B,
3480
3481
where alpha is a scalar, X and B are m by n matrices, A is a unit, or
3482
non-unit, upper or lower triangular matrix and op( A ) is one of
3483
3484
op( A ) = A or op( A ) = A'.
3485
3486
The matrix X is overwritten on B.
3487
3488
Parameters
3489
==========
3490
3491
SIDE - CHARACTER*1.
3492
On entry, SIDE specifies whether op( A ) appears on the left
3493
or right of X as follows:
3494
3495
SIDE = 'L' or 'l' op( A )*X = alpha*B.
3496
3497
SIDE = 'R' or 'r' X*op( A ) = alpha*B.
3498
3499
Unchanged on exit.
3500
3501
UPLO - CHARACTER*1.
3502
On entry, UPLO specifies whether the matrix A is an upper or
3503
lower triangular matrix as follows:
3504
3505
UPLO = 'U' or 'u' A is an upper triangular matrix.
3506
3507
UPLO = 'L' or 'l' A is a lower triangular matrix.
3508
3509
Unchanged on exit.
3510
3511
TRANSA - CHARACTER*1.
3512
On entry, TRANSA specifies the form of op( A ) to be used in
3513
the matrix multiplication as follows:
3514
3515
TRANSA = 'N' or 'n' op( A ) = A.
3516
3517
TRANSA = 'T' or 't' op( A ) = A'.
3518
3519
TRANSA = 'C' or 'c' op( A ) = A'.
3520
3521
Unchanged on exit.
3522
3523
DIAG - CHARACTER*1.
3524
On entry, DIAG specifies whether or not A is unit triangular
3525
as follows:
3526
3527
DIAG = 'U' or 'u' A is assumed to be unit triangular.
3528
3529
DIAG = 'N' or 'n' A is not assumed to be unit
3530
triangular.
3531
3532
Unchanged on exit.
3533
3534
M - INTEGER.
3535
On entry, M specifies the number of rows of B. M must be at
3536
least zero.
3537
Unchanged on exit.
3538
3539
N - INTEGER.
3540
On entry, N specifies the number of columns of B. N must be
3541
at least zero.
3542
Unchanged on exit.
3543
3544
ALPHA - DOUBLE PRECISION.
3545
On entry, ALPHA specifies the scalar alpha. When alpha is
3546
zero then A is not referenced and B need not be set before
3547
entry.
3548
Unchanged on exit.
3549
3550
A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
3551
when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
3552
Before entry with UPLO = 'U' or 'u', the leading k by k
3553
upper triangular part of the array A must contain the upper
3554
triangular matrix and the strictly lower triangular part of
3555
A is not referenced.
3556
Before entry with UPLO = 'L' or 'l', the leading k by k
3557
lower triangular part of the array A must contain the lower
3558
triangular matrix and the strictly upper triangular part of
3559
A is not referenced.
3560
Note that when DIAG = 'U' or 'u', the diagonal elements of
3561
A are not referenced either, but are assumed to be unity.
3562
Unchanged on exit.
3563
3564
LDA - INTEGER.
3565
On entry, LDA specifies the first dimension of A as declared
3566
in the calling (sub) program. When SIDE = 'L' or 'l' then
3567
LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
3568
then LDA must be at least max( 1, n ).
3569
Unchanged on exit.
3570
3571
B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
3572
Before entry, the leading m by n part of the array B must
3573
contain the right-hand side matrix B, and on exit is
3574
overwritten by the solution matrix X.
3575
3576
LDB - INTEGER.
3577
On entry, LDB specifies the first dimension of B as declared
3578
in the calling (sub) program. LDB must be at least
3579
max( 1, m ).
3580
Unchanged on exit.
3581
3582
3583
Level 3 Blas routine.
3584
3585
3586
-- Written on 8-February-1989.
3587
Jack Dongarra, Argonne National Laboratory.
3588
Iain Duff, AERE Harwell.
3589
Jeremy Du Croz, Numerical Algorithms Group Ltd.
3590
Sven Hammarling, Numerical Algorithms Group Ltd.
3591
3592
3593
Test the input parameters.
3594
*/
3595
3596
/* Parameter adjustments */
3597
a_dim1 = *lda;
3598
a_offset = 1 + a_dim1 * 1;
3599
a -= a_offset;
3600
b_dim1 = *ldb;
3601
b_offset = 1 + b_dim1 * 1;
3602
b -= b_offset;
3603
3604
/* Function Body */
3605
lside = lsame_(side, "L");
3606
if (lside) {
3607
nrowa = *m;
3608
} else {
3609
nrowa = *n;
3610
}
3611
nounit = lsame_(diag, "N");
3612
upper = lsame_(uplo, "U");
3613
3614
info = 0;
3615
if ((! lside && ! lsame_(side, "R"))) {
3616
info = 1;
3617
} else if ((! upper && ! lsame_(uplo, "L"))) {
3618
info = 2;
3619
} else if (((! lsame_(transa, "N") && ! lsame_(
3620
transa, "T")) && ! lsame_(transa, "C"))) {
3621
info = 3;
3622
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
3623
"N"))) {
3624
info = 4;
3625
} else if (*m < 0) {
3626
info = 5;
3627
} else if (*n < 0) {
3628
info = 6;
3629
} else if (*lda < max(1,nrowa)) {
3630
info = 9;
3631
} else if (*ldb < max(1,*m)) {
3632
info = 11;
3633
}
3634
if (info != 0) {
3635
xerbla_("DTRSM ", &info);
3636
return 0;
3637
}
3638
3639
/* Quick return if possible. */
3640
3641
if (*n == 0) {
3642
return 0;
3643
}
3644
3645
/* And when alpha.eq.zero. */
3646
3647
if (*alpha == 0.) {
3648
i__1 = *n;
3649
for (j = 1; j <= i__1; ++j) {
3650
i__2 = *m;
3651
for (i__ = 1; i__ <= i__2; ++i__) {
3652
b[i__ + j * b_dim1] = 0.;
3653
/* L10: */
3654
}
3655
/* L20: */
3656
}
3657
return 0;
3658
}
3659
3660
/* Start the operations. */
3661
3662
if (lside) {
3663
if (lsame_(transa, "N")) {
3664
3665
/* Form B := alpha*inv( A )*B. */
3666
3667
if (upper) {
3668
i__1 = *n;
3669
for (j = 1; j <= i__1; ++j) {
3670
if (*alpha != 1.) {
3671
i__2 = *m;
3672
for (i__ = 1; i__ <= i__2; ++i__) {
3673
b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
3674
;
3675
/* L30: */
3676
}
3677
}
3678
for (k = *m; k >= 1; --k) {
3679
if (b[k + j * b_dim1] != 0.) {
3680
if (nounit) {
3681
b[k + j * b_dim1] /= a[k + k * a_dim1];
3682
}
3683
i__2 = k - 1;
3684
for (i__ = 1; i__ <= i__2; ++i__) {
3685
b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
3686
i__ + k * a_dim1];
3687
/* L40: */
3688
}
3689
}
3690
/* L50: */
3691
}
3692
/* L60: */
3693
}
3694
} else {
3695
i__1 = *n;
3696
for (j = 1; j <= i__1; ++j) {
3697
if (*alpha != 1.) {
3698
i__2 = *m;
3699
for (i__ = 1; i__ <= i__2; ++i__) {
3700
b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
3701
;
3702
/* L70: */
3703
}
3704
}
3705
i__2 = *m;
3706
for (k = 1; k <= i__2; ++k) {
3707
if (b[k + j * b_dim1] != 0.) {
3708
if (nounit) {
3709
b[k + j * b_dim1] /= a[k + k * a_dim1];
3710
}
3711
i__3 = *m;
3712
for (i__ = k + 1; i__ <= i__3; ++i__) {
3713
b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
3714
i__ + k * a_dim1];
3715
/* L80: */
3716
}
3717
}
3718
/* L90: */
3719
}
3720
/* L100: */
3721
}
3722
}
3723
} else {
3724
3725
/* Form B := alpha*inv( A' )*B. */
3726
3727
if (upper) {
3728
i__1 = *n;
3729
for (j = 1; j <= i__1; ++j) {
3730
i__2 = *m;
3731
for (i__ = 1; i__ <= i__2; ++i__) {
3732
temp = *alpha * b[i__ + j * b_dim1];
3733
i__3 = i__ - 1;
3734
for (k = 1; k <= i__3; ++k) {
3735
temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
3736
/* L110: */
3737
}
3738
if (nounit) {
3739
temp /= a[i__ + i__ * a_dim1];
3740
}
3741
b[i__ + j * b_dim1] = temp;
3742
/* L120: */
3743
}
3744
/* L130: */
3745
}
3746
} else {
3747
i__1 = *n;
3748
for (j = 1; j <= i__1; ++j) {
3749
for (i__ = *m; i__ >= 1; --i__) {
3750
temp = *alpha * b[i__ + j * b_dim1];
3751
i__2 = *m;
3752
for (k = i__ + 1; k <= i__2; ++k) {
3753
temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
3754
/* L140: */
3755
}
3756
if (nounit) {
3757
temp /= a[i__ + i__ * a_dim1];
3758
}
3759
b[i__ + j * b_dim1] = temp;
3760
/* L150: */
3761
}
3762
/* L160: */
3763
}
3764
}
3765
}
3766
} else {
3767
if (lsame_(transa, "N")) {
3768
3769
/* Form B := alpha*B*inv( A ). */
3770
3771
if (upper) {
3772
i__1 = *n;
3773
for (j = 1; j <= i__1; ++j) {
3774
if (*alpha != 1.) {
3775
i__2 = *m;
3776
for (i__ = 1; i__ <= i__2; ++i__) {
3777
b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
3778
;
3779
/* L170: */
3780
}
3781
}
3782
i__2 = j - 1;
3783
for (k = 1; k <= i__2; ++k) {
3784
if (a[k + j * a_dim1] != 0.) {
3785
i__3 = *m;
3786
for (i__ = 1; i__ <= i__3; ++i__) {
3787
b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
3788
i__ + k * b_dim1];
3789
/* L180: */
3790
}
3791
}
3792
/* L190: */
3793
}
3794
if (nounit) {
3795
temp = 1. / a[j + j * a_dim1];
3796
i__2 = *m;
3797
for (i__ = 1; i__ <= i__2; ++i__) {
3798
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
3799
/* L200: */
3800
}
3801
}
3802
/* L210: */
3803
}
3804
} else {
3805
for (j = *n; j >= 1; --j) {
3806
if (*alpha != 1.) {
3807
i__1 = *m;
3808
for (i__ = 1; i__ <= i__1; ++i__) {
3809
b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
3810
;
3811
/* L220: */
3812
}
3813
}
3814
i__1 = *n;
3815
for (k = j + 1; k <= i__1; ++k) {
3816
if (a[k + j * a_dim1] != 0.) {
3817
i__2 = *m;
3818
for (i__ = 1; i__ <= i__2; ++i__) {
3819
b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
3820
i__ + k * b_dim1];
3821
/* L230: */
3822
}
3823
}
3824
/* L240: */
3825
}
3826
if (nounit) {
3827
temp = 1. / a[j + j * a_dim1];
3828
i__1 = *m;
3829
for (i__ = 1; i__ <= i__1; ++i__) {
3830
b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
3831
/* L250: */
3832
}
3833
}
3834
/* L260: */
3835
}
3836
}
3837
} else {
3838
3839
/* Form B := alpha*B*inv( A' ). */
3840
3841
if (upper) {
3842
for (k = *n; k >= 1; --k) {
3843
if (nounit) {
3844
temp = 1. / a[k + k * a_dim1];
3845
i__1 = *m;
3846
for (i__ = 1; i__ <= i__1; ++i__) {
3847
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
3848
/* L270: */
3849
}
3850
}
3851
i__1 = k - 1;
3852
for (j = 1; j <= i__1; ++j) {
3853
if (a[j + k * a_dim1] != 0.) {
3854
temp = a[j + k * a_dim1];
3855
i__2 = *m;
3856
for (i__ = 1; i__ <= i__2; ++i__) {
3857
b[i__ + j * b_dim1] -= temp * b[i__ + k *
3858
b_dim1];
3859
/* L280: */
3860
}
3861
}
3862
/* L290: */
3863
}
3864
if (*alpha != 1.) {
3865
i__1 = *m;
3866
for (i__ = 1; i__ <= i__1; ++i__) {
3867
b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
3868
;
3869
/* L300: */
3870
}
3871
}
3872
/* L310: */
3873
}
3874
} else {
3875
i__1 = *n;
3876
for (k = 1; k <= i__1; ++k) {
3877
if (nounit) {
3878
temp = 1. / a[k + k * a_dim1];
3879
i__2 = *m;
3880
for (i__ = 1; i__ <= i__2; ++i__) {
3881
b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
3882
/* L320: */
3883
}
3884
}
3885
i__2 = *n;
3886
for (j = k + 1; j <= i__2; ++j) {
3887
if (a[j + k * a_dim1] != 0.) {
3888
temp = a[j + k * a_dim1];
3889
i__3 = *m;
3890
for (i__ = 1; i__ <= i__3; ++i__) {
3891
b[i__ + j * b_dim1] -= temp * b[i__ + k *
3892
b_dim1];
3893
/* L330: */
3894
}
3895
}
3896
/* L340: */
3897
}
3898
if (*alpha != 1.) {
3899
i__2 = *m;
3900
for (i__ = 1; i__ <= i__2; ++i__) {
3901
b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
3902
;
3903
/* L350: */
3904
}
3905
}
3906
/* L360: */
3907
}
3908
}
3909
}
3910
}
3911
3912
return 0;
3913
3914
/* End of DTRSM . */
3915
3916
} /* dtrsm_ */
3917
3918
doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx)
3919
{
3920
/* System generated locals */
3921
integer i__1;
3922
doublereal ret_val;
3923
3924
/* Local variables */
3925
static integer i__, ix;
3926
static doublereal stemp;
3927
extern doublereal dcabs1_(doublecomplex *);
3928
3929
3930
/*
3931
takes the sum of the absolute values.
3932
jack dongarra, 3/11/78.
3933
modified 3/93 to return if incx .le. 0.
3934
modified 12/3/93, array(1) declarations changed to array(*)
3935
*/
3936
3937
3938
/* Parameter adjustments */
3939
--zx;
3940
3941
/* Function Body */
3942
ret_val = 0.;
3943
stemp = 0.;
3944
if (*n <= 0 || *incx <= 0) {
3945
return ret_val;
3946
}
3947
if (*incx == 1) {
3948
goto L20;
3949
}
3950
3951
/* code for increment not equal to 1 */
3952
3953
ix = 1;
3954
i__1 = *n;
3955
for (i__ = 1; i__ <= i__1; ++i__) {
3956
stemp += dcabs1_(&zx[ix]);
3957
ix += *incx;
3958
/* L10: */
3959
}
3960
ret_val = stemp;
3961
return ret_val;
3962
3963
/* code for increment equal to 1 */
3964
3965
L20:
3966
i__1 = *n;
3967
for (i__ = 1; i__ <= i__1; ++i__) {
3968
stemp += dcabs1_(&zx[i__]);
3969
/* L30: */
3970
}
3971
ret_val = stemp;
3972
return ret_val;
3973
} /* dzasum_ */
3974
3975
doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx)
3976
{
3977
/* System generated locals */
3978
integer i__1, i__2, i__3;
3979
doublereal ret_val, d__1;
3980
3981
/* Builtin functions */
3982
double d_imag(doublecomplex *), sqrt(doublereal);
3983
3984
/* Local variables */
3985
static integer ix;
3986
static doublereal ssq, temp, norm, scale;
3987
3988
3989
/*
3990
DZNRM2 returns the euclidean norm of a vector via the function
3991
name, so that
3992
3993
DZNRM2 := sqrt( conjg( x' )*x )
3994
3995
3996
-- This version written on 25-October-1982.
3997
Modified on 14-October-1993 to inline the call to ZLASSQ.
3998
Sven Hammarling, Nag Ltd.
3999
*/
4000
4001
4002
/* Parameter adjustments */
4003
--x;
4004
4005
/* Function Body */
4006
if (*n < 1 || *incx < 1) {
4007
norm = 0.;
4008
} else {
4009
scale = 0.;
4010
ssq = 1.;
4011
/*
4012
The following loop is equivalent to this call to the LAPACK
4013
auxiliary routine:
4014
CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
4015
*/
4016
4017
i__1 = (*n - 1) * *incx + 1;
4018
i__2 = *incx;
4019
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
4020
i__3 = ix;
4021
if (x[i__3].r != 0.) {
4022
i__3 = ix;
4023
temp = (d__1 = x[i__3].r, abs(d__1));
4024
if (scale < temp) {
4025
/* Computing 2nd power */
4026
d__1 = scale / temp;
4027
ssq = ssq * (d__1 * d__1) + 1.;
4028
scale = temp;
4029
} else {
4030
/* Computing 2nd power */
4031
d__1 = temp / scale;
4032
ssq += d__1 * d__1;
4033
}
4034
}
4035
if (d_imag(&x[ix]) != 0.) {
4036
temp = (d__1 = d_imag(&x[ix]), abs(d__1));
4037
if (scale < temp) {
4038
/* Computing 2nd power */
4039
d__1 = scale / temp;
4040
ssq = ssq * (d__1 * d__1) + 1.;
4041
scale = temp;
4042
} else {
4043
/* Computing 2nd power */
4044
d__1 = temp / scale;
4045
ssq += d__1 * d__1;
4046
}
4047
}
4048
/* L10: */
4049
}
4050
norm = scale * sqrt(ssq);
4051
}
4052
4053
ret_val = norm;
4054
return ret_val;
4055
4056
/* End of DZNRM2. */
4057
4058
} /* dznrm2_ */
4059
4060
integer idamax_(integer *n, doublereal *dx, integer *incx)
4061
{
4062
/* System generated locals */
4063
integer ret_val, i__1;
4064
doublereal d__1;
4065
4066
/* Local variables */
4067
static integer i__, ix;
4068
static doublereal dmax__;
4069
4070
4071
/*
4072
finds the index of element having max. absolute value.
4073
jack dongarra, linpack, 3/11/78.
4074
modified 3/93 to return if incx .le. 0.
4075
modified 12/3/93, array(1) declarations changed to array(*)
4076
*/
4077
4078
4079
/* Parameter adjustments */
4080
--dx;
4081
4082
/* Function Body */
4083
ret_val = 0;
4084
if (*n < 1 || *incx <= 0) {
4085
return ret_val;
4086
}
4087
ret_val = 1;
4088
if (*n == 1) {
4089
return ret_val;
4090
}
4091
if (*incx == 1) {
4092
goto L20;
4093
}
4094
4095
/* code for increment not equal to 1 */
4096
4097
ix = 1;
4098
dmax__ = abs(dx[1]);
4099
ix += *incx;
4100
i__1 = *n;
4101
for (i__ = 2; i__ <= i__1; ++i__) {
4102
if ((d__1 = dx[ix], abs(d__1)) <= dmax__) {
4103
goto L5;
4104
}
4105
ret_val = i__;
4106
dmax__ = (d__1 = dx[ix], abs(d__1));
4107
L5:
4108
ix += *incx;
4109
/* L10: */
4110
}
4111
return ret_val;
4112
4113
/* code for increment equal to 1 */
4114
4115
L20:
4116
dmax__ = abs(dx[1]);
4117
i__1 = *n;
4118
for (i__ = 2; i__ <= i__1; ++i__) {
4119
if ((d__1 = dx[i__], abs(d__1)) <= dmax__) {
4120
goto L30;
4121
}
4122
ret_val = i__;
4123
dmax__ = (d__1 = dx[i__], abs(d__1));
4124
L30:
4125
;
4126
}
4127
return ret_val;
4128
} /* idamax_ */
4129
4130
integer izamax_(integer *n, doublecomplex *zx, integer *incx)
4131
{
4132
/* System generated locals */
4133
integer ret_val, i__1;
4134
4135
/* Local variables */
4136
static integer i__, ix;
4137
static doublereal smax;
4138
extern doublereal dcabs1_(doublecomplex *);
4139
4140
4141
/*
4142
finds the index of element having max. absolute value.
4143
jack dongarra, 1/15/85.
4144
modified 3/93 to return if incx .le. 0.
4145
modified 12/3/93, array(1) declarations changed to array(*)
4146
*/
4147
4148
4149
/* Parameter adjustments */
4150
--zx;
4151
4152
/* Function Body */
4153
ret_val = 0;
4154
if (*n < 1 || *incx <= 0) {
4155
return ret_val;
4156
}
4157
ret_val = 1;
4158
if (*n == 1) {
4159
return ret_val;
4160
}
4161
if (*incx == 1) {
4162
goto L20;
4163
}
4164
4165
/* code for increment not equal to 1 */
4166
4167
ix = 1;
4168
smax = dcabs1_(&zx[1]);
4169
ix += *incx;
4170
i__1 = *n;
4171
for (i__ = 2; i__ <= i__1; ++i__) {
4172
if (dcabs1_(&zx[ix]) <= smax) {
4173
goto L5;
4174
}
4175
ret_val = i__;
4176
smax = dcabs1_(&zx[ix]);
4177
L5:
4178
ix += *incx;
4179
/* L10: */
4180
}
4181
return ret_val;
4182
4183
/* code for increment equal to 1 */
4184
4185
L20:
4186
smax = dcabs1_(&zx[1]);
4187
i__1 = *n;
4188
for (i__ = 2; i__ <= i__1; ++i__) {
4189
if (dcabs1_(&zx[i__]) <= smax) {
4190
goto L30;
4191
}
4192
ret_val = i__;
4193
smax = dcabs1_(&zx[i__]);
4194
L30:
4195
;
4196
}
4197
return ret_val;
4198
} /* izamax_ */
4199
4200
logical lsame_(char *ca, char *cb)
4201
{
4202
/* System generated locals */
4203
logical ret_val;
4204
4205
/* Local variables */
4206
static integer inta, intb, zcode;
4207
4208
4209
/*
4210
-- LAPACK auxiliary routine (version 3.0) --
4211
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
4212
Courant Institute, Argonne National Lab, and Rice University
4213
September 30, 1994
4214
4215
4216
Purpose
4217
=======
4218
4219
LSAME returns .TRUE. if CA is the same letter as CB regardless of
4220
case.
4221
4222
Arguments
4223
=========
4224
4225
CA (input) CHARACTER*1
4226
CB (input) CHARACTER*1
4227
CA and CB specify the single characters to be compared.
4228
4229
=====================================================================
4230
4231
4232
Test if the characters are equal
4233
*/
4234
4235
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
4236
if (ret_val) {
4237
return ret_val;
4238
}
4239
4240
/* Now test for equivalence if both characters are alphabetic. */
4241
4242
zcode = 'Z';
4243
4244
/*
4245
Use 'Z' rather than 'A' so that ASCII can be detected on Prime
4246
machines, on which ICHAR returns a value with bit 8 set.
4247
ICHAR('A') on Prime machines returns 193 which is the same as
4248
ICHAR('A') on an EBCDIC machine.
4249
*/
4250
4251
inta = *(unsigned char *)ca;
4252
intb = *(unsigned char *)cb;
4253
4254
if (zcode == 90 || zcode == 122) {
4255
4256
/*
4257
ASCII is assumed - ZCODE is the ASCII code of either lower or
4258
upper case 'Z'.
4259
*/
4260
4261
if ((inta >= 97 && inta <= 122)) {
4262
inta += -32;
4263
}
4264
if ((intb >= 97 && intb <= 122)) {
4265
intb += -32;
4266
}
4267
4268
} else if (zcode == 233 || zcode == 169) {
4269
4270
/*
4271
EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
4272
upper case 'Z'.
4273
*/
4274
4275
if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) || (
4276
inta >= 162 && inta <= 169)) {
4277
inta += 64;
4278
}
4279
if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) || (
4280
intb >= 162 && intb <= 169)) {
4281
intb += 64;
4282
}
4283
4284
} else if (zcode == 218 || zcode == 250) {
4285
4286
/*
4287
ASCII is assumed, on Prime machines - ZCODE is the ASCII code
4288
plus 128 of either lower or upper case 'Z'.
4289
*/
4290
4291
if ((inta >= 225 && inta <= 250)) {
4292
inta += -32;
4293
}
4294
if ((intb >= 225 && intb <= 250)) {
4295
intb += -32;
4296
}
4297
}
4298
ret_val = inta == intb;
4299
4300
/*
4301
RETURN
4302
4303
End of LSAME
4304
*/
4305
4306
return ret_val;
4307
} /* lsame_ */
4308
4309
/* Subroutine */ int xerbla_(char *srname, integer *info)
4310
{
4311
/* Format strings */
4312
static char fmt_9999[] = "(\002 ** On entry to \002,a6,\002 parameter nu"
4313
"mber \002,i2,\002 had \002,\002an illegal value\002)";
4314
4315
/* Builtin functions */
4316
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
4317
/* Subroutine */ int s_stop(char *, ftnlen);
4318
4319
/* Fortran I/O blocks */
4320
static cilist io___147 = { 0, 6, 0, fmt_9999, 0 };
4321
4322
4323
/*
4324
-- LAPACK auxiliary routine (preliminary version) --
4325
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
4326
Courant Institute, Argonne National Lab, and Rice University
4327
February 29, 1992
4328
4329
4330
Purpose
4331
=======
4332
4333
XERBLA is an error handler for the LAPACK routines.
4334
It is called by an LAPACK routine if an input parameter has an
4335
invalid value. A message is printed and execution stops.
4336
4337
Installers may consider modifying the STOP statement in order to
4338
call system-specific exception-handling facilities.
4339
4340
Arguments
4341
=========
4342
4343
SRNAME (input) CHARACTER*6
4344
The name of the routine which called XERBLA.
4345
4346
INFO (input) INTEGER
4347
The position of the invalid parameter in the parameter list
4348
of the calling routine.
4349
*/
4350
4351
4352
s_wsfe(&io___147);
4353
do_fio(&c__1, srname, (ftnlen)6);
4354
do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
4355
e_wsfe();
4356
4357
s_stop("", (ftnlen)0);
4358
4359
4360
/* End of XERBLA */
4361
4362
return 0;
4363
} /* xerbla_ */
4364
4365
/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx,
4366
integer *incx, doublecomplex *zy, integer *incy)
4367
{
4368
/* System generated locals */
4369
integer i__1, i__2, i__3, i__4;
4370
doublecomplex z__1, z__2;
4371
4372
/* Local variables */
4373
static integer i__, ix, iy;
4374
extern doublereal dcabs1_(doublecomplex *);
4375
4376
4377
/*
4378
constant times a vector plus a vector.
4379
jack dongarra, 3/11/78.
4380
modified 12/3/93, array(1) declarations changed to array(*)
4381
*/
4382
4383
/* Parameter adjustments */
4384
--zy;
4385
--zx;
4386
4387
/* Function Body */
4388
if (*n <= 0) {
4389
return 0;
4390
}
4391
if (dcabs1_(za) == 0.) {
4392
return 0;
4393
}
4394
if ((*incx == 1 && *incy == 1)) {
4395
goto L20;
4396
}
4397
4398
/*
4399
code for unequal increments or equal increments
4400
not equal to 1
4401
*/
4402
4403
ix = 1;
4404
iy = 1;
4405
if (*incx < 0) {
4406
ix = (-(*n) + 1) * *incx + 1;
4407
}
4408
if (*incy < 0) {
4409
iy = (-(*n) + 1) * *incy + 1;
4410
}
4411
i__1 = *n;
4412
for (i__ = 1; i__ <= i__1; ++i__) {
4413
i__2 = iy;
4414
i__3 = iy;
4415
i__4 = ix;
4416
z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[
4417
i__4].i + za->i * zx[i__4].r;
4418
z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i;
4419
zy[i__2].r = z__1.r, zy[i__2].i = z__1.i;
4420
ix += *incx;
4421
iy += *incy;
4422
/* L10: */
4423
}
4424
return 0;
4425
4426
/* code for both increments equal to 1 */
4427
4428
L20:
4429
i__1 = *n;
4430
for (i__ = 1; i__ <= i__1; ++i__) {
4431
i__2 = i__;
4432
i__3 = i__;
4433
i__4 = i__;
4434
z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[
4435
i__4].i + za->i * zx[i__4].r;
4436
z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i;
4437
zy[i__2].r = z__1.r, zy[i__2].i = z__1.i;
4438
/* L30: */
4439
}
4440
return 0;
4441
} /* zaxpy_ */
4442
4443
/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx,
4444
doublecomplex *zy, integer *incy)
4445
{
4446
/* System generated locals */
4447
integer i__1, i__2, i__3;
4448
4449
/* Local variables */
4450
static integer i__, ix, iy;
4451
4452
4453
/*
4454
copies a vector, x, to a vector, y.
4455
jack dongarra, linpack, 4/11/78.
4456
modified 12/3/93, array(1) declarations changed to array(*)
4457
*/
4458
4459
4460
/* Parameter adjustments */
4461
--zy;
4462
--zx;
4463
4464
/* Function Body */
4465
if (*n <= 0) {
4466
return 0;
4467
}
4468
if ((*incx == 1 && *incy == 1)) {
4469
goto L20;
4470
}
4471
4472
/*
4473
code for unequal increments or equal increments
4474
not equal to 1
4475
*/
4476
4477
ix = 1;
4478
iy = 1;
4479
if (*incx < 0) {
4480
ix = (-(*n) + 1) * *incx + 1;
4481
}
4482
if (*incy < 0) {
4483
iy = (-(*n) + 1) * *incy + 1;
4484
}
4485
i__1 = *n;
4486
for (i__ = 1; i__ <= i__1; ++i__) {
4487
i__2 = iy;
4488
i__3 = ix;
4489
zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
4490
ix += *incx;
4491
iy += *incy;
4492
/* L10: */
4493
}
4494
return 0;
4495
4496
/* code for both increments equal to 1 */
4497
4498
L20:
4499
i__1 = *n;
4500
for (i__ = 1; i__ <= i__1; ++i__) {
4501
i__2 = i__;
4502
i__3 = i__;
4503
zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
4504
/* L30: */
4505
}
4506
return 0;
4507
} /* zcopy_ */
4508
4509
/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n,
4510
doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy)
4511
{
4512
/* System generated locals */
4513
integer i__1, i__2;
4514
doublecomplex z__1, z__2, z__3;
4515
4516
/* Builtin functions */
4517
void d_cnjg(doublecomplex *, doublecomplex *);
4518
4519
/* Local variables */
4520
static integer i__, ix, iy;
4521
static doublecomplex ztemp;
4522
4523
4524
/*
4525
forms the dot product of a vector.
4526
jack dongarra, 3/11/78.
4527
modified 12/3/93, array(1) declarations changed to array(*)
4528
*/
4529
4530
/* Parameter adjustments */
4531
--zy;
4532
--zx;
4533
4534
/* Function Body */
4535
ztemp.r = 0., ztemp.i = 0.;
4536
ret_val->r = 0., ret_val->i = 0.;
4537
if (*n <= 0) {
4538
return ;
4539
}
4540
if ((*incx == 1 && *incy == 1)) {
4541
goto L20;
4542
}
4543
4544
/*
4545
code for unequal increments or equal increments
4546
not equal to 1
4547
*/
4548
4549
ix = 1;
4550
iy = 1;
4551
if (*incx < 0) {
4552
ix = (-(*n) + 1) * *incx + 1;
4553
}
4554
if (*incy < 0) {
4555
iy = (-(*n) + 1) * *incy + 1;
4556
}
4557
i__1 = *n;
4558
for (i__ = 1; i__ <= i__1; ++i__) {
4559
d_cnjg(&z__3, &zx[ix]);
4560
i__2 = iy;
4561
z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r *
4562
zy[i__2].i + z__3.i * zy[i__2].r;
4563
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
4564
ztemp.r = z__1.r, ztemp.i = z__1.i;
4565
ix += *incx;
4566
iy += *incy;
4567
/* L10: */
4568
}
4569
ret_val->r = ztemp.r, ret_val->i = ztemp.i;
4570
return ;
4571
4572
/* code for both increments equal to 1 */
4573
4574
L20:
4575
i__1 = *n;
4576
for (i__ = 1; i__ <= i__1; ++i__) {
4577
d_cnjg(&z__3, &zx[i__]);
4578
i__2 = i__;
4579
z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r *
4580
zy[i__2].i + z__3.i * zy[i__2].r;
4581
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
4582
ztemp.r = z__1.r, ztemp.i = z__1.i;
4583
/* L30: */
4584
}
4585
ret_val->r = ztemp.r, ret_val->i = ztemp.i;
4586
return ;
4587
} /* zdotc_ */
4588
4589
/* Double Complex */ VOID zdotu_(doublecomplex * ret_val, integer *n,
4590
doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy)
4591
{
4592
/* System generated locals */
4593
integer i__1, i__2, i__3;
4594
doublecomplex z__1, z__2;
4595
4596
/* Local variables */
4597
static integer i__, ix, iy;
4598
static doublecomplex ztemp;
4599
4600
4601
/*
4602
forms the dot product of two vectors.
4603
jack dongarra, 3/11/78.
4604
modified 12/3/93, array(1) declarations changed to array(*)
4605
*/
4606
4607
/* Parameter adjustments */
4608
--zy;
4609
--zx;
4610
4611
/* Function Body */
4612
ztemp.r = 0., ztemp.i = 0.;
4613
ret_val->r = 0., ret_val->i = 0.;
4614
if (*n <= 0) {
4615
return ;
4616
}
4617
if ((*incx == 1 && *incy == 1)) {
4618
goto L20;
4619
}
4620
4621
/*
4622
code for unequal increments or equal increments
4623
not equal to 1
4624
*/
4625
4626
ix = 1;
4627
iy = 1;
4628
if (*incx < 0) {
4629
ix = (-(*n) + 1) * *incx + 1;
4630
}
4631
if (*incy < 0) {
4632
iy = (-(*n) + 1) * *incy + 1;
4633
}
4634
i__1 = *n;
4635
for (i__ = 1; i__ <= i__1; ++i__) {
4636
i__2 = ix;
4637
i__3 = iy;
4638
z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i =
4639
zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
4640
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
4641
ztemp.r = z__1.r, ztemp.i = z__1.i;
4642
ix += *incx;
4643
iy += *incy;
4644
/* L10: */
4645
}
4646
ret_val->r = ztemp.r, ret_val->i = ztemp.i;
4647
return ;
4648
4649
/* code for both increments equal to 1 */
4650
4651
L20:
4652
i__1 = *n;
4653
for (i__ = 1; i__ <= i__1; ++i__) {
4654
i__2 = i__;
4655
i__3 = i__;
4656
z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i =
4657
zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
4658
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
4659
ztemp.r = z__1.r, ztemp.i = z__1.i;
4660
/* L30: */
4661
}
4662
ret_val->r = ztemp.r, ret_val->i = ztemp.i;
4663
return ;
4664
} /* zdotu_ */
4665
4666
/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx,
4667
integer *incx)
4668
{
4669
/* System generated locals */
4670
integer i__1, i__2, i__3;
4671
doublecomplex z__1, z__2;
4672
4673
/* Local variables */
4674
static integer i__, ix;
4675
4676
4677
/*
4678
scales a vector by a constant.
4679
jack dongarra, 3/11/78.
4680
modified 3/93 to return if incx .le. 0.
4681
modified 12/3/93, array(1) declarations changed to array(*)
4682
*/
4683
4684
4685
/* Parameter adjustments */
4686
--zx;
4687
4688
/* Function Body */
4689
if (*n <= 0 || *incx <= 0) {
4690
return 0;
4691
}
4692
if (*incx == 1) {
4693
goto L20;
4694
}
4695
4696
/* code for increment not equal to 1 */
4697
4698
ix = 1;
4699
i__1 = *n;
4700
for (i__ = 1; i__ <= i__1; ++i__) {
4701
i__2 = ix;
4702
z__2.r = *da, z__2.i = 0.;
4703
i__3 = ix;
4704
z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r *
4705
zx[i__3].i + z__2.i * zx[i__3].r;
4706
zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
4707
ix += *incx;
4708
/* L10: */
4709
}
4710
return 0;
4711
4712
/* code for increment equal to 1 */
4713
4714
L20:
4715
i__1 = *n;
4716
for (i__ = 1; i__ <= i__1; ++i__) {
4717
i__2 = i__;
4718
z__2.r = *da, z__2.i = 0.;
4719
i__3 = i__;
4720
z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r *
4721
zx[i__3].i + z__2.i * zx[i__3].r;
4722
zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
4723
/* L30: */
4724
}
4725
return 0;
4726
} /* zdscal_ */
4727
4728
/* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer *
4729
n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
4730
doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
4731
c__, integer *ldc)
4732
{
4733
/* System generated locals */
4734
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
4735
i__3, i__4, i__5, i__6;
4736
doublecomplex z__1, z__2, z__3, z__4;
4737
4738
/* Builtin functions */
4739
void d_cnjg(doublecomplex *, doublecomplex *);
4740
4741
/* Local variables */
4742
static integer i__, j, l, info;
4743
static logical nota, notb;
4744
static doublecomplex temp;
4745
static logical conja, conjb;
4746
static integer ncola;
4747
extern logical lsame_(char *, char *);
4748
static integer nrowa, nrowb;
4749
extern /* Subroutine */ int xerbla_(char *, integer *);
4750
4751
4752
/*
4753
Purpose
4754
=======
4755
4756
ZGEMM performs one of the matrix-matrix operations
4757
4758
C := alpha*op( A )*op( B ) + beta*C,
4759
4760
where op( X ) is one of
4761
4762
op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ),
4763
4764
alpha and beta are scalars, and A, B and C are matrices, with op( A )
4765
an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
4766
4767
Parameters
4768
==========
4769
4770
TRANSA - CHARACTER*1.
4771
On entry, TRANSA specifies the form of op( A ) to be used in
4772
the matrix multiplication as follows:
4773
4774
TRANSA = 'N' or 'n', op( A ) = A.
4775
4776
TRANSA = 'T' or 't', op( A ) = A'.
4777
4778
TRANSA = 'C' or 'c', op( A ) = conjg( A' ).
4779
4780
Unchanged on exit.
4781
4782
TRANSB - CHARACTER*1.
4783
On entry, TRANSB specifies the form of op( B ) to be used in
4784
the matrix multiplication as follows:
4785
4786
TRANSB = 'N' or 'n', op( B ) = B.
4787
4788
TRANSB = 'T' or 't', op( B ) = B'.
4789
4790
TRANSB = 'C' or 'c', op( B ) = conjg( B' ).
4791
4792
Unchanged on exit.
4793
4794
M - INTEGER.
4795
On entry, M specifies the number of rows of the matrix
4796
op( A ) and of the matrix C. M must be at least zero.
4797
Unchanged on exit.
4798
4799
N - INTEGER.
4800
On entry, N specifies the number of columns of the matrix
4801
op( B ) and the number of columns of the matrix C. N must be
4802
at least zero.
4803
Unchanged on exit.
4804
4805
K - INTEGER.
4806
On entry, K specifies the number of columns of the matrix
4807
op( A ) and the number of rows of the matrix op( B ). K must
4808
be at least zero.
4809
Unchanged on exit.
4810
4811
ALPHA - COMPLEX*16 .
4812
On entry, ALPHA specifies the scalar alpha.
4813
Unchanged on exit.
4814
4815
A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
4816
k when TRANSA = 'N' or 'n', and is m otherwise.
4817
Before entry with TRANSA = 'N' or 'n', the leading m by k
4818
part of the array A must contain the matrix A, otherwise
4819
the leading k by m part of the array A must contain the
4820
matrix A.
4821
Unchanged on exit.
4822
4823
LDA - INTEGER.
4824
On entry, LDA specifies the first dimension of A as declared
4825
in the calling (sub) program. When TRANSA = 'N' or 'n' then
4826
LDA must be at least max( 1, m ), otherwise LDA must be at
4827
least max( 1, k ).
4828
Unchanged on exit.
4829
4830
B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
4831
n when TRANSB = 'N' or 'n', and is k otherwise.
4832
Before entry with TRANSB = 'N' or 'n', the leading k by n
4833
part of the array B must contain the matrix B, otherwise
4834
the leading n by k part of the array B must contain the
4835
matrix B.
4836
Unchanged on exit.
4837
4838
LDB - INTEGER.
4839
On entry, LDB specifies the first dimension of B as declared
4840
in the calling (sub) program. When TRANSB = 'N' or 'n' then
4841
LDB must be at least max( 1, k ), otherwise LDB must be at
4842
least max( 1, n ).
4843
Unchanged on exit.
4844
4845
BETA - COMPLEX*16 .
4846
On entry, BETA specifies the scalar beta. When BETA is
4847
supplied as zero then C need not be set on input.
4848
Unchanged on exit.
4849
4850
C - COMPLEX*16 array of DIMENSION ( LDC, n ).
4851
Before entry, the leading m by n part of the array C must
4852
contain the matrix C, except when beta is zero, in which
4853
case C need not be set on entry.
4854
On exit, the array C is overwritten by the m by n matrix
4855
( alpha*op( A )*op( B ) + beta*C ).
4856
4857
LDC - INTEGER.
4858
On entry, LDC specifies the first dimension of C as declared
4859
in the calling (sub) program. LDC must be at least
4860
max( 1, m ).
4861
Unchanged on exit.
4862
4863
4864
Level 3 Blas routine.
4865
4866
-- Written on 8-February-1989.
4867
Jack Dongarra, Argonne National Laboratory.
4868
Iain Duff, AERE Harwell.
4869
Jeremy Du Croz, Numerical Algorithms Group Ltd.
4870
Sven Hammarling, Numerical Algorithms Group Ltd.
4871
4872
4873
Set NOTA and NOTB as true if A and B respectively are not
4874
conjugated or transposed, set CONJA and CONJB as true if A and
4875
B respectively are to be transposed but not conjugated and set
4876
NROWA, NCOLA and NROWB as the number of rows and columns of A
4877
and the number of rows of B respectively.
4878
*/
4879
4880
/* Parameter adjustments */
4881
a_dim1 = *lda;
4882
a_offset = 1 + a_dim1 * 1;
4883
a -= a_offset;
4884
b_dim1 = *ldb;
4885
b_offset = 1 + b_dim1 * 1;
4886
b -= b_offset;
4887
c_dim1 = *ldc;
4888
c_offset = 1 + c_dim1 * 1;
4889
c__ -= c_offset;
4890
4891
/* Function Body */
4892
nota = lsame_(transa, "N");
4893
notb = lsame_(transb, "N");
4894
conja = lsame_(transa, "C");
4895
conjb = lsame_(transb, "C");
4896
if (nota) {
4897
nrowa = *m;
4898
ncola = *k;
4899
} else {
4900
nrowa = *k;
4901
ncola = *m;
4902
}
4903
if (notb) {
4904
nrowb = *k;
4905
} else {
4906
nrowb = *n;
4907
}
4908
4909
/* Test the input parameters. */
4910
4911
info = 0;
4912
if (((! nota && ! conja) && ! lsame_(transa, "T")))
4913
{
4914
info = 1;
4915
} else if (((! notb && ! conjb) && ! lsame_(transb, "T"))) {
4916
info = 2;
4917
} else if (*m < 0) {
4918
info = 3;
4919
} else if (*n < 0) {
4920
info = 4;
4921
} else if (*k < 0) {
4922
info = 5;
4923
} else if (*lda < max(1,nrowa)) {
4924
info = 8;
4925
} else if (*ldb < max(1,nrowb)) {
4926
info = 10;
4927
} else if (*ldc < max(1,*m)) {
4928
info = 13;
4929
}
4930
if (info != 0) {
4931
xerbla_("ZGEMM ", &info);
4932
return 0;
4933
}
4934
4935
/* Quick return if possible. */
4936
4937
if (*m == 0 || *n == 0 || (((alpha->r == 0. && alpha->i == 0.) || *k == 0)
4938
&& ((beta->r == 1. && beta->i == 0.)))) {
4939
return 0;
4940
}
4941
4942
/* And when alpha.eq.zero. */
4943
4944
if ((alpha->r == 0. && alpha->i == 0.)) {
4945
if ((beta->r == 0. && beta->i == 0.)) {
4946
i__1 = *n;
4947
for (j = 1; j <= i__1; ++j) {
4948
i__2 = *m;
4949
for (i__ = 1; i__ <= i__2; ++i__) {
4950
i__3 = i__ + j * c_dim1;
4951
c__[i__3].r = 0., c__[i__3].i = 0.;
4952
/* L10: */
4953
}
4954
/* L20: */
4955
}
4956
} else {
4957
i__1 = *n;
4958
for (j = 1; j <= i__1; ++j) {
4959
i__2 = *m;
4960
for (i__ = 1; i__ <= i__2; ++i__) {
4961
i__3 = i__ + j * c_dim1;
4962
i__4 = i__ + j * c_dim1;
4963
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
4964
z__1.i = beta->r * c__[i__4].i + beta->i * c__[
4965
i__4].r;
4966
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
4967
/* L30: */
4968
}
4969
/* L40: */
4970
}
4971
}
4972
return 0;
4973
}
4974
4975
/* Start the operations. */
4976
4977
if (notb) {
4978
if (nota) {
4979
4980
/* Form C := alpha*A*B + beta*C. */
4981
4982
i__1 = *n;
4983
for (j = 1; j <= i__1; ++j) {
4984
if ((beta->r == 0. && beta->i == 0.)) {
4985
i__2 = *m;
4986
for (i__ = 1; i__ <= i__2; ++i__) {
4987
i__3 = i__ + j * c_dim1;
4988
c__[i__3].r = 0., c__[i__3].i = 0.;
4989
/* L50: */
4990
}
4991
} else if (beta->r != 1. || beta->i != 0.) {
4992
i__2 = *m;
4993
for (i__ = 1; i__ <= i__2; ++i__) {
4994
i__3 = i__ + j * c_dim1;
4995
i__4 = i__ + j * c_dim1;
4996
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
4997
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
4998
c__[i__4].r;
4999
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5000
/* L60: */
5001
}
5002
}
5003
i__2 = *k;
5004
for (l = 1; l <= i__2; ++l) {
5005
i__3 = l + j * b_dim1;
5006
if (b[i__3].r != 0. || b[i__3].i != 0.) {
5007
i__3 = l + j * b_dim1;
5008
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
5009
z__1.i = alpha->r * b[i__3].i + alpha->i * b[
5010
i__3].r;
5011
temp.r = z__1.r, temp.i = z__1.i;
5012
i__3 = *m;
5013
for (i__ = 1; i__ <= i__3; ++i__) {
5014
i__4 = i__ + j * c_dim1;
5015
i__5 = i__ + j * c_dim1;
5016
i__6 = i__ + l * a_dim1;
5017
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
5018
z__2.i = temp.r * a[i__6].i + temp.i * a[
5019
i__6].r;
5020
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
5021
.i + z__2.i;
5022
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
5023
/* L70: */
5024
}
5025
}
5026
/* L80: */
5027
}
5028
/* L90: */
5029
}
5030
} else if (conja) {
5031
5032
/* Form C := alpha*conjg( A' )*B + beta*C. */
5033
5034
i__1 = *n;
5035
for (j = 1; j <= i__1; ++j) {
5036
i__2 = *m;
5037
for (i__ = 1; i__ <= i__2; ++i__) {
5038
temp.r = 0., temp.i = 0.;
5039
i__3 = *k;
5040
for (l = 1; l <= i__3; ++l) {
5041
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
5042
i__4 = l + j * b_dim1;
5043
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
5044
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
5045
.r;
5046
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5047
temp.r = z__1.r, temp.i = z__1.i;
5048
/* L100: */
5049
}
5050
if ((beta->r == 0. && beta->i == 0.)) {
5051
i__3 = i__ + j * c_dim1;
5052
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5053
z__1.i = alpha->r * temp.i + alpha->i *
5054
temp.r;
5055
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5056
} else {
5057
i__3 = i__ + j * c_dim1;
5058
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5059
z__2.i = alpha->r * temp.i + alpha->i *
5060
temp.r;
5061
i__4 = i__ + j * c_dim1;
5062
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5063
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5064
c__[i__4].r;
5065
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5066
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5067
}
5068
/* L110: */
5069
}
5070
/* L120: */
5071
}
5072
} else {
5073
5074
/* Form C := alpha*A'*B + beta*C */
5075
5076
i__1 = *n;
5077
for (j = 1; j <= i__1; ++j) {
5078
i__2 = *m;
5079
for (i__ = 1; i__ <= i__2; ++i__) {
5080
temp.r = 0., temp.i = 0.;
5081
i__3 = *k;
5082
for (l = 1; l <= i__3; ++l) {
5083
i__4 = l + i__ * a_dim1;
5084
i__5 = l + j * b_dim1;
5085
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
5086
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
5087
.i * b[i__5].r;
5088
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5089
temp.r = z__1.r, temp.i = z__1.i;
5090
/* L130: */
5091
}
5092
if ((beta->r == 0. && beta->i == 0.)) {
5093
i__3 = i__ + j * c_dim1;
5094
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5095
z__1.i = alpha->r * temp.i + alpha->i *
5096
temp.r;
5097
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5098
} else {
5099
i__3 = i__ + j * c_dim1;
5100
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5101
z__2.i = alpha->r * temp.i + alpha->i *
5102
temp.r;
5103
i__4 = i__ + j * c_dim1;
5104
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5105
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5106
c__[i__4].r;
5107
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5108
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5109
}
5110
/* L140: */
5111
}
5112
/* L150: */
5113
}
5114
}
5115
} else if (nota) {
5116
if (conjb) {
5117
5118
/* Form C := alpha*A*conjg( B' ) + beta*C. */
5119
5120
i__1 = *n;
5121
for (j = 1; j <= i__1; ++j) {
5122
if ((beta->r == 0. && beta->i == 0.)) {
5123
i__2 = *m;
5124
for (i__ = 1; i__ <= i__2; ++i__) {
5125
i__3 = i__ + j * c_dim1;
5126
c__[i__3].r = 0., c__[i__3].i = 0.;
5127
/* L160: */
5128
}
5129
} else if (beta->r != 1. || beta->i != 0.) {
5130
i__2 = *m;
5131
for (i__ = 1; i__ <= i__2; ++i__) {
5132
i__3 = i__ + j * c_dim1;
5133
i__4 = i__ + j * c_dim1;
5134
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5135
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
5136
c__[i__4].r;
5137
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5138
/* L170: */
5139
}
5140
}
5141
i__2 = *k;
5142
for (l = 1; l <= i__2; ++l) {
5143
i__3 = j + l * b_dim1;
5144
if (b[i__3].r != 0. || b[i__3].i != 0.) {
5145
d_cnjg(&z__2, &b[j + l * b_dim1]);
5146
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
5147
z__1.i = alpha->r * z__2.i + alpha->i *
5148
z__2.r;
5149
temp.r = z__1.r, temp.i = z__1.i;
5150
i__3 = *m;
5151
for (i__ = 1; i__ <= i__3; ++i__) {
5152
i__4 = i__ + j * c_dim1;
5153
i__5 = i__ + j * c_dim1;
5154
i__6 = i__ + l * a_dim1;
5155
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
5156
z__2.i = temp.r * a[i__6].i + temp.i * a[
5157
i__6].r;
5158
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
5159
.i + z__2.i;
5160
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
5161
/* L180: */
5162
}
5163
}
5164
/* L190: */
5165
}
5166
/* L200: */
5167
}
5168
} else {
5169
5170
/* Form C := alpha*A*B' + beta*C */
5171
5172
i__1 = *n;
5173
for (j = 1; j <= i__1; ++j) {
5174
if ((beta->r == 0. && beta->i == 0.)) {
5175
i__2 = *m;
5176
for (i__ = 1; i__ <= i__2; ++i__) {
5177
i__3 = i__ + j * c_dim1;
5178
c__[i__3].r = 0., c__[i__3].i = 0.;
5179
/* L210: */
5180
}
5181
} else if (beta->r != 1. || beta->i != 0.) {
5182
i__2 = *m;
5183
for (i__ = 1; i__ <= i__2; ++i__) {
5184
i__3 = i__ + j * c_dim1;
5185
i__4 = i__ + j * c_dim1;
5186
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5187
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
5188
c__[i__4].r;
5189
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5190
/* L220: */
5191
}
5192
}
5193
i__2 = *k;
5194
for (l = 1; l <= i__2; ++l) {
5195
i__3 = j + l * b_dim1;
5196
if (b[i__3].r != 0. || b[i__3].i != 0.) {
5197
i__3 = j + l * b_dim1;
5198
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
5199
z__1.i = alpha->r * b[i__3].i + alpha->i * b[
5200
i__3].r;
5201
temp.r = z__1.r, temp.i = z__1.i;
5202
i__3 = *m;
5203
for (i__ = 1; i__ <= i__3; ++i__) {
5204
i__4 = i__ + j * c_dim1;
5205
i__5 = i__ + j * c_dim1;
5206
i__6 = i__ + l * a_dim1;
5207
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
5208
z__2.i = temp.r * a[i__6].i + temp.i * a[
5209
i__6].r;
5210
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
5211
.i + z__2.i;
5212
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
5213
/* L230: */
5214
}
5215
}
5216
/* L240: */
5217
}
5218
/* L250: */
5219
}
5220
}
5221
} else if (conja) {
5222
if (conjb) {
5223
5224
/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */
5225
5226
i__1 = *n;
5227
for (j = 1; j <= i__1; ++j) {
5228
i__2 = *m;
5229
for (i__ = 1; i__ <= i__2; ++i__) {
5230
temp.r = 0., temp.i = 0.;
5231
i__3 = *k;
5232
for (l = 1; l <= i__3; ++l) {
5233
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
5234
d_cnjg(&z__4, &b[j + l * b_dim1]);
5235
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i =
5236
z__3.r * z__4.i + z__3.i * z__4.r;
5237
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5238
temp.r = z__1.r, temp.i = z__1.i;
5239
/* L260: */
5240
}
5241
if ((beta->r == 0. && beta->i == 0.)) {
5242
i__3 = i__ + j * c_dim1;
5243
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5244
z__1.i = alpha->r * temp.i + alpha->i *
5245
temp.r;
5246
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5247
} else {
5248
i__3 = i__ + j * c_dim1;
5249
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5250
z__2.i = alpha->r * temp.i + alpha->i *
5251
temp.r;
5252
i__4 = i__ + j * c_dim1;
5253
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5254
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5255
c__[i__4].r;
5256
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5257
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5258
}
5259
/* L270: */
5260
}
5261
/* L280: */
5262
}
5263
} else {
5264
5265
/* Form C := alpha*conjg( A' )*B' + beta*C */
5266
5267
i__1 = *n;
5268
for (j = 1; j <= i__1; ++j) {
5269
i__2 = *m;
5270
for (i__ = 1; i__ <= i__2; ++i__) {
5271
temp.r = 0., temp.i = 0.;
5272
i__3 = *k;
5273
for (l = 1; l <= i__3; ++l) {
5274
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
5275
i__4 = j + l * b_dim1;
5276
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
5277
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
5278
.r;
5279
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5280
temp.r = z__1.r, temp.i = z__1.i;
5281
/* L290: */
5282
}
5283
if ((beta->r == 0. && beta->i == 0.)) {
5284
i__3 = i__ + j * c_dim1;
5285
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5286
z__1.i = alpha->r * temp.i + alpha->i *
5287
temp.r;
5288
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5289
} else {
5290
i__3 = i__ + j * c_dim1;
5291
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5292
z__2.i = alpha->r * temp.i + alpha->i *
5293
temp.r;
5294
i__4 = i__ + j * c_dim1;
5295
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5296
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5297
c__[i__4].r;
5298
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5299
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5300
}
5301
/* L300: */
5302
}
5303
/* L310: */
5304
}
5305
}
5306
} else {
5307
if (conjb) {
5308
5309
/* Form C := alpha*A'*conjg( B' ) + beta*C */
5310
5311
i__1 = *n;
5312
for (j = 1; j <= i__1; ++j) {
5313
i__2 = *m;
5314
for (i__ = 1; i__ <= i__2; ++i__) {
5315
temp.r = 0., temp.i = 0.;
5316
i__3 = *k;
5317
for (l = 1; l <= i__3; ++l) {
5318
i__4 = l + i__ * a_dim1;
5319
d_cnjg(&z__3, &b[j + l * b_dim1]);
5320
z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i,
5321
z__2.i = a[i__4].r * z__3.i + a[i__4].i *
5322
z__3.r;
5323
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5324
temp.r = z__1.r, temp.i = z__1.i;
5325
/* L320: */
5326
}
5327
if ((beta->r == 0. && beta->i == 0.)) {
5328
i__3 = i__ + j * c_dim1;
5329
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5330
z__1.i = alpha->r * temp.i + alpha->i *
5331
temp.r;
5332
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5333
} else {
5334
i__3 = i__ + j * c_dim1;
5335
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5336
z__2.i = alpha->r * temp.i + alpha->i *
5337
temp.r;
5338
i__4 = i__ + j * c_dim1;
5339
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5340
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5341
c__[i__4].r;
5342
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5343
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5344
}
5345
/* L330: */
5346
}
5347
/* L340: */
5348
}
5349
} else {
5350
5351
/* Form C := alpha*A'*B' + beta*C */
5352
5353
i__1 = *n;
5354
for (j = 1; j <= i__1; ++j) {
5355
i__2 = *m;
5356
for (i__ = 1; i__ <= i__2; ++i__) {
5357
temp.r = 0., temp.i = 0.;
5358
i__3 = *k;
5359
for (l = 1; l <= i__3; ++l) {
5360
i__4 = l + i__ * a_dim1;
5361
i__5 = j + l * b_dim1;
5362
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
5363
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
5364
.i * b[i__5].r;
5365
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5366
temp.r = z__1.r, temp.i = z__1.i;
5367
/* L350: */
5368
}
5369
if ((beta->r == 0. && beta->i == 0.)) {
5370
i__3 = i__ + j * c_dim1;
5371
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
5372
z__1.i = alpha->r * temp.i + alpha->i *
5373
temp.r;
5374
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5375
} else {
5376
i__3 = i__ + j * c_dim1;
5377
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
5378
z__2.i = alpha->r * temp.i + alpha->i *
5379
temp.r;
5380
i__4 = i__ + j * c_dim1;
5381
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
5382
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
5383
c__[i__4].r;
5384
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5385
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
5386
}
5387
/* L360: */
5388
}
5389
/* L370: */
5390
}
5391
}
5392
}
5393
5394
return 0;
5395
5396
/* End of ZGEMM . */
5397
5398
} /* zgemm_ */
5399
5400
/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n,
5401
doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
5402
x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
5403
incy)
5404
{
5405
/* System generated locals */
5406
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
5407
doublecomplex z__1, z__2, z__3;
5408
5409
/* Builtin functions */
5410
void d_cnjg(doublecomplex *, doublecomplex *);
5411
5412
/* Local variables */
5413
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
5414
static doublecomplex temp;
5415
static integer lenx, leny;
5416
extern logical lsame_(char *, char *);
5417
extern /* Subroutine */ int xerbla_(char *, integer *);
5418
static logical noconj;
5419
5420
5421
/*
5422
Purpose
5423
=======
5424
5425
ZGEMV performs one of the matrix-vector operations
5426
5427
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
5428
5429
y := alpha*conjg( A' )*x + beta*y,
5430
5431
where alpha and beta are scalars, x and y are vectors and A is an
5432
m by n matrix.
5433
5434
Parameters
5435
==========
5436
5437
TRANS - CHARACTER*1.
5438
On entry, TRANS specifies the operation to be performed as
5439
follows:
5440
5441
TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
5442
5443
TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
5444
5445
TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
5446
5447
Unchanged on exit.
5448
5449
M - INTEGER.
5450
On entry, M specifies the number of rows of the matrix A.
5451
M must be at least zero.
5452
Unchanged on exit.
5453
5454
N - INTEGER.
5455
On entry, N specifies the number of columns of the matrix A.
5456
N must be at least zero.
5457
Unchanged on exit.
5458
5459
ALPHA - COMPLEX*16 .
5460
On entry, ALPHA specifies the scalar alpha.
5461
Unchanged on exit.
5462
5463
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
5464
Before entry, the leading m by n part of the array A must
5465
contain the matrix of coefficients.
5466
Unchanged on exit.
5467
5468
LDA - INTEGER.
5469
On entry, LDA specifies the first dimension of A as declared
5470
in the calling (sub) program. LDA must be at least
5471
max( 1, m ).
5472
Unchanged on exit.
5473
5474
X - COMPLEX*16 array of DIMENSION at least
5475
( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
5476
and at least
5477
( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
5478
Before entry, the incremented array X must contain the
5479
vector x.
5480
Unchanged on exit.
5481
5482
INCX - INTEGER.
5483
On entry, INCX specifies the increment for the elements of
5484
X. INCX must not be zero.
5485
Unchanged on exit.
5486
5487
BETA - COMPLEX*16 .
5488
On entry, BETA specifies the scalar beta. When BETA is
5489
supplied as zero then Y need not be set on input.
5490
Unchanged on exit.
5491
5492
Y - COMPLEX*16 array of DIMENSION at least
5493
( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
5494
and at least
5495
( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
5496
Before entry with BETA non-zero, the incremented array Y
5497
must contain the vector y. On exit, Y is overwritten by the
5498
updated vector y.
5499
5500
INCY - INTEGER.
5501
On entry, INCY specifies the increment for the elements of
5502
Y. INCY must not be zero.
5503
Unchanged on exit.
5504
5505
5506
Level 2 Blas routine.
5507
5508
-- Written on 22-October-1986.
5509
Jack Dongarra, Argonne National Lab.
5510
Jeremy Du Croz, Nag Central Office.
5511
Sven Hammarling, Nag Central Office.
5512
Richard Hanson, Sandia National Labs.
5513
5514
5515
Test the input parameters.
5516
*/
5517
5518
/* Parameter adjustments */
5519
a_dim1 = *lda;
5520
a_offset = 1 + a_dim1 * 1;
5521
a -= a_offset;
5522
--x;
5523
--y;
5524
5525
/* Function Body */
5526
info = 0;
5527
if (((! lsame_(trans, "N") && ! lsame_(trans, "T")) && ! lsame_(trans, "C"))) {
5528
info = 1;
5529
} else if (*m < 0) {
5530
info = 2;
5531
} else if (*n < 0) {
5532
info = 3;
5533
} else if (*lda < max(1,*m)) {
5534
info = 6;
5535
} else if (*incx == 0) {
5536
info = 8;
5537
} else if (*incy == 0) {
5538
info = 11;
5539
}
5540
if (info != 0) {
5541
xerbla_("ZGEMV ", &info);
5542
return 0;
5543
}
5544
5545
/* Quick return if possible. */
5546
5547
if (*m == 0 || *n == 0 || ((alpha->r == 0. && alpha->i == 0.) && ((
5548
beta->r == 1. && beta->i == 0.)))) {
5549
return 0;
5550
}
5551
5552
noconj = lsame_(trans, "T");
5553
5554
/*
5555
Set LENX and LENY, the lengths of the vectors x and y, and set
5556
up the start points in X and Y.
5557
*/
5558
5559
if (lsame_(trans, "N")) {
5560
lenx = *n;
5561
leny = *m;
5562
} else {
5563
lenx = *m;
5564
leny = *n;
5565
}
5566
if (*incx > 0) {
5567
kx = 1;
5568
} else {
5569
kx = 1 - (lenx - 1) * *incx;
5570
}
5571
if (*incy > 0) {
5572
ky = 1;
5573
} else {
5574
ky = 1 - (leny - 1) * *incy;
5575
}
5576
5577
/*
5578
Start the operations. In this version the elements of A are
5579
accessed sequentially with one pass through A.
5580
5581
First form y := beta*y.
5582
*/
5583
5584
if (beta->r != 1. || beta->i != 0.) {
5585
if (*incy == 1) {
5586
if ((beta->r == 0. && beta->i == 0.)) {
5587
i__1 = leny;
5588
for (i__ = 1; i__ <= i__1; ++i__) {
5589
i__2 = i__;
5590
y[i__2].r = 0., y[i__2].i = 0.;
5591
/* L10: */
5592
}
5593
} else {
5594
i__1 = leny;
5595
for (i__ = 1; i__ <= i__1; ++i__) {
5596
i__2 = i__;
5597
i__3 = i__;
5598
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
5599
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
5600
.r;
5601
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
5602
/* L20: */
5603
}
5604
}
5605
} else {
5606
iy = ky;
5607
if ((beta->r == 0. && beta->i == 0.)) {
5608
i__1 = leny;
5609
for (i__ = 1; i__ <= i__1; ++i__) {
5610
i__2 = iy;
5611
y[i__2].r = 0., y[i__2].i = 0.;
5612
iy += *incy;
5613
/* L30: */
5614
}
5615
} else {
5616
i__1 = leny;
5617
for (i__ = 1; i__ <= i__1; ++i__) {
5618
i__2 = iy;
5619
i__3 = iy;
5620
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
5621
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
5622
.r;
5623
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
5624
iy += *incy;
5625
/* L40: */
5626
}
5627
}
5628
}
5629
}
5630
if ((alpha->r == 0. && alpha->i == 0.)) {
5631
return 0;
5632
}
5633
if (lsame_(trans, "N")) {
5634
5635
/* Form y := alpha*A*x + y. */
5636
5637
jx = kx;
5638
if (*incy == 1) {
5639
i__1 = *n;
5640
for (j = 1; j <= i__1; ++j) {
5641
i__2 = jx;
5642
if (x[i__2].r != 0. || x[i__2].i != 0.) {
5643
i__2 = jx;
5644
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
5645
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
5646
.r;
5647
temp.r = z__1.r, temp.i = z__1.i;
5648
i__2 = *m;
5649
for (i__ = 1; i__ <= i__2; ++i__) {
5650
i__3 = i__;
5651
i__4 = i__;
5652
i__5 = i__ + j * a_dim1;
5653
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
5654
z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
5655
.r;
5656
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
5657
z__2.i;
5658
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
5659
/* L50: */
5660
}
5661
}
5662
jx += *incx;
5663
/* L60: */
5664
}
5665
} else {
5666
i__1 = *n;
5667
for (j = 1; j <= i__1; ++j) {
5668
i__2 = jx;
5669
if (x[i__2].r != 0. || x[i__2].i != 0.) {
5670
i__2 = jx;
5671
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
5672
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
5673
.r;
5674
temp.r = z__1.r, temp.i = z__1.i;
5675
iy = ky;
5676
i__2 = *m;
5677
for (i__ = 1; i__ <= i__2; ++i__) {
5678
i__3 = iy;
5679
i__4 = iy;
5680
i__5 = i__ + j * a_dim1;
5681
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
5682
z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
5683
.r;
5684
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
5685
z__2.i;
5686
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
5687
iy += *incy;
5688
/* L70: */
5689
}
5690
}
5691
jx += *incx;
5692
/* L80: */
5693
}
5694
}
5695
} else {
5696
5697
/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
5698
5699
jy = ky;
5700
if (*incx == 1) {
5701
i__1 = *n;
5702
for (j = 1; j <= i__1; ++j) {
5703
temp.r = 0., temp.i = 0.;
5704
if (noconj) {
5705
i__2 = *m;
5706
for (i__ = 1; i__ <= i__2; ++i__) {
5707
i__3 = i__ + j * a_dim1;
5708
i__4 = i__;
5709
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
5710
.i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
5711
.i * x[i__4].r;
5712
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5713
temp.r = z__1.r, temp.i = z__1.i;
5714
/* L90: */
5715
}
5716
} else {
5717
i__2 = *m;
5718
for (i__ = 1; i__ <= i__2; ++i__) {
5719
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
5720
i__3 = i__;
5721
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
5722
z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
5723
.r;
5724
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5725
temp.r = z__1.r, temp.i = z__1.i;
5726
/* L100: */
5727
}
5728
}
5729
i__2 = jy;
5730
i__3 = jy;
5731
z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
5732
alpha->r * temp.i + alpha->i * temp.r;
5733
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
5734
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
5735
jy += *incy;
5736
/* L110: */
5737
}
5738
} else {
5739
i__1 = *n;
5740
for (j = 1; j <= i__1; ++j) {
5741
temp.r = 0., temp.i = 0.;
5742
ix = kx;
5743
if (noconj) {
5744
i__2 = *m;
5745
for (i__ = 1; i__ <= i__2; ++i__) {
5746
i__3 = i__ + j * a_dim1;
5747
i__4 = ix;
5748
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
5749
.i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
5750
.i * x[i__4].r;
5751
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5752
temp.r = z__1.r, temp.i = z__1.i;
5753
ix += *incx;
5754
/* L120: */
5755
}
5756
} else {
5757
i__2 = *m;
5758
for (i__ = 1; i__ <= i__2; ++i__) {
5759
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
5760
i__3 = ix;
5761
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
5762
z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
5763
.r;
5764
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
5765
temp.r = z__1.r, temp.i = z__1.i;
5766
ix += *incx;
5767
/* L130: */
5768
}
5769
}
5770
i__2 = jy;
5771
i__3 = jy;
5772
z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
5773
alpha->r * temp.i + alpha->i * temp.r;
5774
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
5775
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
5776
jy += *incy;
5777
/* L140: */
5778
}
5779
}
5780
}
5781
5782
return 0;
5783
5784
/* End of ZGEMV . */
5785
5786
} /* zgemv_ */
5787
5788
/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha,
5789
doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
5790
doublecomplex *a, integer *lda)
5791
{
5792
/* System generated locals */
5793
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
5794
doublecomplex z__1, z__2;
5795
5796
/* Builtin functions */
5797
void d_cnjg(doublecomplex *, doublecomplex *);
5798
5799
/* Local variables */
5800
static integer i__, j, ix, jy, kx, info;
5801
static doublecomplex temp;
5802
extern /* Subroutine */ int xerbla_(char *, integer *);
5803
5804
5805
/*
5806
Purpose
5807
=======
5808
5809
ZGERC performs the rank 1 operation
5810
5811
A := alpha*x*conjg( y' ) + A,
5812
5813
where alpha is a scalar, x is an m element vector, y is an n element
5814
vector and A is an m by n matrix.
5815
5816
Parameters
5817
==========
5818
5819
M - INTEGER.
5820
On entry, M specifies the number of rows of the matrix A.
5821
M must be at least zero.
5822
Unchanged on exit.
5823
5824
N - INTEGER.
5825
On entry, N specifies the number of columns of the matrix A.
5826
N must be at least zero.
5827
Unchanged on exit.
5828
5829
ALPHA - COMPLEX*16 .
5830
On entry, ALPHA specifies the scalar alpha.
5831
Unchanged on exit.
5832
5833
X - COMPLEX*16 array of dimension at least
5834
( 1 + ( m - 1 )*abs( INCX ) ).
5835
Before entry, the incremented array X must contain the m
5836
element vector x.
5837
Unchanged on exit.
5838
5839
INCX - INTEGER.
5840
On entry, INCX specifies the increment for the elements of
5841
X. INCX must not be zero.
5842
Unchanged on exit.
5843
5844
Y - COMPLEX*16 array of dimension at least
5845
( 1 + ( n - 1 )*abs( INCY ) ).
5846
Before entry, the incremented array Y must contain the n
5847
element vector y.
5848
Unchanged on exit.
5849
5850
INCY - INTEGER.
5851
On entry, INCY specifies the increment for the elements of
5852
Y. INCY must not be zero.
5853
Unchanged on exit.
5854
5855
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
5856
Before entry, the leading m by n part of the array A must
5857
contain the matrix of coefficients. On exit, A is
5858
overwritten by the updated matrix.
5859
5860
LDA - INTEGER.
5861
On entry, LDA specifies the first dimension of A as declared
5862
in the calling (sub) program. LDA must be at least
5863
max( 1, m ).
5864
Unchanged on exit.
5865
5866
5867
Level 2 Blas routine.
5868
5869
-- Written on 22-October-1986.
5870
Jack Dongarra, Argonne National Lab.
5871
Jeremy Du Croz, Nag Central Office.
5872
Sven Hammarling, Nag Central Office.
5873
Richard Hanson, Sandia National Labs.
5874
5875
5876
Test the input parameters.
5877
*/
5878
5879
/* Parameter adjustments */
5880
--x;
5881
--y;
5882
a_dim1 = *lda;
5883
a_offset = 1 + a_dim1 * 1;
5884
a -= a_offset;
5885
5886
/* Function Body */
5887
info = 0;
5888
if (*m < 0) {
5889
info = 1;
5890
} else if (*n < 0) {
5891
info = 2;
5892
} else if (*incx == 0) {
5893
info = 5;
5894
} else if (*incy == 0) {
5895
info = 7;
5896
} else if (*lda < max(1,*m)) {
5897
info = 9;
5898
}
5899
if (info != 0) {
5900
xerbla_("ZGERC ", &info);
5901
return 0;
5902
}
5903
5904
/* Quick return if possible. */
5905
5906
if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0.)) {
5907
return 0;
5908
}
5909
5910
/*
5911
Start the operations. In this version the elements of A are
5912
accessed sequentially with one pass through A.
5913
*/
5914
5915
if (*incy > 0) {
5916
jy = 1;
5917
} else {
5918
jy = 1 - (*n - 1) * *incy;
5919
}
5920
if (*incx == 1) {
5921
i__1 = *n;
5922
for (j = 1; j <= i__1; ++j) {
5923
i__2 = jy;
5924
if (y[i__2].r != 0. || y[i__2].i != 0.) {
5925
d_cnjg(&z__2, &y[jy]);
5926
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
5927
alpha->r * z__2.i + alpha->i * z__2.r;
5928
temp.r = z__1.r, temp.i = z__1.i;
5929
i__2 = *m;
5930
for (i__ = 1; i__ <= i__2; ++i__) {
5931
i__3 = i__ + j * a_dim1;
5932
i__4 = i__ + j * a_dim1;
5933
i__5 = i__;
5934
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
5935
x[i__5].r * temp.i + x[i__5].i * temp.r;
5936
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
5937
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
5938
/* L10: */
5939
}
5940
}
5941
jy += *incy;
5942
/* L20: */
5943
}
5944
} else {
5945
if (*incx > 0) {
5946
kx = 1;
5947
} else {
5948
kx = 1 - (*m - 1) * *incx;
5949
}
5950
i__1 = *n;
5951
for (j = 1; j <= i__1; ++j) {
5952
i__2 = jy;
5953
if (y[i__2].r != 0. || y[i__2].i != 0.) {
5954
d_cnjg(&z__2, &y[jy]);
5955
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
5956
alpha->r * z__2.i + alpha->i * z__2.r;
5957
temp.r = z__1.r, temp.i = z__1.i;
5958
ix = kx;
5959
i__2 = *m;
5960
for (i__ = 1; i__ <= i__2; ++i__) {
5961
i__3 = i__ + j * a_dim1;
5962
i__4 = i__ + j * a_dim1;
5963
i__5 = ix;
5964
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
5965
x[i__5].r * temp.i + x[i__5].i * temp.r;
5966
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
5967
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
5968
ix += *incx;
5969
/* L30: */
5970
}
5971
}
5972
jy += *incy;
5973
/* L40: */
5974
}
5975
}
5976
5977
return 0;
5978
5979
/* End of ZGERC . */
5980
5981
} /* zgerc_ */
5982
5983
/* Subroutine */ int zgeru_(integer *m, integer *n, doublecomplex *alpha,
5984
doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
5985
doublecomplex *a, integer *lda)
5986
{
5987
/* System generated locals */
5988
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
5989
doublecomplex z__1, z__2;
5990
5991
/* Local variables */
5992
static integer i__, j, ix, jy, kx, info;
5993
static doublecomplex temp;
5994
extern /* Subroutine */ int xerbla_(char *, integer *);
5995
5996
5997
/*
5998
Purpose
5999
=======
6000
6001
ZGERU performs the rank 1 operation
6002
6003
A := alpha*x*y' + A,
6004
6005
where alpha is a scalar, x is an m element vector, y is an n element
6006
vector and A is an m by n matrix.
6007
6008
Parameters
6009
==========
6010
6011
M - INTEGER.
6012
On entry, M specifies the number of rows of the matrix A.
6013
M must be at least zero.
6014
Unchanged on exit.
6015
6016
N - INTEGER.
6017
On entry, N specifies the number of columns of the matrix A.
6018
N must be at least zero.
6019
Unchanged on exit.
6020
6021
ALPHA - COMPLEX*16 .
6022
On entry, ALPHA specifies the scalar alpha.
6023
Unchanged on exit.
6024
6025
X - COMPLEX*16 array of dimension at least
6026
( 1 + ( m - 1 )*abs( INCX ) ).
6027
Before entry, the incremented array X must contain the m
6028
element vector x.
6029
Unchanged on exit.
6030
6031
INCX - INTEGER.
6032
On entry, INCX specifies the increment for the elements of
6033
X. INCX must not be zero.
6034
Unchanged on exit.
6035
6036
Y - COMPLEX*16 array of dimension at least
6037
( 1 + ( n - 1 )*abs( INCY ) ).
6038
Before entry, the incremented array Y must contain the n
6039
element vector y.
6040
Unchanged on exit.
6041
6042
INCY - INTEGER.
6043
On entry, INCY specifies the increment for the elements of
6044
Y. INCY must not be zero.
6045
Unchanged on exit.
6046
6047
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
6048
Before entry, the leading m by n part of the array A must
6049
contain the matrix of coefficients. On exit, A is
6050
overwritten by the updated matrix.
6051
6052
LDA - INTEGER.
6053
On entry, LDA specifies the first dimension of A as declared
6054
in the calling (sub) program. LDA must be at least
6055
max( 1, m ).
6056
Unchanged on exit.
6057
6058
6059
Level 2 Blas routine.
6060
6061
-- Written on 22-October-1986.
6062
Jack Dongarra, Argonne National Lab.
6063
Jeremy Du Croz, Nag Central Office.
6064
Sven Hammarling, Nag Central Office.
6065
Richard Hanson, Sandia National Labs.
6066
6067
6068
Test the input parameters.
6069
*/
6070
6071
/* Parameter adjustments */
6072
--x;
6073
--y;
6074
a_dim1 = *lda;
6075
a_offset = 1 + a_dim1 * 1;
6076
a -= a_offset;
6077
6078
/* Function Body */
6079
info = 0;
6080
if (*m < 0) {
6081
info = 1;
6082
} else if (*n < 0) {
6083
info = 2;
6084
} else if (*incx == 0) {
6085
info = 5;
6086
} else if (*incy == 0) {
6087
info = 7;
6088
} else if (*lda < max(1,*m)) {
6089
info = 9;
6090
}
6091
if (info != 0) {
6092
xerbla_("ZGERU ", &info);
6093
return 0;
6094
}
6095
6096
/* Quick return if possible. */
6097
6098
if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0.)) {
6099
return 0;
6100
}
6101
6102
/*
6103
Start the operations. In this version the elements of A are
6104
accessed sequentially with one pass through A.
6105
*/
6106
6107
if (*incy > 0) {
6108
jy = 1;
6109
} else {
6110
jy = 1 - (*n - 1) * *incy;
6111
}
6112
if (*incx == 1) {
6113
i__1 = *n;
6114
for (j = 1; j <= i__1; ++j) {
6115
i__2 = jy;
6116
if (y[i__2].r != 0. || y[i__2].i != 0.) {
6117
i__2 = jy;
6118
z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i =
6119
alpha->r * y[i__2].i + alpha->i * y[i__2].r;
6120
temp.r = z__1.r, temp.i = z__1.i;
6121
i__2 = *m;
6122
for (i__ = 1; i__ <= i__2; ++i__) {
6123
i__3 = i__ + j * a_dim1;
6124
i__4 = i__ + j * a_dim1;
6125
i__5 = i__;
6126
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
6127
x[i__5].r * temp.i + x[i__5].i * temp.r;
6128
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
6129
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6130
/* L10: */
6131
}
6132
}
6133
jy += *incy;
6134
/* L20: */
6135
}
6136
} else {
6137
if (*incx > 0) {
6138
kx = 1;
6139
} else {
6140
kx = 1 - (*m - 1) * *incx;
6141
}
6142
i__1 = *n;
6143
for (j = 1; j <= i__1; ++j) {
6144
i__2 = jy;
6145
if (y[i__2].r != 0. || y[i__2].i != 0.) {
6146
i__2 = jy;
6147
z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i =
6148
alpha->r * y[i__2].i + alpha->i * y[i__2].r;
6149
temp.r = z__1.r, temp.i = z__1.i;
6150
ix = kx;
6151
i__2 = *m;
6152
for (i__ = 1; i__ <= i__2; ++i__) {
6153
i__3 = i__ + j * a_dim1;
6154
i__4 = i__ + j * a_dim1;
6155
i__5 = ix;
6156
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
6157
x[i__5].r * temp.i + x[i__5].i * temp.r;
6158
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
6159
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6160
ix += *incx;
6161
/* L30: */
6162
}
6163
}
6164
jy += *incy;
6165
/* L40: */
6166
}
6167
}
6168
6169
return 0;
6170
6171
/* End of ZGERU . */
6172
6173
} /* zgeru_ */
6174
6175
/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha,
6176
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
6177
doublecomplex *beta, doublecomplex *y, integer *incy)
6178
{
6179
/* System generated locals */
6180
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
6181
doublereal d__1;
6182
doublecomplex z__1, z__2, z__3, z__4;
6183
6184
/* Builtin functions */
6185
void d_cnjg(doublecomplex *, doublecomplex *);
6186
6187
/* Local variables */
6188
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
6189
static doublecomplex temp1, temp2;
6190
extern logical lsame_(char *, char *);
6191
extern /* Subroutine */ int xerbla_(char *, integer *);
6192
6193
6194
/*
6195
Purpose
6196
=======
6197
6198
ZHEMV performs the matrix-vector operation
6199
6200
y := alpha*A*x + beta*y,
6201
6202
where alpha and beta are scalars, x and y are n element vectors and
6203
A is an n by n hermitian matrix.
6204
6205
Parameters
6206
==========
6207
6208
UPLO - CHARACTER*1.
6209
On entry, UPLO specifies whether the upper or lower
6210
triangular part of the array A is to be referenced as
6211
follows:
6212
6213
UPLO = 'U' or 'u' Only the upper triangular part of A
6214
is to be referenced.
6215
6216
UPLO = 'L' or 'l' Only the lower triangular part of A
6217
is to be referenced.
6218
6219
Unchanged on exit.
6220
6221
N - INTEGER.
6222
On entry, N specifies the order of the matrix A.
6223
N must be at least zero.
6224
Unchanged on exit.
6225
6226
ALPHA - COMPLEX*16 .
6227
On entry, ALPHA specifies the scalar alpha.
6228
Unchanged on exit.
6229
6230
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
6231
Before entry with UPLO = 'U' or 'u', the leading n by n
6232
upper triangular part of the array A must contain the upper
6233
triangular part of the hermitian matrix and the strictly
6234
lower triangular part of A is not referenced.
6235
Before entry with UPLO = 'L' or 'l', the leading n by n
6236
lower triangular part of the array A must contain the lower
6237
triangular part of the hermitian matrix and the strictly
6238
upper triangular part of A is not referenced.
6239
Note that the imaginary parts of the diagonal elements need
6240
not be set and are assumed to be zero.
6241
Unchanged on exit.
6242
6243
LDA - INTEGER.
6244
On entry, LDA specifies the first dimension of A as declared
6245
in the calling (sub) program. LDA must be at least
6246
max( 1, n ).
6247
Unchanged on exit.
6248
6249
X - COMPLEX*16 array of dimension at least
6250
( 1 + ( n - 1 )*abs( INCX ) ).
6251
Before entry, the incremented array X must contain the n
6252
element vector x.
6253
Unchanged on exit.
6254
6255
INCX - INTEGER.
6256
On entry, INCX specifies the increment for the elements of
6257
X. INCX must not be zero.
6258
Unchanged on exit.
6259
6260
BETA - COMPLEX*16 .
6261
On entry, BETA specifies the scalar beta. When BETA is
6262
supplied as zero then Y need not be set on input.
6263
Unchanged on exit.
6264
6265
Y - COMPLEX*16 array of dimension at least
6266
( 1 + ( n - 1 )*abs( INCY ) ).
6267
Before entry, the incremented array Y must contain the n
6268
element vector y. On exit, Y is overwritten by the updated
6269
vector y.
6270
6271
INCY - INTEGER.
6272
On entry, INCY specifies the increment for the elements of
6273
Y. INCY must not be zero.
6274
Unchanged on exit.
6275
6276
6277
Level 2 Blas routine.
6278
6279
-- Written on 22-October-1986.
6280
Jack Dongarra, Argonne National Lab.
6281
Jeremy Du Croz, Nag Central Office.
6282
Sven Hammarling, Nag Central Office.
6283
Richard Hanson, Sandia National Labs.
6284
6285
6286
Test the input parameters.
6287
*/
6288
6289
/* Parameter adjustments */
6290
a_dim1 = *lda;
6291
a_offset = 1 + a_dim1 * 1;
6292
a -= a_offset;
6293
--x;
6294
--y;
6295
6296
/* Function Body */
6297
info = 0;
6298
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
6299
info = 1;
6300
} else if (*n < 0) {
6301
info = 2;
6302
} else if (*lda < max(1,*n)) {
6303
info = 5;
6304
} else if (*incx == 0) {
6305
info = 7;
6306
} else if (*incy == 0) {
6307
info = 10;
6308
}
6309
if (info != 0) {
6310
xerbla_("ZHEMV ", &info);
6311
return 0;
6312
}
6313
6314
/* Quick return if possible. */
6315
6316
if (*n == 0 || ((alpha->r == 0. && alpha->i == 0.) && ((beta->r == 1. &&
6317
beta->i == 0.)))) {
6318
return 0;
6319
}
6320
6321
/* Set up the start points in X and Y. */
6322
6323
if (*incx > 0) {
6324
kx = 1;
6325
} else {
6326
kx = 1 - (*n - 1) * *incx;
6327
}
6328
if (*incy > 0) {
6329
ky = 1;
6330
} else {
6331
ky = 1 - (*n - 1) * *incy;
6332
}
6333
6334
/*
6335
Start the operations. In this version the elements of A are
6336
accessed sequentially with one pass through the triangular part
6337
of A.
6338
6339
First form y := beta*y.
6340
*/
6341
6342
if (beta->r != 1. || beta->i != 0.) {
6343
if (*incy == 1) {
6344
if ((beta->r == 0. && beta->i == 0.)) {
6345
i__1 = *n;
6346
for (i__ = 1; i__ <= i__1; ++i__) {
6347
i__2 = i__;
6348
y[i__2].r = 0., y[i__2].i = 0.;
6349
/* L10: */
6350
}
6351
} else {
6352
i__1 = *n;
6353
for (i__ = 1; i__ <= i__1; ++i__) {
6354
i__2 = i__;
6355
i__3 = i__;
6356
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
6357
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
6358
.r;
6359
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6360
/* L20: */
6361
}
6362
}
6363
} else {
6364
iy = ky;
6365
if ((beta->r == 0. && beta->i == 0.)) {
6366
i__1 = *n;
6367
for (i__ = 1; i__ <= i__1; ++i__) {
6368
i__2 = iy;
6369
y[i__2].r = 0., y[i__2].i = 0.;
6370
iy += *incy;
6371
/* L30: */
6372
}
6373
} else {
6374
i__1 = *n;
6375
for (i__ = 1; i__ <= i__1; ++i__) {
6376
i__2 = iy;
6377
i__3 = iy;
6378
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
6379
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
6380
.r;
6381
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6382
iy += *incy;
6383
/* L40: */
6384
}
6385
}
6386
}
6387
}
6388
if ((alpha->r == 0. && alpha->i == 0.)) {
6389
return 0;
6390
}
6391
if (lsame_(uplo, "U")) {
6392
6393
/* Form y when A is stored in upper triangle. */
6394
6395
if ((*incx == 1 && *incy == 1)) {
6396
i__1 = *n;
6397
for (j = 1; j <= i__1; ++j) {
6398
i__2 = j;
6399
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
6400
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
6401
temp1.r = z__1.r, temp1.i = z__1.i;
6402
temp2.r = 0., temp2.i = 0.;
6403
i__2 = j - 1;
6404
for (i__ = 1; i__ <= i__2; ++i__) {
6405
i__3 = i__;
6406
i__4 = i__;
6407
i__5 = i__ + j * a_dim1;
6408
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
6409
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
6410
.r;
6411
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
6412
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
6413
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
6414
i__3 = i__;
6415
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
6416
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
6417
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
6418
temp2.r = z__1.r, temp2.i = z__1.i;
6419
/* L50: */
6420
}
6421
i__2 = j;
6422
i__3 = j;
6423
i__4 = j + j * a_dim1;
6424
d__1 = a[i__4].r;
6425
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
6426
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
6427
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
6428
alpha->r * temp2.i + alpha->i * temp2.r;
6429
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6430
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6431
/* L60: */
6432
}
6433
} else {
6434
jx = kx;
6435
jy = ky;
6436
i__1 = *n;
6437
for (j = 1; j <= i__1; ++j) {
6438
i__2 = jx;
6439
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
6440
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
6441
temp1.r = z__1.r, temp1.i = z__1.i;
6442
temp2.r = 0., temp2.i = 0.;
6443
ix = kx;
6444
iy = ky;
6445
i__2 = j - 1;
6446
for (i__ = 1; i__ <= i__2; ++i__) {
6447
i__3 = iy;
6448
i__4 = iy;
6449
i__5 = i__ + j * a_dim1;
6450
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
6451
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
6452
.r;
6453
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
6454
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
6455
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
6456
i__3 = ix;
6457
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
6458
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
6459
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
6460
temp2.r = z__1.r, temp2.i = z__1.i;
6461
ix += *incx;
6462
iy += *incy;
6463
/* L70: */
6464
}
6465
i__2 = jy;
6466
i__3 = jy;
6467
i__4 = j + j * a_dim1;
6468
d__1 = a[i__4].r;
6469
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
6470
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
6471
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
6472
alpha->r * temp2.i + alpha->i * temp2.r;
6473
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6474
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6475
jx += *incx;
6476
jy += *incy;
6477
/* L80: */
6478
}
6479
}
6480
} else {
6481
6482
/* Form y when A is stored in lower triangle. */
6483
6484
if ((*incx == 1 && *incy == 1)) {
6485
i__1 = *n;
6486
for (j = 1; j <= i__1; ++j) {
6487
i__2 = j;
6488
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
6489
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
6490
temp1.r = z__1.r, temp1.i = z__1.i;
6491
temp2.r = 0., temp2.i = 0.;
6492
i__2 = j;
6493
i__3 = j;
6494
i__4 = j + j * a_dim1;
6495
d__1 = a[i__4].r;
6496
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
6497
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
6498
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6499
i__2 = *n;
6500
for (i__ = j + 1; i__ <= i__2; ++i__) {
6501
i__3 = i__;
6502
i__4 = i__;
6503
i__5 = i__ + j * a_dim1;
6504
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
6505
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
6506
.r;
6507
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
6508
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
6509
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
6510
i__3 = i__;
6511
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
6512
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
6513
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
6514
temp2.r = z__1.r, temp2.i = z__1.i;
6515
/* L90: */
6516
}
6517
i__2 = j;
6518
i__3 = j;
6519
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
6520
alpha->r * temp2.i + alpha->i * temp2.r;
6521
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
6522
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6523
/* L100: */
6524
}
6525
} else {
6526
jx = kx;
6527
jy = ky;
6528
i__1 = *n;
6529
for (j = 1; j <= i__1; ++j) {
6530
i__2 = jx;
6531
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
6532
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
6533
temp1.r = z__1.r, temp1.i = z__1.i;
6534
temp2.r = 0., temp2.i = 0.;
6535
i__2 = jy;
6536
i__3 = jy;
6537
i__4 = j + j * a_dim1;
6538
d__1 = a[i__4].r;
6539
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
6540
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
6541
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6542
ix = jx;
6543
iy = jy;
6544
i__2 = *n;
6545
for (i__ = j + 1; i__ <= i__2; ++i__) {
6546
ix += *incx;
6547
iy += *incy;
6548
i__3 = iy;
6549
i__4 = iy;
6550
i__5 = i__ + j * a_dim1;
6551
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
6552
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
6553
.r;
6554
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
6555
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
6556
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
6557
i__3 = ix;
6558
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
6559
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
6560
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
6561
temp2.r = z__1.r, temp2.i = z__1.i;
6562
/* L110: */
6563
}
6564
i__2 = jy;
6565
i__3 = jy;
6566
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
6567
alpha->r * temp2.i + alpha->i * temp2.r;
6568
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
6569
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
6570
jx += *incx;
6571
jy += *incy;
6572
/* L120: */
6573
}
6574
}
6575
}
6576
6577
return 0;
6578
6579
/* End of ZHEMV . */
6580
6581
} /* zhemv_ */
6582
6583
/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha,
6584
doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
6585
doublecomplex *a, integer *lda)
6586
{
6587
/* System generated locals */
6588
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
6589
doublereal d__1;
6590
doublecomplex z__1, z__2, z__3, z__4;
6591
6592
/* Builtin functions */
6593
void d_cnjg(doublecomplex *, doublecomplex *);
6594
6595
/* Local variables */
6596
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
6597
static doublecomplex temp1, temp2;
6598
extern logical lsame_(char *, char *);
6599
extern /* Subroutine */ int xerbla_(char *, integer *);
6600
6601
6602
/*
6603
Purpose
6604
=======
6605
6606
ZHER2 performs the hermitian rank 2 operation
6607
6608
A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
6609
6610
where alpha is a scalar, x and y are n element vectors and A is an n
6611
by n hermitian matrix.
6612
6613
Parameters
6614
==========
6615
6616
UPLO - CHARACTER*1.
6617
On entry, UPLO specifies whether the upper or lower
6618
triangular part of the array A is to be referenced as
6619
follows:
6620
6621
UPLO = 'U' or 'u' Only the upper triangular part of A
6622
is to be referenced.
6623
6624
UPLO = 'L' or 'l' Only the lower triangular part of A
6625
is to be referenced.
6626
6627
Unchanged on exit.
6628
6629
N - INTEGER.
6630
On entry, N specifies the order of the matrix A.
6631
N must be at least zero.
6632
Unchanged on exit.
6633
6634
ALPHA - COMPLEX*16 .
6635
On entry, ALPHA specifies the scalar alpha.
6636
Unchanged on exit.
6637
6638
X - COMPLEX*16 array of dimension at least
6639
( 1 + ( n - 1 )*abs( INCX ) ).
6640
Before entry, the incremented array X must contain the n
6641
element vector x.
6642
Unchanged on exit.
6643
6644
INCX - INTEGER.
6645
On entry, INCX specifies the increment for the elements of
6646
X. INCX must not be zero.
6647
Unchanged on exit.
6648
6649
Y - COMPLEX*16 array of dimension at least
6650
( 1 + ( n - 1 )*abs( INCY ) ).
6651
Before entry, the incremented array Y must contain the n
6652
element vector y.
6653
Unchanged on exit.
6654
6655
INCY - INTEGER.
6656
On entry, INCY specifies the increment for the elements of
6657
Y. INCY must not be zero.
6658
Unchanged on exit.
6659
6660
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
6661
Before entry with UPLO = 'U' or 'u', the leading n by n
6662
upper triangular part of the array A must contain the upper
6663
triangular part of the hermitian matrix and the strictly
6664
lower triangular part of A is not referenced. On exit, the
6665
upper triangular part of the array A is overwritten by the
6666
upper triangular part of the updated matrix.
6667
Before entry with UPLO = 'L' or 'l', the leading n by n
6668
lower triangular part of the array A must contain the lower
6669
triangular part of the hermitian matrix and the strictly
6670
upper triangular part of A is not referenced. On exit, the
6671
lower triangular part of the array A is overwritten by the
6672
lower triangular part of the updated matrix.
6673
Note that the imaginary parts of the diagonal elements need
6674
not be set, they are assumed to be zero, and on exit they
6675
are set to zero.
6676
6677
LDA - INTEGER.
6678
On entry, LDA specifies the first dimension of A as declared
6679
in the calling (sub) program. LDA must be at least
6680
max( 1, n ).
6681
Unchanged on exit.
6682
6683
6684
Level 2 Blas routine.
6685
6686
-- Written on 22-October-1986.
6687
Jack Dongarra, Argonne National Lab.
6688
Jeremy Du Croz, Nag Central Office.
6689
Sven Hammarling, Nag Central Office.
6690
Richard Hanson, Sandia National Labs.
6691
6692
6693
Test the input parameters.
6694
*/
6695
6696
/* Parameter adjustments */
6697
--x;
6698
--y;
6699
a_dim1 = *lda;
6700
a_offset = 1 + a_dim1 * 1;
6701
a -= a_offset;
6702
6703
/* Function Body */
6704
info = 0;
6705
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
6706
info = 1;
6707
} else if (*n < 0) {
6708
info = 2;
6709
} else if (*incx == 0) {
6710
info = 5;
6711
} else if (*incy == 0) {
6712
info = 7;
6713
} else if (*lda < max(1,*n)) {
6714
info = 9;
6715
}
6716
if (info != 0) {
6717
xerbla_("ZHER2 ", &info);
6718
return 0;
6719
}
6720
6721
/* Quick return if possible. */
6722
6723
if (*n == 0 || (alpha->r == 0. && alpha->i == 0.)) {
6724
return 0;
6725
}
6726
6727
/*
6728
Set up the start points in X and Y if the increments are not both
6729
unity.
6730
*/
6731
6732
if (*incx != 1 || *incy != 1) {
6733
if (*incx > 0) {
6734
kx = 1;
6735
} else {
6736
kx = 1 - (*n - 1) * *incx;
6737
}
6738
if (*incy > 0) {
6739
ky = 1;
6740
} else {
6741
ky = 1 - (*n - 1) * *incy;
6742
}
6743
jx = kx;
6744
jy = ky;
6745
}
6746
6747
/*
6748
Start the operations. In this version the elements of A are
6749
accessed sequentially with one pass through the triangular part
6750
of A.
6751
*/
6752
6753
if (lsame_(uplo, "U")) {
6754
6755
/* Form A when A is stored in the upper triangle. */
6756
6757
if ((*incx == 1 && *incy == 1)) {
6758
i__1 = *n;
6759
for (j = 1; j <= i__1; ++j) {
6760
i__2 = j;
6761
i__3 = j;
6762
if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
6763
y[i__3].i != 0.)) {
6764
d_cnjg(&z__2, &y[j]);
6765
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
6766
alpha->r * z__2.i + alpha->i * z__2.r;
6767
temp1.r = z__1.r, temp1.i = z__1.i;
6768
i__2 = j;
6769
z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
6770
z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
6771
.r;
6772
d_cnjg(&z__1, &z__2);
6773
temp2.r = z__1.r, temp2.i = z__1.i;
6774
i__2 = j - 1;
6775
for (i__ = 1; i__ <= i__2; ++i__) {
6776
i__3 = i__ + j * a_dim1;
6777
i__4 = i__ + j * a_dim1;
6778
i__5 = i__;
6779
z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
6780
z__3.i = x[i__5].r * temp1.i + x[i__5].i *
6781
temp1.r;
6782
z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
6783
z__3.i;
6784
i__6 = i__;
6785
z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
6786
z__4.i = y[i__6].r * temp2.i + y[i__6].i *
6787
temp2.r;
6788
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6789
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6790
/* L10: */
6791
}
6792
i__2 = j + j * a_dim1;
6793
i__3 = j + j * a_dim1;
6794
i__4 = j;
6795
z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
6796
z__2.i = x[i__4].r * temp1.i + x[i__4].i *
6797
temp1.r;
6798
i__5 = j;
6799
z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
6800
z__3.i = y[i__5].r * temp2.i + y[i__5].i *
6801
temp2.r;
6802
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
6803
d__1 = a[i__3].r + z__1.r;
6804
a[i__2].r = d__1, a[i__2].i = 0.;
6805
} else {
6806
i__2 = j + j * a_dim1;
6807
i__3 = j + j * a_dim1;
6808
d__1 = a[i__3].r;
6809
a[i__2].r = d__1, a[i__2].i = 0.;
6810
}
6811
/* L20: */
6812
}
6813
} else {
6814
i__1 = *n;
6815
for (j = 1; j <= i__1; ++j) {
6816
i__2 = jx;
6817
i__3 = jy;
6818
if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
6819
y[i__3].i != 0.)) {
6820
d_cnjg(&z__2, &y[jy]);
6821
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
6822
alpha->r * z__2.i + alpha->i * z__2.r;
6823
temp1.r = z__1.r, temp1.i = z__1.i;
6824
i__2 = jx;
6825
z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
6826
z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
6827
.r;
6828
d_cnjg(&z__1, &z__2);
6829
temp2.r = z__1.r, temp2.i = z__1.i;
6830
ix = kx;
6831
iy = ky;
6832
i__2 = j - 1;
6833
for (i__ = 1; i__ <= i__2; ++i__) {
6834
i__3 = i__ + j * a_dim1;
6835
i__4 = i__ + j * a_dim1;
6836
i__5 = ix;
6837
z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
6838
z__3.i = x[i__5].r * temp1.i + x[i__5].i *
6839
temp1.r;
6840
z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
6841
z__3.i;
6842
i__6 = iy;
6843
z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
6844
z__4.i = y[i__6].r * temp2.i + y[i__6].i *
6845
temp2.r;
6846
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6847
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6848
ix += *incx;
6849
iy += *incy;
6850
/* L30: */
6851
}
6852
i__2 = j + j * a_dim1;
6853
i__3 = j + j * a_dim1;
6854
i__4 = jx;
6855
z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
6856
z__2.i = x[i__4].r * temp1.i + x[i__4].i *
6857
temp1.r;
6858
i__5 = jy;
6859
z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
6860
z__3.i = y[i__5].r * temp2.i + y[i__5].i *
6861
temp2.r;
6862
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
6863
d__1 = a[i__3].r + z__1.r;
6864
a[i__2].r = d__1, a[i__2].i = 0.;
6865
} else {
6866
i__2 = j + j * a_dim1;
6867
i__3 = j + j * a_dim1;
6868
d__1 = a[i__3].r;
6869
a[i__2].r = d__1, a[i__2].i = 0.;
6870
}
6871
jx += *incx;
6872
jy += *incy;
6873
/* L40: */
6874
}
6875
}
6876
} else {
6877
6878
/* Form A when A is stored in the lower triangle. */
6879
6880
if ((*incx == 1 && *incy == 1)) {
6881
i__1 = *n;
6882
for (j = 1; j <= i__1; ++j) {
6883
i__2 = j;
6884
i__3 = j;
6885
if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
6886
y[i__3].i != 0.)) {
6887
d_cnjg(&z__2, &y[j]);
6888
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
6889
alpha->r * z__2.i + alpha->i * z__2.r;
6890
temp1.r = z__1.r, temp1.i = z__1.i;
6891
i__2 = j;
6892
z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
6893
z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
6894
.r;
6895
d_cnjg(&z__1, &z__2);
6896
temp2.r = z__1.r, temp2.i = z__1.i;
6897
i__2 = j + j * a_dim1;
6898
i__3 = j + j * a_dim1;
6899
i__4 = j;
6900
z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
6901
z__2.i = x[i__4].r * temp1.i + x[i__4].i *
6902
temp1.r;
6903
i__5 = j;
6904
z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
6905
z__3.i = y[i__5].r * temp2.i + y[i__5].i *
6906
temp2.r;
6907
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
6908
d__1 = a[i__3].r + z__1.r;
6909
a[i__2].r = d__1, a[i__2].i = 0.;
6910
i__2 = *n;
6911
for (i__ = j + 1; i__ <= i__2; ++i__) {
6912
i__3 = i__ + j * a_dim1;
6913
i__4 = i__ + j * a_dim1;
6914
i__5 = i__;
6915
z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
6916
z__3.i = x[i__5].r * temp1.i + x[i__5].i *
6917
temp1.r;
6918
z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
6919
z__3.i;
6920
i__6 = i__;
6921
z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
6922
z__4.i = y[i__6].r * temp2.i + y[i__6].i *
6923
temp2.r;
6924
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6925
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6926
/* L50: */
6927
}
6928
} else {
6929
i__2 = j + j * a_dim1;
6930
i__3 = j + j * a_dim1;
6931
d__1 = a[i__3].r;
6932
a[i__2].r = d__1, a[i__2].i = 0.;
6933
}
6934
/* L60: */
6935
}
6936
} else {
6937
i__1 = *n;
6938
for (j = 1; j <= i__1; ++j) {
6939
i__2 = jx;
6940
i__3 = jy;
6941
if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
6942
y[i__3].i != 0.)) {
6943
d_cnjg(&z__2, &y[jy]);
6944
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
6945
alpha->r * z__2.i + alpha->i * z__2.r;
6946
temp1.r = z__1.r, temp1.i = z__1.i;
6947
i__2 = jx;
6948
z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
6949
z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
6950
.r;
6951
d_cnjg(&z__1, &z__2);
6952
temp2.r = z__1.r, temp2.i = z__1.i;
6953
i__2 = j + j * a_dim1;
6954
i__3 = j + j * a_dim1;
6955
i__4 = jx;
6956
z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
6957
z__2.i = x[i__4].r * temp1.i + x[i__4].i *
6958
temp1.r;
6959
i__5 = jy;
6960
z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
6961
z__3.i = y[i__5].r * temp2.i + y[i__5].i *
6962
temp2.r;
6963
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
6964
d__1 = a[i__3].r + z__1.r;
6965
a[i__2].r = d__1, a[i__2].i = 0.;
6966
ix = jx;
6967
iy = jy;
6968
i__2 = *n;
6969
for (i__ = j + 1; i__ <= i__2; ++i__) {
6970
ix += *incx;
6971
iy += *incy;
6972
i__3 = i__ + j * a_dim1;
6973
i__4 = i__ + j * a_dim1;
6974
i__5 = ix;
6975
z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
6976
z__3.i = x[i__5].r * temp1.i + x[i__5].i *
6977
temp1.r;
6978
z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
6979
z__3.i;
6980
i__6 = iy;
6981
z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
6982
z__4.i = y[i__6].r * temp2.i + y[i__6].i *
6983
temp2.r;
6984
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
6985
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
6986
/* L70: */
6987
}
6988
} else {
6989
i__2 = j + j * a_dim1;
6990
i__3 = j + j * a_dim1;
6991
d__1 = a[i__3].r;
6992
a[i__2].r = d__1, a[i__2].i = 0.;
6993
}
6994
jx += *incx;
6995
jy += *incy;
6996
/* L80: */
6997
}
6998
}
6999
}
7000
7001
return 0;
7002
7003
/* End of ZHER2 . */
7004
7005
} /* zher2_ */
7006
7007
/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k,
7008
doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
7009
b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc)
7010
{
7011
/* System generated locals */
7012
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
7013
i__3, i__4, i__5, i__6, i__7;
7014
doublereal d__1;
7015
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
7016
7017
/* Builtin functions */
7018
void d_cnjg(doublecomplex *, doublecomplex *);
7019
7020
/* Local variables */
7021
static integer i__, j, l, info;
7022
static doublecomplex temp1, temp2;
7023
extern logical lsame_(char *, char *);
7024
static integer nrowa;
7025
static logical upper;
7026
extern /* Subroutine */ int xerbla_(char *, integer *);
7027
7028
7029
/*
7030
Purpose
7031
=======
7032
7033
ZHER2K performs one of the hermitian rank 2k operations
7034
7035
C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C,
7036
7037
or
7038
7039
C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C,
7040
7041
where alpha and beta are scalars with beta real, C is an n by n
7042
hermitian matrix and A and B are n by k matrices in the first case
7043
and k by n matrices in the second case.
7044
7045
Parameters
7046
==========
7047
7048
UPLO - CHARACTER*1.
7049
On entry, UPLO specifies whether the upper or lower
7050
triangular part of the array C is to be referenced as
7051
follows:
7052
7053
UPLO = 'U' or 'u' Only the upper triangular part of C
7054
is to be referenced.
7055
7056
UPLO = 'L' or 'l' Only the lower triangular part of C
7057
is to be referenced.
7058
7059
Unchanged on exit.
7060
7061
TRANS - CHARACTER*1.
7062
On entry, TRANS specifies the operation to be performed as
7063
follows:
7064
7065
TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) +
7066
conjg( alpha )*B*conjg( A' ) +
7067
beta*C.
7068
7069
TRANS = 'C' or 'c' C := alpha*conjg( A' )*B +
7070
conjg( alpha )*conjg( B' )*A +
7071
beta*C.
7072
7073
Unchanged on exit.
7074
7075
N - INTEGER.
7076
On entry, N specifies the order of the matrix C. N must be
7077
at least zero.
7078
Unchanged on exit.
7079
7080
K - INTEGER.
7081
On entry with TRANS = 'N' or 'n', K specifies the number
7082
of columns of the matrices A and B, and on entry with
7083
TRANS = 'C' or 'c', K specifies the number of rows of the
7084
matrices A and B. K must be at least zero.
7085
Unchanged on exit.
7086
7087
ALPHA - COMPLEX*16 .
7088
On entry, ALPHA specifies the scalar alpha.
7089
Unchanged on exit.
7090
7091
A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
7092
k when TRANS = 'N' or 'n', and is n otherwise.
7093
Before entry with TRANS = 'N' or 'n', the leading n by k
7094
part of the array A must contain the matrix A, otherwise
7095
the leading k by n part of the array A must contain the
7096
matrix A.
7097
Unchanged on exit.
7098
7099
LDA - INTEGER.
7100
On entry, LDA specifies the first dimension of A as declared
7101
in the calling (sub) program. When TRANS = 'N' or 'n'
7102
then LDA must be at least max( 1, n ), otherwise LDA must
7103
be at least max( 1, k ).
7104
Unchanged on exit.
7105
7106
B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
7107
k when TRANS = 'N' or 'n', and is n otherwise.
7108
Before entry with TRANS = 'N' or 'n', the leading n by k
7109
part of the array B must contain the matrix B, otherwise
7110
the leading k by n part of the array B must contain the
7111
matrix B.
7112
Unchanged on exit.
7113
7114
LDB - INTEGER.
7115
On entry, LDB specifies the first dimension of B as declared
7116
in the calling (sub) program. When TRANS = 'N' or 'n'
7117
then LDB must be at least max( 1, n ), otherwise LDB must
7118
be at least max( 1, k ).
7119
Unchanged on exit.
7120
7121
BETA - DOUBLE PRECISION .
7122
On entry, BETA specifies the scalar beta.
7123
Unchanged on exit.
7124
7125
C - COMPLEX*16 array of DIMENSION ( LDC, n ).
7126
Before entry with UPLO = 'U' or 'u', the leading n by n
7127
upper triangular part of the array C must contain the upper
7128
triangular part of the hermitian matrix and the strictly
7129
lower triangular part of C is not referenced. On exit, the
7130
upper triangular part of the array C is overwritten by the
7131
upper triangular part of the updated matrix.
7132
Before entry with UPLO = 'L' or 'l', the leading n by n
7133
lower triangular part of the array C must contain the lower
7134
triangular part of the hermitian matrix and the strictly
7135
upper triangular part of C is not referenced. On exit, the
7136
lower triangular part of the array C is overwritten by the
7137
lower triangular part of the updated matrix.
7138
Note that the imaginary parts of the diagonal elements need
7139
not be set, they are assumed to be zero, and on exit they
7140
are set to zero.
7141
7142
LDC - INTEGER.
7143
On entry, LDC specifies the first dimension of C as declared
7144
in the calling (sub) program. LDC must be at least
7145
max( 1, n ).
7146
Unchanged on exit.
7147
7148
7149
Level 3 Blas routine.
7150
7151
-- Written on 8-February-1989.
7152
Jack Dongarra, Argonne National Laboratory.
7153
Iain Duff, AERE Harwell.
7154
Jeremy Du Croz, Numerical Algorithms Group Ltd.
7155
Sven Hammarling, Numerical Algorithms Group Ltd.
7156
7157
-- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
7158
Ed Anderson, Cray Research Inc.
7159
7160
7161
Test the input parameters.
7162
*/
7163
7164
/* Parameter adjustments */
7165
a_dim1 = *lda;
7166
a_offset = 1 + a_dim1 * 1;
7167
a -= a_offset;
7168
b_dim1 = *ldb;
7169
b_offset = 1 + b_dim1 * 1;
7170
b -= b_offset;
7171
c_dim1 = *ldc;
7172
c_offset = 1 + c_dim1 * 1;
7173
c__ -= c_offset;
7174
7175
/* Function Body */
7176
if (lsame_(trans, "N")) {
7177
nrowa = *n;
7178
} else {
7179
nrowa = *k;
7180
}
7181
upper = lsame_(uplo, "U");
7182
7183
info = 0;
7184
if ((! upper && ! lsame_(uplo, "L"))) {
7185
info = 1;
7186
} else if ((! lsame_(trans, "N") && ! lsame_(trans,
7187
"C"))) {
7188
info = 2;
7189
} else if (*n < 0) {
7190
info = 3;
7191
} else if (*k < 0) {
7192
info = 4;
7193
} else if (*lda < max(1,nrowa)) {
7194
info = 7;
7195
} else if (*ldb < max(1,nrowa)) {
7196
info = 9;
7197
} else if (*ldc < max(1,*n)) {
7198
info = 12;
7199
}
7200
if (info != 0) {
7201
xerbla_("ZHER2K", &info);
7202
return 0;
7203
}
7204
7205
/* Quick return if possible. */
7206
7207
if (*n == 0 || (((alpha->r == 0. && alpha->i == 0.) || *k == 0) && *beta
7208
== 1.)) {
7209
return 0;
7210
}
7211
7212
/* And when alpha.eq.zero. */
7213
7214
if ((alpha->r == 0. && alpha->i == 0.)) {
7215
if (upper) {
7216
if (*beta == 0.) {
7217
i__1 = *n;
7218
for (j = 1; j <= i__1; ++j) {
7219
i__2 = j;
7220
for (i__ = 1; i__ <= i__2; ++i__) {
7221
i__3 = i__ + j * c_dim1;
7222
c__[i__3].r = 0., c__[i__3].i = 0.;
7223
/* L10: */
7224
}
7225
/* L20: */
7226
}
7227
} else {
7228
i__1 = *n;
7229
for (j = 1; j <= i__1; ++j) {
7230
i__2 = j - 1;
7231
for (i__ = 1; i__ <= i__2; ++i__) {
7232
i__3 = i__ + j * c_dim1;
7233
i__4 = i__ + j * c_dim1;
7234
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7235
i__4].i;
7236
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7237
/* L30: */
7238
}
7239
i__2 = j + j * c_dim1;
7240
i__3 = j + j * c_dim1;
7241
d__1 = *beta * c__[i__3].r;
7242
c__[i__2].r = d__1, c__[i__2].i = 0.;
7243
/* L40: */
7244
}
7245
}
7246
} else {
7247
if (*beta == 0.) {
7248
i__1 = *n;
7249
for (j = 1; j <= i__1; ++j) {
7250
i__2 = *n;
7251
for (i__ = j; i__ <= i__2; ++i__) {
7252
i__3 = i__ + j * c_dim1;
7253
c__[i__3].r = 0., c__[i__3].i = 0.;
7254
/* L50: */
7255
}
7256
/* L60: */
7257
}
7258
} else {
7259
i__1 = *n;
7260
for (j = 1; j <= i__1; ++j) {
7261
i__2 = j + j * c_dim1;
7262
i__3 = j + j * c_dim1;
7263
d__1 = *beta * c__[i__3].r;
7264
c__[i__2].r = d__1, c__[i__2].i = 0.;
7265
i__2 = *n;
7266
for (i__ = j + 1; i__ <= i__2; ++i__) {
7267
i__3 = i__ + j * c_dim1;
7268
i__4 = i__ + j * c_dim1;
7269
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7270
i__4].i;
7271
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7272
/* L70: */
7273
}
7274
/* L80: */
7275
}
7276
}
7277
}
7278
return 0;
7279
}
7280
7281
/* Start the operations. */
7282
7283
if (lsame_(trans, "N")) {
7284
7285
/*
7286
Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) +
7287
C.
7288
*/
7289
7290
if (upper) {
7291
i__1 = *n;
7292
for (j = 1; j <= i__1; ++j) {
7293
if (*beta == 0.) {
7294
i__2 = j;
7295
for (i__ = 1; i__ <= i__2; ++i__) {
7296
i__3 = i__ + j * c_dim1;
7297
c__[i__3].r = 0., c__[i__3].i = 0.;
7298
/* L90: */
7299
}
7300
} else if (*beta != 1.) {
7301
i__2 = j - 1;
7302
for (i__ = 1; i__ <= i__2; ++i__) {
7303
i__3 = i__ + j * c_dim1;
7304
i__4 = i__ + j * c_dim1;
7305
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7306
i__4].i;
7307
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7308
/* L100: */
7309
}
7310
i__2 = j + j * c_dim1;
7311
i__3 = j + j * c_dim1;
7312
d__1 = *beta * c__[i__3].r;
7313
c__[i__2].r = d__1, c__[i__2].i = 0.;
7314
} else {
7315
i__2 = j + j * c_dim1;
7316
i__3 = j + j * c_dim1;
7317
d__1 = c__[i__3].r;
7318
c__[i__2].r = d__1, c__[i__2].i = 0.;
7319
}
7320
i__2 = *k;
7321
for (l = 1; l <= i__2; ++l) {
7322
i__3 = j + l * a_dim1;
7323
i__4 = j + l * b_dim1;
7324
if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
7325
0. || b[i__4].i != 0.)) {
7326
d_cnjg(&z__2, &b[j + l * b_dim1]);
7327
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
7328
z__1.i = alpha->r * z__2.i + alpha->i *
7329
z__2.r;
7330
temp1.r = z__1.r, temp1.i = z__1.i;
7331
i__3 = j + l * a_dim1;
7332
z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
7333
z__2.i = alpha->r * a[i__3].i + alpha->i * a[
7334
i__3].r;
7335
d_cnjg(&z__1, &z__2);
7336
temp2.r = z__1.r, temp2.i = z__1.i;
7337
i__3 = j - 1;
7338
for (i__ = 1; i__ <= i__3; ++i__) {
7339
i__4 = i__ + j * c_dim1;
7340
i__5 = i__ + j * c_dim1;
7341
i__6 = i__ + l * a_dim1;
7342
z__3.r = a[i__6].r * temp1.r - a[i__6].i *
7343
temp1.i, z__3.i = a[i__6].r * temp1.i + a[
7344
i__6].i * temp1.r;
7345
z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
7346
.i + z__3.i;
7347
i__7 = i__ + l * b_dim1;
7348
z__4.r = b[i__7].r * temp2.r - b[i__7].i *
7349
temp2.i, z__4.i = b[i__7].r * temp2.i + b[
7350
i__7].i * temp2.r;
7351
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
7352
z__4.i;
7353
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
7354
/* L110: */
7355
}
7356
i__3 = j + j * c_dim1;
7357
i__4 = j + j * c_dim1;
7358
i__5 = j + l * a_dim1;
7359
z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
7360
z__2.i = a[i__5].r * temp1.i + a[i__5].i *
7361
temp1.r;
7362
i__6 = j + l * b_dim1;
7363
z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
7364
z__3.i = b[i__6].r * temp2.i + b[i__6].i *
7365
temp2.r;
7366
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
7367
d__1 = c__[i__4].r + z__1.r;
7368
c__[i__3].r = d__1, c__[i__3].i = 0.;
7369
}
7370
/* L120: */
7371
}
7372
/* L130: */
7373
}
7374
} else {
7375
i__1 = *n;
7376
for (j = 1; j <= i__1; ++j) {
7377
if (*beta == 0.) {
7378
i__2 = *n;
7379
for (i__ = j; i__ <= i__2; ++i__) {
7380
i__3 = i__ + j * c_dim1;
7381
c__[i__3].r = 0., c__[i__3].i = 0.;
7382
/* L140: */
7383
}
7384
} else if (*beta != 1.) {
7385
i__2 = *n;
7386
for (i__ = j + 1; i__ <= i__2; ++i__) {
7387
i__3 = i__ + j * c_dim1;
7388
i__4 = i__ + j * c_dim1;
7389
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7390
i__4].i;
7391
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7392
/* L150: */
7393
}
7394
i__2 = j + j * c_dim1;
7395
i__3 = j + j * c_dim1;
7396
d__1 = *beta * c__[i__3].r;
7397
c__[i__2].r = d__1, c__[i__2].i = 0.;
7398
} else {
7399
i__2 = j + j * c_dim1;
7400
i__3 = j + j * c_dim1;
7401
d__1 = c__[i__3].r;
7402
c__[i__2].r = d__1, c__[i__2].i = 0.;
7403
}
7404
i__2 = *k;
7405
for (l = 1; l <= i__2; ++l) {
7406
i__3 = j + l * a_dim1;
7407
i__4 = j + l * b_dim1;
7408
if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
7409
0. || b[i__4].i != 0.)) {
7410
d_cnjg(&z__2, &b[j + l * b_dim1]);
7411
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
7412
z__1.i = alpha->r * z__2.i + alpha->i *
7413
z__2.r;
7414
temp1.r = z__1.r, temp1.i = z__1.i;
7415
i__3 = j + l * a_dim1;
7416
z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
7417
z__2.i = alpha->r * a[i__3].i + alpha->i * a[
7418
i__3].r;
7419
d_cnjg(&z__1, &z__2);
7420
temp2.r = z__1.r, temp2.i = z__1.i;
7421
i__3 = *n;
7422
for (i__ = j + 1; i__ <= i__3; ++i__) {
7423
i__4 = i__ + j * c_dim1;
7424
i__5 = i__ + j * c_dim1;
7425
i__6 = i__ + l * a_dim1;
7426
z__3.r = a[i__6].r * temp1.r - a[i__6].i *
7427
temp1.i, z__3.i = a[i__6].r * temp1.i + a[
7428
i__6].i * temp1.r;
7429
z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
7430
.i + z__3.i;
7431
i__7 = i__ + l * b_dim1;
7432
z__4.r = b[i__7].r * temp2.r - b[i__7].i *
7433
temp2.i, z__4.i = b[i__7].r * temp2.i + b[
7434
i__7].i * temp2.r;
7435
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
7436
z__4.i;
7437
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
7438
/* L160: */
7439
}
7440
i__3 = j + j * c_dim1;
7441
i__4 = j + j * c_dim1;
7442
i__5 = j + l * a_dim1;
7443
z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
7444
z__2.i = a[i__5].r * temp1.i + a[i__5].i *
7445
temp1.r;
7446
i__6 = j + l * b_dim1;
7447
z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
7448
z__3.i = b[i__6].r * temp2.i + b[i__6].i *
7449
temp2.r;
7450
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
7451
d__1 = c__[i__4].r + z__1.r;
7452
c__[i__3].r = d__1, c__[i__3].i = 0.;
7453
}
7454
/* L170: */
7455
}
7456
/* L180: */
7457
}
7458
}
7459
} else {
7460
7461
/*
7462
Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A +
7463
C.
7464
*/
7465
7466
if (upper) {
7467
i__1 = *n;
7468
for (j = 1; j <= i__1; ++j) {
7469
i__2 = j;
7470
for (i__ = 1; i__ <= i__2; ++i__) {
7471
temp1.r = 0., temp1.i = 0.;
7472
temp2.r = 0., temp2.i = 0.;
7473
i__3 = *k;
7474
for (l = 1; l <= i__3; ++l) {
7475
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
7476
i__4 = l + j * b_dim1;
7477
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
7478
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
7479
.r;
7480
z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
7481
temp1.r = z__1.r, temp1.i = z__1.i;
7482
d_cnjg(&z__3, &b[l + i__ * b_dim1]);
7483
i__4 = l + j * a_dim1;
7484
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
7485
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
7486
.r;
7487
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
7488
temp2.r = z__1.r, temp2.i = z__1.i;
7489
/* L190: */
7490
}
7491
if (i__ == j) {
7492
if (*beta == 0.) {
7493
i__3 = j + j * c_dim1;
7494
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7495
z__2.i = alpha->r * temp1.i + alpha->i *
7496
temp1.r;
7497
d_cnjg(&z__4, alpha);
7498
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7499
z__3.i = z__4.r * temp2.i + z__4.i *
7500
temp2.r;
7501
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7502
z__3.i;
7503
d__1 = z__1.r;
7504
c__[i__3].r = d__1, c__[i__3].i = 0.;
7505
} else {
7506
i__3 = j + j * c_dim1;
7507
i__4 = j + j * c_dim1;
7508
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7509
z__2.i = alpha->r * temp1.i + alpha->i *
7510
temp1.r;
7511
d_cnjg(&z__4, alpha);
7512
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7513
z__3.i = z__4.r * temp2.i + z__4.i *
7514
temp2.r;
7515
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7516
z__3.i;
7517
d__1 = *beta * c__[i__4].r + z__1.r;
7518
c__[i__3].r = d__1, c__[i__3].i = 0.;
7519
}
7520
} else {
7521
if (*beta == 0.) {
7522
i__3 = i__ + j * c_dim1;
7523
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7524
z__2.i = alpha->r * temp1.i + alpha->i *
7525
temp1.r;
7526
d_cnjg(&z__4, alpha);
7527
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7528
z__3.i = z__4.r * temp2.i + z__4.i *
7529
temp2.r;
7530
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7531
z__3.i;
7532
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7533
} else {
7534
i__3 = i__ + j * c_dim1;
7535
i__4 = i__ + j * c_dim1;
7536
z__3.r = *beta * c__[i__4].r, z__3.i = *beta *
7537
c__[i__4].i;
7538
z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
7539
z__4.i = alpha->r * temp1.i + alpha->i *
7540
temp1.r;
7541
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i +
7542
z__4.i;
7543
d_cnjg(&z__6, alpha);
7544
z__5.r = z__6.r * temp2.r - z__6.i * temp2.i,
7545
z__5.i = z__6.r * temp2.i + z__6.i *
7546
temp2.r;
7547
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i +
7548
z__5.i;
7549
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7550
}
7551
}
7552
/* L200: */
7553
}
7554
/* L210: */
7555
}
7556
} else {
7557
i__1 = *n;
7558
for (j = 1; j <= i__1; ++j) {
7559
i__2 = *n;
7560
for (i__ = j; i__ <= i__2; ++i__) {
7561
temp1.r = 0., temp1.i = 0.;
7562
temp2.r = 0., temp2.i = 0.;
7563
i__3 = *k;
7564
for (l = 1; l <= i__3; ++l) {
7565
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
7566
i__4 = l + j * b_dim1;
7567
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
7568
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
7569
.r;
7570
z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
7571
temp1.r = z__1.r, temp1.i = z__1.i;
7572
d_cnjg(&z__3, &b[l + i__ * b_dim1]);
7573
i__4 = l + j * a_dim1;
7574
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
7575
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
7576
.r;
7577
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
7578
temp2.r = z__1.r, temp2.i = z__1.i;
7579
/* L220: */
7580
}
7581
if (i__ == j) {
7582
if (*beta == 0.) {
7583
i__3 = j + j * c_dim1;
7584
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7585
z__2.i = alpha->r * temp1.i + alpha->i *
7586
temp1.r;
7587
d_cnjg(&z__4, alpha);
7588
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7589
z__3.i = z__4.r * temp2.i + z__4.i *
7590
temp2.r;
7591
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7592
z__3.i;
7593
d__1 = z__1.r;
7594
c__[i__3].r = d__1, c__[i__3].i = 0.;
7595
} else {
7596
i__3 = j + j * c_dim1;
7597
i__4 = j + j * c_dim1;
7598
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7599
z__2.i = alpha->r * temp1.i + alpha->i *
7600
temp1.r;
7601
d_cnjg(&z__4, alpha);
7602
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7603
z__3.i = z__4.r * temp2.i + z__4.i *
7604
temp2.r;
7605
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7606
z__3.i;
7607
d__1 = *beta * c__[i__4].r + z__1.r;
7608
c__[i__3].r = d__1, c__[i__3].i = 0.;
7609
}
7610
} else {
7611
if (*beta == 0.) {
7612
i__3 = i__ + j * c_dim1;
7613
z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
7614
z__2.i = alpha->r * temp1.i + alpha->i *
7615
temp1.r;
7616
d_cnjg(&z__4, alpha);
7617
z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
7618
z__3.i = z__4.r * temp2.i + z__4.i *
7619
temp2.r;
7620
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
7621
z__3.i;
7622
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7623
} else {
7624
i__3 = i__ + j * c_dim1;
7625
i__4 = i__ + j * c_dim1;
7626
z__3.r = *beta * c__[i__4].r, z__3.i = *beta *
7627
c__[i__4].i;
7628
z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
7629
z__4.i = alpha->r * temp1.i + alpha->i *
7630
temp1.r;
7631
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i +
7632
z__4.i;
7633
d_cnjg(&z__6, alpha);
7634
z__5.r = z__6.r * temp2.r - z__6.i * temp2.i,
7635
z__5.i = z__6.r * temp2.i + z__6.i *
7636
temp2.r;
7637
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i +
7638
z__5.i;
7639
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7640
}
7641
}
7642
/* L230: */
7643
}
7644
/* L240: */
7645
}
7646
}
7647
}
7648
7649
return 0;
7650
7651
/* End of ZHER2K. */
7652
7653
} /* zher2k_ */
7654
7655
/* Subroutine */ int zherk_(char *uplo, char *trans, integer *n, integer *k,
7656
doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta,
7657
doublecomplex *c__, integer *ldc)
7658
{
7659
/* System generated locals */
7660
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
7661
i__6;
7662
doublereal d__1;
7663
doublecomplex z__1, z__2, z__3;
7664
7665
/* Builtin functions */
7666
void d_cnjg(doublecomplex *, doublecomplex *);
7667
7668
/* Local variables */
7669
static integer i__, j, l, info;
7670
static doublecomplex temp;
7671
extern logical lsame_(char *, char *);
7672
static integer nrowa;
7673
static doublereal rtemp;
7674
static logical upper;
7675
extern /* Subroutine */ int xerbla_(char *, integer *);
7676
7677
7678
/*
7679
Purpose
7680
=======
7681
7682
ZHERK performs one of the hermitian rank k operations
7683
7684
C := alpha*A*conjg( A' ) + beta*C,
7685
7686
or
7687
7688
C := alpha*conjg( A' )*A + beta*C,
7689
7690
where alpha and beta are real scalars, C is an n by n hermitian
7691
matrix and A is an n by k matrix in the first case and a k by n
7692
matrix in the second case.
7693
7694
Parameters
7695
==========
7696
7697
UPLO - CHARACTER*1.
7698
On entry, UPLO specifies whether the upper or lower
7699
triangular part of the array C is to be referenced as
7700
follows:
7701
7702
UPLO = 'U' or 'u' Only the upper triangular part of C
7703
is to be referenced.
7704
7705
UPLO = 'L' or 'l' Only the lower triangular part of C
7706
is to be referenced.
7707
7708
Unchanged on exit.
7709
7710
TRANS - CHARACTER*1.
7711
On entry, TRANS specifies the operation to be performed as
7712
follows:
7713
7714
TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.
7715
7716
TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.
7717
7718
Unchanged on exit.
7719
7720
N - INTEGER.
7721
On entry, N specifies the order of the matrix C. N must be
7722
at least zero.
7723
Unchanged on exit.
7724
7725
K - INTEGER.
7726
On entry with TRANS = 'N' or 'n', K specifies the number
7727
of columns of the matrix A, and on entry with
7728
TRANS = 'C' or 'c', K specifies the number of rows of the
7729
matrix A. K must be at least zero.
7730
Unchanged on exit.
7731
7732
ALPHA - DOUBLE PRECISION .
7733
On entry, ALPHA specifies the scalar alpha.
7734
Unchanged on exit.
7735
7736
A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
7737
k when TRANS = 'N' or 'n', and is n otherwise.
7738
Before entry with TRANS = 'N' or 'n', the leading n by k
7739
part of the array A must contain the matrix A, otherwise
7740
the leading k by n part of the array A must contain the
7741
matrix A.
7742
Unchanged on exit.
7743
7744
LDA - INTEGER.
7745
On entry, LDA specifies the first dimension of A as declared
7746
in the calling (sub) program. When TRANS = 'N' or 'n'
7747
then LDA must be at least max( 1, n ), otherwise LDA must
7748
be at least max( 1, k ).
7749
Unchanged on exit.
7750
7751
BETA - DOUBLE PRECISION.
7752
On entry, BETA specifies the scalar beta.
7753
Unchanged on exit.
7754
7755
C - COMPLEX*16 array of DIMENSION ( LDC, n ).
7756
Before entry with UPLO = 'U' or 'u', the leading n by n
7757
upper triangular part of the array C must contain the upper
7758
triangular part of the hermitian matrix and the strictly
7759
lower triangular part of C is not referenced. On exit, the
7760
upper triangular part of the array C is overwritten by the
7761
upper triangular part of the updated matrix.
7762
Before entry with UPLO = 'L' or 'l', the leading n by n
7763
lower triangular part of the array C must contain the lower
7764
triangular part of the hermitian matrix and the strictly
7765
upper triangular part of C is not referenced. On exit, the
7766
lower triangular part of the array C is overwritten by the
7767
lower triangular part of the updated matrix.
7768
Note that the imaginary parts of the diagonal elements need
7769
not be set, they are assumed to be zero, and on exit they
7770
are set to zero.
7771
7772
LDC - INTEGER.
7773
On entry, LDC specifies the first dimension of C as declared
7774
in the calling (sub) program. LDC must be at least
7775
max( 1, n ).
7776
Unchanged on exit.
7777
7778
7779
Level 3 Blas routine.
7780
7781
-- Written on 8-February-1989.
7782
Jack Dongarra, Argonne National Laboratory.
7783
Iain Duff, AERE Harwell.
7784
Jeremy Du Croz, Numerical Algorithms Group Ltd.
7785
Sven Hammarling, Numerical Algorithms Group Ltd.
7786
7787
-- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
7788
Ed Anderson, Cray Research Inc.
7789
7790
7791
Test the input parameters.
7792
*/
7793
7794
/* Parameter adjustments */
7795
a_dim1 = *lda;
7796
a_offset = 1 + a_dim1 * 1;
7797
a -= a_offset;
7798
c_dim1 = *ldc;
7799
c_offset = 1 + c_dim1 * 1;
7800
c__ -= c_offset;
7801
7802
/* Function Body */
7803
if (lsame_(trans, "N")) {
7804
nrowa = *n;
7805
} else {
7806
nrowa = *k;
7807
}
7808
upper = lsame_(uplo, "U");
7809
7810
info = 0;
7811
if ((! upper && ! lsame_(uplo, "L"))) {
7812
info = 1;
7813
} else if ((! lsame_(trans, "N") && ! lsame_(trans,
7814
"C"))) {
7815
info = 2;
7816
} else if (*n < 0) {
7817
info = 3;
7818
} else if (*k < 0) {
7819
info = 4;
7820
} else if (*lda < max(1,nrowa)) {
7821
info = 7;
7822
} else if (*ldc < max(1,*n)) {
7823
info = 10;
7824
}
7825
if (info != 0) {
7826
xerbla_("ZHERK ", &info);
7827
return 0;
7828
}
7829
7830
/* Quick return if possible. */
7831
7832
if (*n == 0 || ((*alpha == 0. || *k == 0) && *beta == 1.)) {
7833
return 0;
7834
}
7835
7836
/* And when alpha.eq.zero. */
7837
7838
if (*alpha == 0.) {
7839
if (upper) {
7840
if (*beta == 0.) {
7841
i__1 = *n;
7842
for (j = 1; j <= i__1; ++j) {
7843
i__2 = j;
7844
for (i__ = 1; i__ <= i__2; ++i__) {
7845
i__3 = i__ + j * c_dim1;
7846
c__[i__3].r = 0., c__[i__3].i = 0.;
7847
/* L10: */
7848
}
7849
/* L20: */
7850
}
7851
} else {
7852
i__1 = *n;
7853
for (j = 1; j <= i__1; ++j) {
7854
i__2 = j - 1;
7855
for (i__ = 1; i__ <= i__2; ++i__) {
7856
i__3 = i__ + j * c_dim1;
7857
i__4 = i__ + j * c_dim1;
7858
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7859
i__4].i;
7860
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7861
/* L30: */
7862
}
7863
i__2 = j + j * c_dim1;
7864
i__3 = j + j * c_dim1;
7865
d__1 = *beta * c__[i__3].r;
7866
c__[i__2].r = d__1, c__[i__2].i = 0.;
7867
/* L40: */
7868
}
7869
}
7870
} else {
7871
if (*beta == 0.) {
7872
i__1 = *n;
7873
for (j = 1; j <= i__1; ++j) {
7874
i__2 = *n;
7875
for (i__ = j; i__ <= i__2; ++i__) {
7876
i__3 = i__ + j * c_dim1;
7877
c__[i__3].r = 0., c__[i__3].i = 0.;
7878
/* L50: */
7879
}
7880
/* L60: */
7881
}
7882
} else {
7883
i__1 = *n;
7884
for (j = 1; j <= i__1; ++j) {
7885
i__2 = j + j * c_dim1;
7886
i__3 = j + j * c_dim1;
7887
d__1 = *beta * c__[i__3].r;
7888
c__[i__2].r = d__1, c__[i__2].i = 0.;
7889
i__2 = *n;
7890
for (i__ = j + 1; i__ <= i__2; ++i__) {
7891
i__3 = i__ + j * c_dim1;
7892
i__4 = i__ + j * c_dim1;
7893
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7894
i__4].i;
7895
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7896
/* L70: */
7897
}
7898
/* L80: */
7899
}
7900
}
7901
}
7902
return 0;
7903
}
7904
7905
/* Start the operations. */
7906
7907
if (lsame_(trans, "N")) {
7908
7909
/* Form C := alpha*A*conjg( A' ) + beta*C. */
7910
7911
if (upper) {
7912
i__1 = *n;
7913
for (j = 1; j <= i__1; ++j) {
7914
if (*beta == 0.) {
7915
i__2 = j;
7916
for (i__ = 1; i__ <= i__2; ++i__) {
7917
i__3 = i__ + j * c_dim1;
7918
c__[i__3].r = 0., c__[i__3].i = 0.;
7919
/* L90: */
7920
}
7921
} else if (*beta != 1.) {
7922
i__2 = j - 1;
7923
for (i__ = 1; i__ <= i__2; ++i__) {
7924
i__3 = i__ + j * c_dim1;
7925
i__4 = i__ + j * c_dim1;
7926
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7927
i__4].i;
7928
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7929
/* L100: */
7930
}
7931
i__2 = j + j * c_dim1;
7932
i__3 = j + j * c_dim1;
7933
d__1 = *beta * c__[i__3].r;
7934
c__[i__2].r = d__1, c__[i__2].i = 0.;
7935
} else {
7936
i__2 = j + j * c_dim1;
7937
i__3 = j + j * c_dim1;
7938
d__1 = c__[i__3].r;
7939
c__[i__2].r = d__1, c__[i__2].i = 0.;
7940
}
7941
i__2 = *k;
7942
for (l = 1; l <= i__2; ++l) {
7943
i__3 = j + l * a_dim1;
7944
if (a[i__3].r != 0. || a[i__3].i != 0.) {
7945
d_cnjg(&z__2, &a[j + l * a_dim1]);
7946
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
7947
temp.r = z__1.r, temp.i = z__1.i;
7948
i__3 = j - 1;
7949
for (i__ = 1; i__ <= i__3; ++i__) {
7950
i__4 = i__ + j * c_dim1;
7951
i__5 = i__ + j * c_dim1;
7952
i__6 = i__ + l * a_dim1;
7953
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
7954
z__2.i = temp.r * a[i__6].i + temp.i * a[
7955
i__6].r;
7956
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
7957
.i + z__2.i;
7958
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
7959
/* L110: */
7960
}
7961
i__3 = j + j * c_dim1;
7962
i__4 = j + j * c_dim1;
7963
i__5 = i__ + l * a_dim1;
7964
z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
7965
z__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
7966
.r;
7967
d__1 = c__[i__4].r + z__1.r;
7968
c__[i__3].r = d__1, c__[i__3].i = 0.;
7969
}
7970
/* L120: */
7971
}
7972
/* L130: */
7973
}
7974
} else {
7975
i__1 = *n;
7976
for (j = 1; j <= i__1; ++j) {
7977
if (*beta == 0.) {
7978
i__2 = *n;
7979
for (i__ = j; i__ <= i__2; ++i__) {
7980
i__3 = i__ + j * c_dim1;
7981
c__[i__3].r = 0., c__[i__3].i = 0.;
7982
/* L140: */
7983
}
7984
} else if (*beta != 1.) {
7985
i__2 = j + j * c_dim1;
7986
i__3 = j + j * c_dim1;
7987
d__1 = *beta * c__[i__3].r;
7988
c__[i__2].r = d__1, c__[i__2].i = 0.;
7989
i__2 = *n;
7990
for (i__ = j + 1; i__ <= i__2; ++i__) {
7991
i__3 = i__ + j * c_dim1;
7992
i__4 = i__ + j * c_dim1;
7993
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
7994
i__4].i;
7995
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
7996
/* L150: */
7997
}
7998
} else {
7999
i__2 = j + j * c_dim1;
8000
i__3 = j + j * c_dim1;
8001
d__1 = c__[i__3].r;
8002
c__[i__2].r = d__1, c__[i__2].i = 0.;
8003
}
8004
i__2 = *k;
8005
for (l = 1; l <= i__2; ++l) {
8006
i__3 = j + l * a_dim1;
8007
if (a[i__3].r != 0. || a[i__3].i != 0.) {
8008
d_cnjg(&z__2, &a[j + l * a_dim1]);
8009
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
8010
temp.r = z__1.r, temp.i = z__1.i;
8011
i__3 = j + j * c_dim1;
8012
i__4 = j + j * c_dim1;
8013
i__5 = j + l * a_dim1;
8014
z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
8015
z__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
8016
.r;
8017
d__1 = c__[i__4].r + z__1.r;
8018
c__[i__3].r = d__1, c__[i__3].i = 0.;
8019
i__3 = *n;
8020
for (i__ = j + 1; i__ <= i__3; ++i__) {
8021
i__4 = i__ + j * c_dim1;
8022
i__5 = i__ + j * c_dim1;
8023
i__6 = i__ + l * a_dim1;
8024
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
8025
z__2.i = temp.r * a[i__6].i + temp.i * a[
8026
i__6].r;
8027
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
8028
.i + z__2.i;
8029
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
8030
/* L160: */
8031
}
8032
}
8033
/* L170: */
8034
}
8035
/* L180: */
8036
}
8037
}
8038
} else {
8039
8040
/* Form C := alpha*conjg( A' )*A + beta*C. */
8041
8042
if (upper) {
8043
i__1 = *n;
8044
for (j = 1; j <= i__1; ++j) {
8045
i__2 = j - 1;
8046
for (i__ = 1; i__ <= i__2; ++i__) {
8047
temp.r = 0., temp.i = 0.;
8048
i__3 = *k;
8049
for (l = 1; l <= i__3; ++l) {
8050
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
8051
i__4 = l + j * a_dim1;
8052
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
8053
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
8054
.r;
8055
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
8056
temp.r = z__1.r, temp.i = z__1.i;
8057
/* L190: */
8058
}
8059
if (*beta == 0.) {
8060
i__3 = i__ + j * c_dim1;
8061
z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
8062
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
8063
} else {
8064
i__3 = i__ + j * c_dim1;
8065
z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
8066
i__4 = i__ + j * c_dim1;
8067
z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[
8068
i__4].i;
8069
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
8070
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
8071
}
8072
/* L200: */
8073
}
8074
rtemp = 0.;
8075
i__2 = *k;
8076
for (l = 1; l <= i__2; ++l) {
8077
d_cnjg(&z__3, &a[l + j * a_dim1]);
8078
i__3 = l + j * a_dim1;
8079
z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i =
8080
z__3.r * a[i__3].i + z__3.i * a[i__3].r;
8081
z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
8082
rtemp = z__1.r;
8083
/* L210: */
8084
}
8085
if (*beta == 0.) {
8086
i__2 = j + j * c_dim1;
8087
d__1 = *alpha * rtemp;
8088
c__[i__2].r = d__1, c__[i__2].i = 0.;
8089
} else {
8090
i__2 = j + j * c_dim1;
8091
i__3 = j + j * c_dim1;
8092
d__1 = *alpha * rtemp + *beta * c__[i__3].r;
8093
c__[i__2].r = d__1, c__[i__2].i = 0.;
8094
}
8095
/* L220: */
8096
}
8097
} else {
8098
i__1 = *n;
8099
for (j = 1; j <= i__1; ++j) {
8100
rtemp = 0.;
8101
i__2 = *k;
8102
for (l = 1; l <= i__2; ++l) {
8103
d_cnjg(&z__3, &a[l + j * a_dim1]);
8104
i__3 = l + j * a_dim1;
8105
z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i =
8106
z__3.r * a[i__3].i + z__3.i * a[i__3].r;
8107
z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
8108
rtemp = z__1.r;
8109
/* L230: */
8110
}
8111
if (*beta == 0.) {
8112
i__2 = j + j * c_dim1;
8113
d__1 = *alpha * rtemp;
8114
c__[i__2].r = d__1, c__[i__2].i = 0.;
8115
} else {
8116
i__2 = j + j * c_dim1;
8117
i__3 = j + j * c_dim1;
8118
d__1 = *alpha * rtemp + *beta * c__[i__3].r;
8119
c__[i__2].r = d__1, c__[i__2].i = 0.;
8120
}
8121
i__2 = *n;
8122
for (i__ = j + 1; i__ <= i__2; ++i__) {
8123
temp.r = 0., temp.i = 0.;
8124
i__3 = *k;
8125
for (l = 1; l <= i__3; ++l) {
8126
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
8127
i__4 = l + j * a_dim1;
8128
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
8129
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
8130
.r;
8131
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
8132
temp.r = z__1.r, temp.i = z__1.i;
8133
/* L240: */
8134
}
8135
if (*beta == 0.) {
8136
i__3 = i__ + j * c_dim1;
8137
z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
8138
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
8139
} else {
8140
i__3 = i__ + j * c_dim1;
8141
z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
8142
i__4 = i__ + j * c_dim1;
8143
z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[
8144
i__4].i;
8145
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
8146
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
8147
}
8148
/* L250: */
8149
}
8150
/* L260: */
8151
}
8152
}
8153
}
8154
8155
return 0;
8156
8157
/* End of ZHERK . */
8158
8159
} /* zherk_ */
8160
8161
/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx,
8162
integer *incx)
8163
{
8164
/* System generated locals */
8165
integer i__1, i__2, i__3;
8166
doublecomplex z__1;
8167
8168
/* Local variables */
8169
static integer i__, ix;
8170
8171
8172
/*
8173
scales a vector by a constant.
8174
jack dongarra, 3/11/78.
8175
modified 3/93 to return if incx .le. 0.
8176
modified 12/3/93, array(1) declarations changed to array(*)
8177
*/
8178
8179
8180
/* Parameter adjustments */
8181
--zx;
8182
8183
/* Function Body */
8184
if (*n <= 0 || *incx <= 0) {
8185
return 0;
8186
}
8187
if (*incx == 1) {
8188
goto L20;
8189
}
8190
8191
/* code for increment not equal to 1 */
8192
8193
ix = 1;
8194
i__1 = *n;
8195
for (i__ = 1; i__ <= i__1; ++i__) {
8196
i__2 = ix;
8197
i__3 = ix;
8198
z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[
8199
i__3].i + za->i * zx[i__3].r;
8200
zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
8201
ix += *incx;
8202
/* L10: */
8203
}
8204
return 0;
8205
8206
/* code for increment equal to 1 */
8207
8208
L20:
8209
i__1 = *n;
8210
for (i__ = 1; i__ <= i__1; ++i__) {
8211
i__2 = i__;
8212
i__3 = i__;
8213
z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[
8214
i__3].i + za->i * zx[i__3].r;
8215
zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
8216
/* L30: */
8217
}
8218
return 0;
8219
} /* zscal_ */
8220
8221
/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx,
8222
doublecomplex *zy, integer *incy)
8223
{
8224
/* System generated locals */
8225
integer i__1, i__2, i__3;
8226
8227
/* Local variables */
8228
static integer i__, ix, iy;
8229
static doublecomplex ztemp;
8230
8231
8232
/*
8233
interchanges two vectors.
8234
jack dongarra, 3/11/78.
8235
modified 12/3/93, array(1) declarations changed to array(*)
8236
*/
8237
8238
8239
/* Parameter adjustments */
8240
--zy;
8241
--zx;
8242
8243
/* Function Body */
8244
if (*n <= 0) {
8245
return 0;
8246
}
8247
if ((*incx == 1 && *incy == 1)) {
8248
goto L20;
8249
}
8250
8251
/*
8252
code for unequal increments or equal increments not equal
8253
to 1
8254
*/
8255
8256
ix = 1;
8257
iy = 1;
8258
if (*incx < 0) {
8259
ix = (-(*n) + 1) * *incx + 1;
8260
}
8261
if (*incy < 0) {
8262
iy = (-(*n) + 1) * *incy + 1;
8263
}
8264
i__1 = *n;
8265
for (i__ = 1; i__ <= i__1; ++i__) {
8266
i__2 = ix;
8267
ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i;
8268
i__2 = ix;
8269
i__3 = iy;
8270
zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i;
8271
i__2 = iy;
8272
zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i;
8273
ix += *incx;
8274
iy += *incy;
8275
/* L10: */
8276
}
8277
return 0;
8278
8279
/* code for both increments equal to 1 */
8280
L20:
8281
i__1 = *n;
8282
for (i__ = 1; i__ <= i__1; ++i__) {
8283
i__2 = i__;
8284
ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i;
8285
i__2 = i__;
8286
i__3 = i__;
8287
zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i;
8288
i__2 = i__;
8289
zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i;
8290
/* L30: */
8291
}
8292
return 0;
8293
} /* zswap_ */
8294
8295
/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag,
8296
integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
8297
integer *lda, doublecomplex *b, integer *ldb)
8298
{
8299
/* System generated locals */
8300
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
8301
i__6;
8302
doublecomplex z__1, z__2, z__3;
8303
8304
/* Builtin functions */
8305
void d_cnjg(doublecomplex *, doublecomplex *);
8306
8307
/* Local variables */
8308
static integer i__, j, k, info;
8309
static doublecomplex temp;
8310
static logical lside;
8311
extern logical lsame_(char *, char *);
8312
static integer nrowa;
8313
static logical upper;
8314
extern /* Subroutine */ int xerbla_(char *, integer *);
8315
static logical noconj, nounit;
8316
8317
8318
/*
8319
Purpose
8320
=======
8321
8322
ZTRMM performs one of the matrix-matrix operations
8323
8324
B := alpha*op( A )*B, or B := alpha*B*op( A )
8325
8326
where alpha is a scalar, B is an m by n matrix, A is a unit, or
8327
non-unit, upper or lower triangular matrix and op( A ) is one of
8328
8329
op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
8330
8331
Parameters
8332
==========
8333
8334
SIDE - CHARACTER*1.
8335
On entry, SIDE specifies whether op( A ) multiplies B from
8336
the left or right as follows:
8337
8338
SIDE = 'L' or 'l' B := alpha*op( A )*B.
8339
8340
SIDE = 'R' or 'r' B := alpha*B*op( A ).
8341
8342
Unchanged on exit.
8343
8344
UPLO - CHARACTER*1.
8345
On entry, UPLO specifies whether the matrix A is an upper or
8346
lower triangular matrix as follows:
8347
8348
UPLO = 'U' or 'u' A is an upper triangular matrix.
8349
8350
UPLO = 'L' or 'l' A is a lower triangular matrix.
8351
8352
Unchanged on exit.
8353
8354
TRANSA - CHARACTER*1.
8355
On entry, TRANSA specifies the form of op( A ) to be used in
8356
the matrix multiplication as follows:
8357
8358
TRANSA = 'N' or 'n' op( A ) = A.
8359
8360
TRANSA = 'T' or 't' op( A ) = A'.
8361
8362
TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
8363
8364
Unchanged on exit.
8365
8366
DIAG - CHARACTER*1.
8367
On entry, DIAG specifies whether or not A is unit triangular
8368
as follows:
8369
8370
DIAG = 'U' or 'u' A is assumed to be unit triangular.
8371
8372
DIAG = 'N' or 'n' A is not assumed to be unit
8373
triangular.
8374
8375
Unchanged on exit.
8376
8377
M - INTEGER.
8378
On entry, M specifies the number of rows of B. M must be at
8379
least zero.
8380
Unchanged on exit.
8381
8382
N - INTEGER.
8383
On entry, N specifies the number of columns of B. N must be
8384
at least zero.
8385
Unchanged on exit.
8386
8387
ALPHA - COMPLEX*16 .
8388
On entry, ALPHA specifies the scalar alpha. When alpha is
8389
zero then A is not referenced and B need not be set before
8390
entry.
8391
Unchanged on exit.
8392
8393
A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m
8394
when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
8395
Before entry with UPLO = 'U' or 'u', the leading k by k
8396
upper triangular part of the array A must contain the upper
8397
triangular matrix and the strictly lower triangular part of
8398
A is not referenced.
8399
Before entry with UPLO = 'L' or 'l', the leading k by k
8400
lower triangular part of the array A must contain the lower
8401
triangular matrix and the strictly upper triangular part of
8402
A is not referenced.
8403
Note that when DIAG = 'U' or 'u', the diagonal elements of
8404
A are not referenced either, but are assumed to be unity.
8405
Unchanged on exit.
8406
8407
LDA - INTEGER.
8408
On entry, LDA specifies the first dimension of A as declared
8409
in the calling (sub) program. When SIDE = 'L' or 'l' then
8410
LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
8411
then LDA must be at least max( 1, n ).
8412
Unchanged on exit.
8413
8414
B - COMPLEX*16 array of DIMENSION ( LDB, n ).
8415
Before entry, the leading m by n part of the array B must
8416
contain the matrix B, and on exit is overwritten by the
8417
transformed matrix.
8418
8419
LDB - INTEGER.
8420
On entry, LDB specifies the first dimension of B as declared
8421
in the calling (sub) program. LDB must be at least
8422
max( 1, m ).
8423
Unchanged on exit.
8424
8425
8426
Level 3 Blas routine.
8427
8428
-- Written on 8-February-1989.
8429
Jack Dongarra, Argonne National Laboratory.
8430
Iain Duff, AERE Harwell.
8431
Jeremy Du Croz, Numerical Algorithms Group Ltd.
8432
Sven Hammarling, Numerical Algorithms Group Ltd.
8433
8434
8435
Test the input parameters.
8436
*/
8437
8438
/* Parameter adjustments */
8439
a_dim1 = *lda;
8440
a_offset = 1 + a_dim1 * 1;
8441
a -= a_offset;
8442
b_dim1 = *ldb;
8443
b_offset = 1 + b_dim1 * 1;
8444
b -= b_offset;
8445
8446
/* Function Body */
8447
lside = lsame_(side, "L");
8448
if (lside) {
8449
nrowa = *m;
8450
} else {
8451
nrowa = *n;
8452
}
8453
noconj = lsame_(transa, "T");
8454
nounit = lsame_(diag, "N");
8455
upper = lsame_(uplo, "U");
8456
8457
info = 0;
8458
if ((! lside && ! lsame_(side, "R"))) {
8459
info = 1;
8460
} else if ((! upper && ! lsame_(uplo, "L"))) {
8461
info = 2;
8462
} else if (((! lsame_(transa, "N") && ! lsame_(
8463
transa, "T")) && ! lsame_(transa, "C"))) {
8464
info = 3;
8465
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
8466
"N"))) {
8467
info = 4;
8468
} else if (*m < 0) {
8469
info = 5;
8470
} else if (*n < 0) {
8471
info = 6;
8472
} else if (*lda < max(1,nrowa)) {
8473
info = 9;
8474
} else if (*ldb < max(1,*m)) {
8475
info = 11;
8476
}
8477
if (info != 0) {
8478
xerbla_("ZTRMM ", &info);
8479
return 0;
8480
}
8481
8482
/* Quick return if possible. */
8483
8484
if (*n == 0) {
8485
return 0;
8486
}
8487
8488
/* And when alpha.eq.zero. */
8489
8490
if ((alpha->r == 0. && alpha->i == 0.)) {
8491
i__1 = *n;
8492
for (j = 1; j <= i__1; ++j) {
8493
i__2 = *m;
8494
for (i__ = 1; i__ <= i__2; ++i__) {
8495
i__3 = i__ + j * b_dim1;
8496
b[i__3].r = 0., b[i__3].i = 0.;
8497
/* L10: */
8498
}
8499
/* L20: */
8500
}
8501
return 0;
8502
}
8503
8504
/* Start the operations. */
8505
8506
if (lside) {
8507
if (lsame_(transa, "N")) {
8508
8509
/* Form B := alpha*A*B. */
8510
8511
if (upper) {
8512
i__1 = *n;
8513
for (j = 1; j <= i__1; ++j) {
8514
i__2 = *m;
8515
for (k = 1; k <= i__2; ++k) {
8516
i__3 = k + j * b_dim1;
8517
if (b[i__3].r != 0. || b[i__3].i != 0.) {
8518
i__3 = k + j * b_dim1;
8519
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
8520
.i, z__1.i = alpha->r * b[i__3].i +
8521
alpha->i * b[i__3].r;
8522
temp.r = z__1.r, temp.i = z__1.i;
8523
i__3 = k - 1;
8524
for (i__ = 1; i__ <= i__3; ++i__) {
8525
i__4 = i__ + j * b_dim1;
8526
i__5 = i__ + j * b_dim1;
8527
i__6 = i__ + k * a_dim1;
8528
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6]
8529
.i, z__2.i = temp.r * a[i__6].i +
8530
temp.i * a[i__6].r;
8531
z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
8532
.i + z__2.i;
8533
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
8534
/* L30: */
8535
}
8536
if (nounit) {
8537
i__3 = k + k * a_dim1;
8538
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
8539
.i, z__1.i = temp.r * a[i__3].i +
8540
temp.i * a[i__3].r;
8541
temp.r = z__1.r, temp.i = z__1.i;
8542
}
8543
i__3 = k + j * b_dim1;
8544
b[i__3].r = temp.r, b[i__3].i = temp.i;
8545
}
8546
/* L40: */
8547
}
8548
/* L50: */
8549
}
8550
} else {
8551
i__1 = *n;
8552
for (j = 1; j <= i__1; ++j) {
8553
for (k = *m; k >= 1; --k) {
8554
i__2 = k + j * b_dim1;
8555
if (b[i__2].r != 0. || b[i__2].i != 0.) {
8556
i__2 = k + j * b_dim1;
8557
z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2]
8558
.i, z__1.i = alpha->r * b[i__2].i +
8559
alpha->i * b[i__2].r;
8560
temp.r = z__1.r, temp.i = z__1.i;
8561
i__2 = k + j * b_dim1;
8562
b[i__2].r = temp.r, b[i__2].i = temp.i;
8563
if (nounit) {
8564
i__2 = k + j * b_dim1;
8565
i__3 = k + j * b_dim1;
8566
i__4 = k + k * a_dim1;
8567
z__1.r = b[i__3].r * a[i__4].r - b[i__3].i *
8568
a[i__4].i, z__1.i = b[i__3].r * a[
8569
i__4].i + b[i__3].i * a[i__4].r;
8570
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
8571
}
8572
i__2 = *m;
8573
for (i__ = k + 1; i__ <= i__2; ++i__) {
8574
i__3 = i__ + j * b_dim1;
8575
i__4 = i__ + j * b_dim1;
8576
i__5 = i__ + k * a_dim1;
8577
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5]
8578
.i, z__2.i = temp.r * a[i__5].i +
8579
temp.i * a[i__5].r;
8580
z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
8581
.i + z__2.i;
8582
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8583
/* L60: */
8584
}
8585
}
8586
/* L70: */
8587
}
8588
/* L80: */
8589
}
8590
}
8591
} else {
8592
8593
/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */
8594
8595
if (upper) {
8596
i__1 = *n;
8597
for (j = 1; j <= i__1; ++j) {
8598
for (i__ = *m; i__ >= 1; --i__) {
8599
i__2 = i__ + j * b_dim1;
8600
temp.r = b[i__2].r, temp.i = b[i__2].i;
8601
if (noconj) {
8602
if (nounit) {
8603
i__2 = i__ + i__ * a_dim1;
8604
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2]
8605
.i, z__1.i = temp.r * a[i__2].i +
8606
temp.i * a[i__2].r;
8607
temp.r = z__1.r, temp.i = z__1.i;
8608
}
8609
i__2 = i__ - 1;
8610
for (k = 1; k <= i__2; ++k) {
8611
i__3 = k + i__ * a_dim1;
8612
i__4 = k + j * b_dim1;
8613
z__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
8614
b[i__4].i, z__2.i = a[i__3].r * b[
8615
i__4].i + a[i__3].i * b[i__4].r;
8616
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
8617
z__2.i;
8618
temp.r = z__1.r, temp.i = z__1.i;
8619
/* L90: */
8620
}
8621
} else {
8622
if (nounit) {
8623
d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
8624
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
8625
z__1.i = temp.r * z__2.i + temp.i *
8626
z__2.r;
8627
temp.r = z__1.r, temp.i = z__1.i;
8628
}
8629
i__2 = i__ - 1;
8630
for (k = 1; k <= i__2; ++k) {
8631
d_cnjg(&z__3, &a[k + i__ * a_dim1]);
8632
i__3 = k + j * b_dim1;
8633
z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3]
8634
.i, z__2.i = z__3.r * b[i__3].i +
8635
z__3.i * b[i__3].r;
8636
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
8637
z__2.i;
8638
temp.r = z__1.r, temp.i = z__1.i;
8639
/* L100: */
8640
}
8641
}
8642
i__2 = i__ + j * b_dim1;
8643
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
8644
z__1.i = alpha->r * temp.i + alpha->i *
8645
temp.r;
8646
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
8647
/* L110: */
8648
}
8649
/* L120: */
8650
}
8651
} else {
8652
i__1 = *n;
8653
for (j = 1; j <= i__1; ++j) {
8654
i__2 = *m;
8655
for (i__ = 1; i__ <= i__2; ++i__) {
8656
i__3 = i__ + j * b_dim1;
8657
temp.r = b[i__3].r, temp.i = b[i__3].i;
8658
if (noconj) {
8659
if (nounit) {
8660
i__3 = i__ + i__ * a_dim1;
8661
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
8662
.i, z__1.i = temp.r * a[i__3].i +
8663
temp.i * a[i__3].r;
8664
temp.r = z__1.r, temp.i = z__1.i;
8665
}
8666
i__3 = *m;
8667
for (k = i__ + 1; k <= i__3; ++k) {
8668
i__4 = k + i__ * a_dim1;
8669
i__5 = k + j * b_dim1;
8670
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
8671
b[i__5].i, z__2.i = a[i__4].r * b[
8672
i__5].i + a[i__4].i * b[i__5].r;
8673
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
8674
z__2.i;
8675
temp.r = z__1.r, temp.i = z__1.i;
8676
/* L130: */
8677
}
8678
} else {
8679
if (nounit) {
8680
d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
8681
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
8682
z__1.i = temp.r * z__2.i + temp.i *
8683
z__2.r;
8684
temp.r = z__1.r, temp.i = z__1.i;
8685
}
8686
i__3 = *m;
8687
for (k = i__ + 1; k <= i__3; ++k) {
8688
d_cnjg(&z__3, &a[k + i__ * a_dim1]);
8689
i__4 = k + j * b_dim1;
8690
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4]
8691
.i, z__2.i = z__3.r * b[i__4].i +
8692
z__3.i * b[i__4].r;
8693
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
8694
z__2.i;
8695
temp.r = z__1.r, temp.i = z__1.i;
8696
/* L140: */
8697
}
8698
}
8699
i__3 = i__ + j * b_dim1;
8700
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
8701
z__1.i = alpha->r * temp.i + alpha->i *
8702
temp.r;
8703
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8704
/* L150: */
8705
}
8706
/* L160: */
8707
}
8708
}
8709
}
8710
} else {
8711
if (lsame_(transa, "N")) {
8712
8713
/* Form B := alpha*B*A. */
8714
8715
if (upper) {
8716
for (j = *n; j >= 1; --j) {
8717
temp.r = alpha->r, temp.i = alpha->i;
8718
if (nounit) {
8719
i__1 = j + j * a_dim1;
8720
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
8721
z__1.i = temp.r * a[i__1].i + temp.i * a[i__1]
8722
.r;
8723
temp.r = z__1.r, temp.i = z__1.i;
8724
}
8725
i__1 = *m;
8726
for (i__ = 1; i__ <= i__1; ++i__) {
8727
i__2 = i__ + j * b_dim1;
8728
i__3 = i__ + j * b_dim1;
8729
z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
8730
z__1.i = temp.r * b[i__3].i + temp.i * b[i__3]
8731
.r;
8732
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
8733
/* L170: */
8734
}
8735
i__1 = j - 1;
8736
for (k = 1; k <= i__1; ++k) {
8737
i__2 = k + j * a_dim1;
8738
if (a[i__2].r != 0. || a[i__2].i != 0.) {
8739
i__2 = k + j * a_dim1;
8740
z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2]
8741
.i, z__1.i = alpha->r * a[i__2].i +
8742
alpha->i * a[i__2].r;
8743
temp.r = z__1.r, temp.i = z__1.i;
8744
i__2 = *m;
8745
for (i__ = 1; i__ <= i__2; ++i__) {
8746
i__3 = i__ + j * b_dim1;
8747
i__4 = i__ + j * b_dim1;
8748
i__5 = i__ + k * b_dim1;
8749
z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
8750
.i, z__2.i = temp.r * b[i__5].i +
8751
temp.i * b[i__5].r;
8752
z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
8753
.i + z__2.i;
8754
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8755
/* L180: */
8756
}
8757
}
8758
/* L190: */
8759
}
8760
/* L200: */
8761
}
8762
} else {
8763
i__1 = *n;
8764
for (j = 1; j <= i__1; ++j) {
8765
temp.r = alpha->r, temp.i = alpha->i;
8766
if (nounit) {
8767
i__2 = j + j * a_dim1;
8768
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
8769
z__1.i = temp.r * a[i__2].i + temp.i * a[i__2]
8770
.r;
8771
temp.r = z__1.r, temp.i = z__1.i;
8772
}
8773
i__2 = *m;
8774
for (i__ = 1; i__ <= i__2; ++i__) {
8775
i__3 = i__ + j * b_dim1;
8776
i__4 = i__ + j * b_dim1;
8777
z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
8778
z__1.i = temp.r * b[i__4].i + temp.i * b[i__4]
8779
.r;
8780
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8781
/* L210: */
8782
}
8783
i__2 = *n;
8784
for (k = j + 1; k <= i__2; ++k) {
8785
i__3 = k + j * a_dim1;
8786
if (a[i__3].r != 0. || a[i__3].i != 0.) {
8787
i__3 = k + j * a_dim1;
8788
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3]
8789
.i, z__1.i = alpha->r * a[i__3].i +
8790
alpha->i * a[i__3].r;
8791
temp.r = z__1.r, temp.i = z__1.i;
8792
i__3 = *m;
8793
for (i__ = 1; i__ <= i__3; ++i__) {
8794
i__4 = i__ + j * b_dim1;
8795
i__5 = i__ + j * b_dim1;
8796
i__6 = i__ + k * b_dim1;
8797
z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
8798
.i, z__2.i = temp.r * b[i__6].i +
8799
temp.i * b[i__6].r;
8800
z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
8801
.i + z__2.i;
8802
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
8803
/* L220: */
8804
}
8805
}
8806
/* L230: */
8807
}
8808
/* L240: */
8809
}
8810
}
8811
} else {
8812
8813
/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */
8814
8815
if (upper) {
8816
i__1 = *n;
8817
for (k = 1; k <= i__1; ++k) {
8818
i__2 = k - 1;
8819
for (j = 1; j <= i__2; ++j) {
8820
i__3 = j + k * a_dim1;
8821
if (a[i__3].r != 0. || a[i__3].i != 0.) {
8822
if (noconj) {
8823
i__3 = j + k * a_dim1;
8824
z__1.r = alpha->r * a[i__3].r - alpha->i * a[
8825
i__3].i, z__1.i = alpha->r * a[i__3]
8826
.i + alpha->i * a[i__3].r;
8827
temp.r = z__1.r, temp.i = z__1.i;
8828
} else {
8829
d_cnjg(&z__2, &a[j + k * a_dim1]);
8830
z__1.r = alpha->r * z__2.r - alpha->i *
8831
z__2.i, z__1.i = alpha->r * z__2.i +
8832
alpha->i * z__2.r;
8833
temp.r = z__1.r, temp.i = z__1.i;
8834
}
8835
i__3 = *m;
8836
for (i__ = 1; i__ <= i__3; ++i__) {
8837
i__4 = i__ + j * b_dim1;
8838
i__5 = i__ + j * b_dim1;
8839
i__6 = i__ + k * b_dim1;
8840
z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
8841
.i, z__2.i = temp.r * b[i__6].i +
8842
temp.i * b[i__6].r;
8843
z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
8844
.i + z__2.i;
8845
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
8846
/* L250: */
8847
}
8848
}
8849
/* L260: */
8850
}
8851
temp.r = alpha->r, temp.i = alpha->i;
8852
if (nounit) {
8853
if (noconj) {
8854
i__2 = k + k * a_dim1;
8855
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
8856
z__1.i = temp.r * a[i__2].i + temp.i * a[
8857
i__2].r;
8858
temp.r = z__1.r, temp.i = z__1.i;
8859
} else {
8860
d_cnjg(&z__2, &a[k + k * a_dim1]);
8861
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
8862
z__1.i = temp.r * z__2.i + temp.i *
8863
z__2.r;
8864
temp.r = z__1.r, temp.i = z__1.i;
8865
}
8866
}
8867
if (temp.r != 1. || temp.i != 0.) {
8868
i__2 = *m;
8869
for (i__ = 1; i__ <= i__2; ++i__) {
8870
i__3 = i__ + k * b_dim1;
8871
i__4 = i__ + k * b_dim1;
8872
z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
8873
z__1.i = temp.r * b[i__4].i + temp.i * b[
8874
i__4].r;
8875
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8876
/* L270: */
8877
}
8878
}
8879
/* L280: */
8880
}
8881
} else {
8882
for (k = *n; k >= 1; --k) {
8883
i__1 = *n;
8884
for (j = k + 1; j <= i__1; ++j) {
8885
i__2 = j + k * a_dim1;
8886
if (a[i__2].r != 0. || a[i__2].i != 0.) {
8887
if (noconj) {
8888
i__2 = j + k * a_dim1;
8889
z__1.r = alpha->r * a[i__2].r - alpha->i * a[
8890
i__2].i, z__1.i = alpha->r * a[i__2]
8891
.i + alpha->i * a[i__2].r;
8892
temp.r = z__1.r, temp.i = z__1.i;
8893
} else {
8894
d_cnjg(&z__2, &a[j + k * a_dim1]);
8895
z__1.r = alpha->r * z__2.r - alpha->i *
8896
z__2.i, z__1.i = alpha->r * z__2.i +
8897
alpha->i * z__2.r;
8898
temp.r = z__1.r, temp.i = z__1.i;
8899
}
8900
i__2 = *m;
8901
for (i__ = 1; i__ <= i__2; ++i__) {
8902
i__3 = i__ + j * b_dim1;
8903
i__4 = i__ + j * b_dim1;
8904
i__5 = i__ + k * b_dim1;
8905
z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
8906
.i, z__2.i = temp.r * b[i__5].i +
8907
temp.i * b[i__5].r;
8908
z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
8909
.i + z__2.i;
8910
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
8911
/* L290: */
8912
}
8913
}
8914
/* L300: */
8915
}
8916
temp.r = alpha->r, temp.i = alpha->i;
8917
if (nounit) {
8918
if (noconj) {
8919
i__1 = k + k * a_dim1;
8920
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
8921
z__1.i = temp.r * a[i__1].i + temp.i * a[
8922
i__1].r;
8923
temp.r = z__1.r, temp.i = z__1.i;
8924
} else {
8925
d_cnjg(&z__2, &a[k + k * a_dim1]);
8926
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
8927
z__1.i = temp.r * z__2.i + temp.i *
8928
z__2.r;
8929
temp.r = z__1.r, temp.i = z__1.i;
8930
}
8931
}
8932
if (temp.r != 1. || temp.i != 0.) {
8933
i__1 = *m;
8934
for (i__ = 1; i__ <= i__1; ++i__) {
8935
i__2 = i__ + k * b_dim1;
8936
i__3 = i__ + k * b_dim1;
8937
z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
8938
z__1.i = temp.r * b[i__3].i + temp.i * b[
8939
i__3].r;
8940
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
8941
/* L310: */
8942
}
8943
}
8944
/* L320: */
8945
}
8946
}
8947
}
8948
}
8949
8950
return 0;
8951
8952
/* End of ZTRMM . */
8953
8954
} /* ztrmm_ */
8955
8956
/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n,
8957
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
8958
{
8959
/* System generated locals */
8960
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
8961
doublecomplex z__1, z__2, z__3;
8962
8963
/* Builtin functions */
8964
void d_cnjg(doublecomplex *, doublecomplex *);
8965
8966
/* Local variables */
8967
static integer i__, j, ix, jx, kx, info;
8968
static doublecomplex temp;
8969
extern logical lsame_(char *, char *);
8970
extern /* Subroutine */ int xerbla_(char *, integer *);
8971
static logical noconj, nounit;
8972
8973
8974
/*
8975
Purpose
8976
=======
8977
8978
ZTRMV performs one of the matrix-vector operations
8979
8980
x := A*x, or x := A'*x, or x := conjg( A' )*x,
8981
8982
where x is an n element vector and A is an n by n unit, or non-unit,
8983
upper or lower triangular matrix.
8984
8985
Parameters
8986
==========
8987
8988
UPLO - CHARACTER*1.
8989
On entry, UPLO specifies whether the matrix is an upper or
8990
lower triangular matrix as follows:
8991
8992
UPLO = 'U' or 'u' A is an upper triangular matrix.
8993
8994
UPLO = 'L' or 'l' A is a lower triangular matrix.
8995
8996
Unchanged on exit.
8997
8998
TRANS - CHARACTER*1.
8999
On entry, TRANS specifies the operation to be performed as
9000
follows:
9001
9002
TRANS = 'N' or 'n' x := A*x.
9003
9004
TRANS = 'T' or 't' x := A'*x.
9005
9006
TRANS = 'C' or 'c' x := conjg( A' )*x.
9007
9008
Unchanged on exit.
9009
9010
DIAG - CHARACTER*1.
9011
On entry, DIAG specifies whether or not A is unit
9012
triangular as follows:
9013
9014
DIAG = 'U' or 'u' A is assumed to be unit triangular.
9015
9016
DIAG = 'N' or 'n' A is not assumed to be unit
9017
triangular.
9018
9019
Unchanged on exit.
9020
9021
N - INTEGER.
9022
On entry, N specifies the order of the matrix A.
9023
N must be at least zero.
9024
Unchanged on exit.
9025
9026
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
9027
Before entry with UPLO = 'U' or 'u', the leading n by n
9028
upper triangular part of the array A must contain the upper
9029
triangular matrix and the strictly lower triangular part of
9030
A is not referenced.
9031
Before entry with UPLO = 'L' or 'l', the leading n by n
9032
lower triangular part of the array A must contain the lower
9033
triangular matrix and the strictly upper triangular part of
9034
A is not referenced.
9035
Note that when DIAG = 'U' or 'u', the diagonal elements of
9036
A are not referenced either, but are assumed to be unity.
9037
Unchanged on exit.
9038
9039
LDA - INTEGER.
9040
On entry, LDA specifies the first dimension of A as declared
9041
in the calling (sub) program. LDA must be at least
9042
max( 1, n ).
9043
Unchanged on exit.
9044
9045
X - COMPLEX*16 array of dimension at least
9046
( 1 + ( n - 1 )*abs( INCX ) ).
9047
Before entry, the incremented array X must contain the n
9048
element vector x. On exit, X is overwritten with the
9049
tranformed vector x.
9050
9051
INCX - INTEGER.
9052
On entry, INCX specifies the increment for the elements of
9053
X. INCX must not be zero.
9054
Unchanged on exit.
9055
9056
9057
Level 2 Blas routine.
9058
9059
-- Written on 22-October-1986.
9060
Jack Dongarra, Argonne National Lab.
9061
Jeremy Du Croz, Nag Central Office.
9062
Sven Hammarling, Nag Central Office.
9063
Richard Hanson, Sandia National Labs.
9064
9065
9066
Test the input parameters.
9067
*/
9068
9069
/* Parameter adjustments */
9070
a_dim1 = *lda;
9071
a_offset = 1 + a_dim1 * 1;
9072
a -= a_offset;
9073
--x;
9074
9075
/* Function Body */
9076
info = 0;
9077
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
9078
info = 1;
9079
} else if (((! lsame_(trans, "N") && ! lsame_(trans,
9080
"T")) && ! lsame_(trans, "C"))) {
9081
info = 2;
9082
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
9083
"N"))) {
9084
info = 3;
9085
} else if (*n < 0) {
9086
info = 4;
9087
} else if (*lda < max(1,*n)) {
9088
info = 6;
9089
} else if (*incx == 0) {
9090
info = 8;
9091
}
9092
if (info != 0) {
9093
xerbla_("ZTRMV ", &info);
9094
return 0;
9095
}
9096
9097
/* Quick return if possible. */
9098
9099
if (*n == 0) {
9100
return 0;
9101
}
9102
9103
noconj = lsame_(trans, "T");
9104
nounit = lsame_(diag, "N");
9105
9106
/*
9107
Set up the start point in X if the increment is not unity. This
9108
will be ( N - 1 )*INCX too small for descending loops.
9109
*/
9110
9111
if (*incx <= 0) {
9112
kx = 1 - (*n - 1) * *incx;
9113
} else if (*incx != 1) {
9114
kx = 1;
9115
}
9116
9117
/*
9118
Start the operations. In this version the elements of A are
9119
accessed sequentially with one pass through A.
9120
*/
9121
9122
if (lsame_(trans, "N")) {
9123
9124
/* Form x := A*x. */
9125
9126
if (lsame_(uplo, "U")) {
9127
if (*incx == 1) {
9128
i__1 = *n;
9129
for (j = 1; j <= i__1; ++j) {
9130
i__2 = j;
9131
if (x[i__2].r != 0. || x[i__2].i != 0.) {
9132
i__2 = j;
9133
temp.r = x[i__2].r, temp.i = x[i__2].i;
9134
i__2 = j - 1;
9135
for (i__ = 1; i__ <= i__2; ++i__) {
9136
i__3 = i__;
9137
i__4 = i__;
9138
i__5 = i__ + j * a_dim1;
9139
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
9140
z__2.i = temp.r * a[i__5].i + temp.i * a[
9141
i__5].r;
9142
z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
9143
z__2.i;
9144
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
9145
/* L10: */
9146
}
9147
if (nounit) {
9148
i__2 = j;
9149
i__3 = j;
9150
i__4 = j + j * a_dim1;
9151
z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
9152
i__4].i, z__1.i = x[i__3].r * a[i__4].i +
9153
x[i__3].i * a[i__4].r;
9154
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
9155
}
9156
}
9157
/* L20: */
9158
}
9159
} else {
9160
jx = kx;
9161
i__1 = *n;
9162
for (j = 1; j <= i__1; ++j) {
9163
i__2 = jx;
9164
if (x[i__2].r != 0. || x[i__2].i != 0.) {
9165
i__2 = jx;
9166
temp.r = x[i__2].r, temp.i = x[i__2].i;
9167
ix = kx;
9168
i__2 = j - 1;
9169
for (i__ = 1; i__ <= i__2; ++i__) {
9170
i__3 = ix;
9171
i__4 = ix;
9172
i__5 = i__ + j * a_dim1;
9173
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
9174
z__2.i = temp.r * a[i__5].i + temp.i * a[
9175
i__5].r;
9176
z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
9177
z__2.i;
9178
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
9179
ix += *incx;
9180
/* L30: */
9181
}
9182
if (nounit) {
9183
i__2 = jx;
9184
i__3 = jx;
9185
i__4 = j + j * a_dim1;
9186
z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
9187
i__4].i, z__1.i = x[i__3].r * a[i__4].i +
9188
x[i__3].i * a[i__4].r;
9189
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
9190
}
9191
}
9192
jx += *incx;
9193
/* L40: */
9194
}
9195
}
9196
} else {
9197
if (*incx == 1) {
9198
for (j = *n; j >= 1; --j) {
9199
i__1 = j;
9200
if (x[i__1].r != 0. || x[i__1].i != 0.) {
9201
i__1 = j;
9202
temp.r = x[i__1].r, temp.i = x[i__1].i;
9203
i__1 = j + 1;
9204
for (i__ = *n; i__ >= i__1; --i__) {
9205
i__2 = i__;
9206
i__3 = i__;
9207
i__4 = i__ + j * a_dim1;
9208
z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
9209
z__2.i = temp.r * a[i__4].i + temp.i * a[
9210
i__4].r;
9211
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
9212
z__2.i;
9213
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
9214
/* L50: */
9215
}
9216
if (nounit) {
9217
i__1 = j;
9218
i__2 = j;
9219
i__3 = j + j * a_dim1;
9220
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
9221
i__3].i, z__1.i = x[i__2].r * a[i__3].i +
9222
x[i__2].i * a[i__3].r;
9223
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
9224
}
9225
}
9226
/* L60: */
9227
}
9228
} else {
9229
kx += (*n - 1) * *incx;
9230
jx = kx;
9231
for (j = *n; j >= 1; --j) {
9232
i__1 = jx;
9233
if (x[i__1].r != 0. || x[i__1].i != 0.) {
9234
i__1 = jx;
9235
temp.r = x[i__1].r, temp.i = x[i__1].i;
9236
ix = kx;
9237
i__1 = j + 1;
9238
for (i__ = *n; i__ >= i__1; --i__) {
9239
i__2 = ix;
9240
i__3 = ix;
9241
i__4 = i__ + j * a_dim1;
9242
z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
9243
z__2.i = temp.r * a[i__4].i + temp.i * a[
9244
i__4].r;
9245
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
9246
z__2.i;
9247
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
9248
ix -= *incx;
9249
/* L70: */
9250
}
9251
if (nounit) {
9252
i__1 = jx;
9253
i__2 = jx;
9254
i__3 = j + j * a_dim1;
9255
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
9256
i__3].i, z__1.i = x[i__2].r * a[i__3].i +
9257
x[i__2].i * a[i__3].r;
9258
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
9259
}
9260
}
9261
jx -= *incx;
9262
/* L80: */
9263
}
9264
}
9265
}
9266
} else {
9267
9268
/* Form x := A'*x or x := conjg( A' )*x. */
9269
9270
if (lsame_(uplo, "U")) {
9271
if (*incx == 1) {
9272
for (j = *n; j >= 1; --j) {
9273
i__1 = j;
9274
temp.r = x[i__1].r, temp.i = x[i__1].i;
9275
if (noconj) {
9276
if (nounit) {
9277
i__1 = j + j * a_dim1;
9278
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
9279
z__1.i = temp.r * a[i__1].i + temp.i * a[
9280
i__1].r;
9281
temp.r = z__1.r, temp.i = z__1.i;
9282
}
9283
for (i__ = j - 1; i__ >= 1; --i__) {
9284
i__1 = i__ + j * a_dim1;
9285
i__2 = i__;
9286
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
9287
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
9288
a[i__1].i * x[i__2].r;
9289
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9290
z__2.i;
9291
temp.r = z__1.r, temp.i = z__1.i;
9292
/* L90: */
9293
}
9294
} else {
9295
if (nounit) {
9296
d_cnjg(&z__2, &a[j + j * a_dim1]);
9297
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
9298
z__1.i = temp.r * z__2.i + temp.i *
9299
z__2.r;
9300
temp.r = z__1.r, temp.i = z__1.i;
9301
}
9302
for (i__ = j - 1; i__ >= 1; --i__) {
9303
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
9304
i__1 = i__;
9305
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
9306
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
9307
i__1].r;
9308
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9309
z__2.i;
9310
temp.r = z__1.r, temp.i = z__1.i;
9311
/* L100: */
9312
}
9313
}
9314
i__1 = j;
9315
x[i__1].r = temp.r, x[i__1].i = temp.i;
9316
/* L110: */
9317
}
9318
} else {
9319
jx = kx + (*n - 1) * *incx;
9320
for (j = *n; j >= 1; --j) {
9321
i__1 = jx;
9322
temp.r = x[i__1].r, temp.i = x[i__1].i;
9323
ix = jx;
9324
if (noconj) {
9325
if (nounit) {
9326
i__1 = j + j * a_dim1;
9327
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
9328
z__1.i = temp.r * a[i__1].i + temp.i * a[
9329
i__1].r;
9330
temp.r = z__1.r, temp.i = z__1.i;
9331
}
9332
for (i__ = j - 1; i__ >= 1; --i__) {
9333
ix -= *incx;
9334
i__1 = i__ + j * a_dim1;
9335
i__2 = ix;
9336
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
9337
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
9338
a[i__1].i * x[i__2].r;
9339
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9340
z__2.i;
9341
temp.r = z__1.r, temp.i = z__1.i;
9342
/* L120: */
9343
}
9344
} else {
9345
if (nounit) {
9346
d_cnjg(&z__2, &a[j + j * a_dim1]);
9347
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
9348
z__1.i = temp.r * z__2.i + temp.i *
9349
z__2.r;
9350
temp.r = z__1.r, temp.i = z__1.i;
9351
}
9352
for (i__ = j - 1; i__ >= 1; --i__) {
9353
ix -= *incx;
9354
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
9355
i__1 = ix;
9356
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
9357
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
9358
i__1].r;
9359
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9360
z__2.i;
9361
temp.r = z__1.r, temp.i = z__1.i;
9362
/* L130: */
9363
}
9364
}
9365
i__1 = jx;
9366
x[i__1].r = temp.r, x[i__1].i = temp.i;
9367
jx -= *incx;
9368
/* L140: */
9369
}
9370
}
9371
} else {
9372
if (*incx == 1) {
9373
i__1 = *n;
9374
for (j = 1; j <= i__1; ++j) {
9375
i__2 = j;
9376
temp.r = x[i__2].r, temp.i = x[i__2].i;
9377
if (noconj) {
9378
if (nounit) {
9379
i__2 = j + j * a_dim1;
9380
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
9381
z__1.i = temp.r * a[i__2].i + temp.i * a[
9382
i__2].r;
9383
temp.r = z__1.r, temp.i = z__1.i;
9384
}
9385
i__2 = *n;
9386
for (i__ = j + 1; i__ <= i__2; ++i__) {
9387
i__3 = i__ + j * a_dim1;
9388
i__4 = i__;
9389
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
9390
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
9391
a[i__3].i * x[i__4].r;
9392
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9393
z__2.i;
9394
temp.r = z__1.r, temp.i = z__1.i;
9395
/* L150: */
9396
}
9397
} else {
9398
if (nounit) {
9399
d_cnjg(&z__2, &a[j + j * a_dim1]);
9400
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
9401
z__1.i = temp.r * z__2.i + temp.i *
9402
z__2.r;
9403
temp.r = z__1.r, temp.i = z__1.i;
9404
}
9405
i__2 = *n;
9406
for (i__ = j + 1; i__ <= i__2; ++i__) {
9407
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
9408
i__3 = i__;
9409
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
9410
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
9411
i__3].r;
9412
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9413
z__2.i;
9414
temp.r = z__1.r, temp.i = z__1.i;
9415
/* L160: */
9416
}
9417
}
9418
i__2 = j;
9419
x[i__2].r = temp.r, x[i__2].i = temp.i;
9420
/* L170: */
9421
}
9422
} else {
9423
jx = kx;
9424
i__1 = *n;
9425
for (j = 1; j <= i__1; ++j) {
9426
i__2 = jx;
9427
temp.r = x[i__2].r, temp.i = x[i__2].i;
9428
ix = jx;
9429
if (noconj) {
9430
if (nounit) {
9431
i__2 = j + j * a_dim1;
9432
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
9433
z__1.i = temp.r * a[i__2].i + temp.i * a[
9434
i__2].r;
9435
temp.r = z__1.r, temp.i = z__1.i;
9436
}
9437
i__2 = *n;
9438
for (i__ = j + 1; i__ <= i__2; ++i__) {
9439
ix += *incx;
9440
i__3 = i__ + j * a_dim1;
9441
i__4 = ix;
9442
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
9443
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
9444
a[i__3].i * x[i__4].r;
9445
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9446
z__2.i;
9447
temp.r = z__1.r, temp.i = z__1.i;
9448
/* L180: */
9449
}
9450
} else {
9451
if (nounit) {
9452
d_cnjg(&z__2, &a[j + j * a_dim1]);
9453
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
9454
z__1.i = temp.r * z__2.i + temp.i *
9455
z__2.r;
9456
temp.r = z__1.r, temp.i = z__1.i;
9457
}
9458
i__2 = *n;
9459
for (i__ = j + 1; i__ <= i__2; ++i__) {
9460
ix += *incx;
9461
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
9462
i__3 = ix;
9463
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
9464
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
9465
i__3].r;
9466
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
9467
z__2.i;
9468
temp.r = z__1.r, temp.i = z__1.i;
9469
/* L190: */
9470
}
9471
}
9472
i__2 = jx;
9473
x[i__2].r = temp.r, x[i__2].i = temp.i;
9474
jx += *incx;
9475
/* L200: */
9476
}
9477
}
9478
}
9479
}
9480
9481
return 0;
9482
9483
/* End of ZTRMV . */
9484
9485
} /* ztrmv_ */
9486
9487
/* Subroutine */ int ztrsm_(char *side, char *uplo, char *transa, char *diag,
9488
integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
9489
integer *lda, doublecomplex *b, integer *ldb)
9490
{
9491
/* System generated locals */
9492
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
9493
i__6, i__7;
9494
doublecomplex z__1, z__2, z__3;
9495
9496
/* Builtin functions */
9497
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
9498
doublecomplex *, doublecomplex *);
9499
9500
/* Local variables */
9501
static integer i__, j, k, info;
9502
static doublecomplex temp;
9503
static logical lside;
9504
extern logical lsame_(char *, char *);
9505
static integer nrowa;
9506
static logical upper;
9507
extern /* Subroutine */ int xerbla_(char *, integer *);
9508
static logical noconj, nounit;
9509
9510
9511
/*
9512
Purpose
9513
=======
9514
9515
ZTRSM solves one of the matrix equations
9516
9517
op( A )*X = alpha*B, or X*op( A ) = alpha*B,
9518
9519
where alpha is a scalar, X and B are m by n matrices, A is a unit, or
9520
non-unit, upper or lower triangular matrix and op( A ) is one of
9521
9522
op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
9523
9524
The matrix X is overwritten on B.
9525
9526
Parameters
9527
==========
9528
9529
SIDE - CHARACTER*1.
9530
On entry, SIDE specifies whether op( A ) appears on the left
9531
or right of X as follows:
9532
9533
SIDE = 'L' or 'l' op( A )*X = alpha*B.
9534
9535
SIDE = 'R' or 'r' X*op( A ) = alpha*B.
9536
9537
Unchanged on exit.
9538
9539
UPLO - CHARACTER*1.
9540
On entry, UPLO specifies whether the matrix A is an upper or
9541
lower triangular matrix as follows:
9542
9543
UPLO = 'U' or 'u' A is an upper triangular matrix.
9544
9545
UPLO = 'L' or 'l' A is a lower triangular matrix.
9546
9547
Unchanged on exit.
9548
9549
TRANSA - CHARACTER*1.
9550
On entry, TRANSA specifies the form of op( A ) to be used in
9551
the matrix multiplication as follows:
9552
9553
TRANSA = 'N' or 'n' op( A ) = A.
9554
9555
TRANSA = 'T' or 't' op( A ) = A'.
9556
9557
TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
9558
9559
Unchanged on exit.
9560
9561
DIAG - CHARACTER*1.
9562
On entry, DIAG specifies whether or not A is unit triangular
9563
as follows:
9564
9565
DIAG = 'U' or 'u' A is assumed to be unit triangular.
9566
9567
DIAG = 'N' or 'n' A is not assumed to be unit
9568
triangular.
9569
9570
Unchanged on exit.
9571
9572
M - INTEGER.
9573
On entry, M specifies the number of rows of B. M must be at
9574
least zero.
9575
Unchanged on exit.
9576
9577
N - INTEGER.
9578
On entry, N specifies the number of columns of B. N must be
9579
at least zero.
9580
Unchanged on exit.
9581
9582
ALPHA - COMPLEX*16 .
9583
On entry, ALPHA specifies the scalar alpha. When alpha is
9584
zero then A is not referenced and B need not be set before
9585
entry.
9586
Unchanged on exit.
9587
9588
A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m
9589
when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
9590
Before entry with UPLO = 'U' or 'u', the leading k by k
9591
upper triangular part of the array A must contain the upper
9592
triangular matrix and the strictly lower triangular part of
9593
A is not referenced.
9594
Before entry with UPLO = 'L' or 'l', the leading k by k
9595
lower triangular part of the array A must contain the lower
9596
triangular matrix and the strictly upper triangular part of
9597
A is not referenced.
9598
Note that when DIAG = 'U' or 'u', the diagonal elements of
9599
A are not referenced either, but are assumed to be unity.
9600
Unchanged on exit.
9601
9602
LDA - INTEGER.
9603
On entry, LDA specifies the first dimension of A as declared
9604
in the calling (sub) program. When SIDE = 'L' or 'l' then
9605
LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
9606
then LDA must be at least max( 1, n ).
9607
Unchanged on exit.
9608
9609
B - COMPLEX*16 array of DIMENSION ( LDB, n ).
9610
Before entry, the leading m by n part of the array B must
9611
contain the right-hand side matrix B, and on exit is
9612
overwritten by the solution matrix X.
9613
9614
LDB - INTEGER.
9615
On entry, LDB specifies the first dimension of B as declared
9616
in the calling (sub) program. LDB must be at least
9617
max( 1, m ).
9618
Unchanged on exit.
9619
9620
9621
Level 3 Blas routine.
9622
9623
-- Written on 8-February-1989.
9624
Jack Dongarra, Argonne National Laboratory.
9625
Iain Duff, AERE Harwell.
9626
Jeremy Du Croz, Numerical Algorithms Group Ltd.
9627
Sven Hammarling, Numerical Algorithms Group Ltd.
9628
9629
9630
Test the input parameters.
9631
*/
9632
9633
/* Parameter adjustments */
9634
a_dim1 = *lda;
9635
a_offset = 1 + a_dim1 * 1;
9636
a -= a_offset;
9637
b_dim1 = *ldb;
9638
b_offset = 1 + b_dim1 * 1;
9639
b -= b_offset;
9640
9641
/* Function Body */
9642
lside = lsame_(side, "L");
9643
if (lside) {
9644
nrowa = *m;
9645
} else {
9646
nrowa = *n;
9647
}
9648
noconj = lsame_(transa, "T");
9649
nounit = lsame_(diag, "N");
9650
upper = lsame_(uplo, "U");
9651
9652
info = 0;
9653
if ((! lside && ! lsame_(side, "R"))) {
9654
info = 1;
9655
} else if ((! upper && ! lsame_(uplo, "L"))) {
9656
info = 2;
9657
} else if (((! lsame_(transa, "N") && ! lsame_(
9658
transa, "T")) && ! lsame_(transa, "C"))) {
9659
info = 3;
9660
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
9661
"N"))) {
9662
info = 4;
9663
} else if (*m < 0) {
9664
info = 5;
9665
} else if (*n < 0) {
9666
info = 6;
9667
} else if (*lda < max(1,nrowa)) {
9668
info = 9;
9669
} else if (*ldb < max(1,*m)) {
9670
info = 11;
9671
}
9672
if (info != 0) {
9673
xerbla_("ZTRSM ", &info);
9674
return 0;
9675
}
9676
9677
/* Quick return if possible. */
9678
9679
if (*n == 0) {
9680
return 0;
9681
}
9682
9683
/* And when alpha.eq.zero. */
9684
9685
if ((alpha->r == 0. && alpha->i == 0.)) {
9686
i__1 = *n;
9687
for (j = 1; j <= i__1; ++j) {
9688
i__2 = *m;
9689
for (i__ = 1; i__ <= i__2; ++i__) {
9690
i__3 = i__ + j * b_dim1;
9691
b[i__3].r = 0., b[i__3].i = 0.;
9692
/* L10: */
9693
}
9694
/* L20: */
9695
}
9696
return 0;
9697
}
9698
9699
/* Start the operations. */
9700
9701
if (lside) {
9702
if (lsame_(transa, "N")) {
9703
9704
/* Form B := alpha*inv( A )*B. */
9705
9706
if (upper) {
9707
i__1 = *n;
9708
for (j = 1; j <= i__1; ++j) {
9709
if (alpha->r != 1. || alpha->i != 0.) {
9710
i__2 = *m;
9711
for (i__ = 1; i__ <= i__2; ++i__) {
9712
i__3 = i__ + j * b_dim1;
9713
i__4 = i__ + j * b_dim1;
9714
z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
9715
.i, z__1.i = alpha->r * b[i__4].i +
9716
alpha->i * b[i__4].r;
9717
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9718
/* L30: */
9719
}
9720
}
9721
for (k = *m; k >= 1; --k) {
9722
i__2 = k + j * b_dim1;
9723
if (b[i__2].r != 0. || b[i__2].i != 0.) {
9724
if (nounit) {
9725
i__2 = k + j * b_dim1;
9726
z_div(&z__1, &b[k + j * b_dim1], &a[k + k *
9727
a_dim1]);
9728
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
9729
}
9730
i__2 = k - 1;
9731
for (i__ = 1; i__ <= i__2; ++i__) {
9732
i__3 = i__ + j * b_dim1;
9733
i__4 = i__ + j * b_dim1;
9734
i__5 = k + j * b_dim1;
9735
i__6 = i__ + k * a_dim1;
9736
z__2.r = b[i__5].r * a[i__6].r - b[i__5].i *
9737
a[i__6].i, z__2.i = b[i__5].r * a[
9738
i__6].i + b[i__5].i * a[i__6].r;
9739
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
9740
.i - z__2.i;
9741
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9742
/* L40: */
9743
}
9744
}
9745
/* L50: */
9746
}
9747
/* L60: */
9748
}
9749
} else {
9750
i__1 = *n;
9751
for (j = 1; j <= i__1; ++j) {
9752
if (alpha->r != 1. || alpha->i != 0.) {
9753
i__2 = *m;
9754
for (i__ = 1; i__ <= i__2; ++i__) {
9755
i__3 = i__ + j * b_dim1;
9756
i__4 = i__ + j * b_dim1;
9757
z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
9758
.i, z__1.i = alpha->r * b[i__4].i +
9759
alpha->i * b[i__4].r;
9760
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9761
/* L70: */
9762
}
9763
}
9764
i__2 = *m;
9765
for (k = 1; k <= i__2; ++k) {
9766
i__3 = k + j * b_dim1;
9767
if (b[i__3].r != 0. || b[i__3].i != 0.) {
9768
if (nounit) {
9769
i__3 = k + j * b_dim1;
9770
z_div(&z__1, &b[k + j * b_dim1], &a[k + k *
9771
a_dim1]);
9772
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9773
}
9774
i__3 = *m;
9775
for (i__ = k + 1; i__ <= i__3; ++i__) {
9776
i__4 = i__ + j * b_dim1;
9777
i__5 = i__ + j * b_dim1;
9778
i__6 = k + j * b_dim1;
9779
i__7 = i__ + k * a_dim1;
9780
z__2.r = b[i__6].r * a[i__7].r - b[i__6].i *
9781
a[i__7].i, z__2.i = b[i__6].r * a[
9782
i__7].i + b[i__6].i * a[i__7].r;
9783
z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
9784
.i - z__2.i;
9785
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
9786
/* L80: */
9787
}
9788
}
9789
/* L90: */
9790
}
9791
/* L100: */
9792
}
9793
}
9794
} else {
9795
9796
/*
9797
Form B := alpha*inv( A' )*B
9798
or B := alpha*inv( conjg( A' ) )*B.
9799
*/
9800
9801
if (upper) {
9802
i__1 = *n;
9803
for (j = 1; j <= i__1; ++j) {
9804
i__2 = *m;
9805
for (i__ = 1; i__ <= i__2; ++i__) {
9806
i__3 = i__ + j * b_dim1;
9807
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
9808
z__1.i = alpha->r * b[i__3].i + alpha->i * b[
9809
i__3].r;
9810
temp.r = z__1.r, temp.i = z__1.i;
9811
if (noconj) {
9812
i__3 = i__ - 1;
9813
for (k = 1; k <= i__3; ++k) {
9814
i__4 = k + i__ * a_dim1;
9815
i__5 = k + j * b_dim1;
9816
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
9817
b[i__5].i, z__2.i = a[i__4].r * b[
9818
i__5].i + a[i__4].i * b[i__5].r;
9819
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
9820
z__2.i;
9821
temp.r = z__1.r, temp.i = z__1.i;
9822
/* L110: */
9823
}
9824
if (nounit) {
9825
z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]);
9826
temp.r = z__1.r, temp.i = z__1.i;
9827
}
9828
} else {
9829
i__3 = i__ - 1;
9830
for (k = 1; k <= i__3; ++k) {
9831
d_cnjg(&z__3, &a[k + i__ * a_dim1]);
9832
i__4 = k + j * b_dim1;
9833
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4]
9834
.i, z__2.i = z__3.r * b[i__4].i +
9835
z__3.i * b[i__4].r;
9836
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
9837
z__2.i;
9838
temp.r = z__1.r, temp.i = z__1.i;
9839
/* L120: */
9840
}
9841
if (nounit) {
9842
d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
9843
z_div(&z__1, &temp, &z__2);
9844
temp.r = z__1.r, temp.i = z__1.i;
9845
}
9846
}
9847
i__3 = i__ + j * b_dim1;
9848
b[i__3].r = temp.r, b[i__3].i = temp.i;
9849
/* L130: */
9850
}
9851
/* L140: */
9852
}
9853
} else {
9854
i__1 = *n;
9855
for (j = 1; j <= i__1; ++j) {
9856
for (i__ = *m; i__ >= 1; --i__) {
9857
i__2 = i__ + j * b_dim1;
9858
z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
9859
z__1.i = alpha->r * b[i__2].i + alpha->i * b[
9860
i__2].r;
9861
temp.r = z__1.r, temp.i = z__1.i;
9862
if (noconj) {
9863
i__2 = *m;
9864
for (k = i__ + 1; k <= i__2; ++k) {
9865
i__3 = k + i__ * a_dim1;
9866
i__4 = k + j * b_dim1;
9867
z__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
9868
b[i__4].i, z__2.i = a[i__3].r * b[
9869
i__4].i + a[i__3].i * b[i__4].r;
9870
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
9871
z__2.i;
9872
temp.r = z__1.r, temp.i = z__1.i;
9873
/* L150: */
9874
}
9875
if (nounit) {
9876
z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]);
9877
temp.r = z__1.r, temp.i = z__1.i;
9878
}
9879
} else {
9880
i__2 = *m;
9881
for (k = i__ + 1; k <= i__2; ++k) {
9882
d_cnjg(&z__3, &a[k + i__ * a_dim1]);
9883
i__3 = k + j * b_dim1;
9884
z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3]
9885
.i, z__2.i = z__3.r * b[i__3].i +
9886
z__3.i * b[i__3].r;
9887
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
9888
z__2.i;
9889
temp.r = z__1.r, temp.i = z__1.i;
9890
/* L160: */
9891
}
9892
if (nounit) {
9893
d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
9894
z_div(&z__1, &temp, &z__2);
9895
temp.r = z__1.r, temp.i = z__1.i;
9896
}
9897
}
9898
i__2 = i__ + j * b_dim1;
9899
b[i__2].r = temp.r, b[i__2].i = temp.i;
9900
/* L170: */
9901
}
9902
/* L180: */
9903
}
9904
}
9905
}
9906
} else {
9907
if (lsame_(transa, "N")) {
9908
9909
/* Form B := alpha*B*inv( A ). */
9910
9911
if (upper) {
9912
i__1 = *n;
9913
for (j = 1; j <= i__1; ++j) {
9914
if (alpha->r != 1. || alpha->i != 0.) {
9915
i__2 = *m;
9916
for (i__ = 1; i__ <= i__2; ++i__) {
9917
i__3 = i__ + j * b_dim1;
9918
i__4 = i__ + j * b_dim1;
9919
z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
9920
.i, z__1.i = alpha->r * b[i__4].i +
9921
alpha->i * b[i__4].r;
9922
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9923
/* L190: */
9924
}
9925
}
9926
i__2 = j - 1;
9927
for (k = 1; k <= i__2; ++k) {
9928
i__3 = k + j * a_dim1;
9929
if (a[i__3].r != 0. || a[i__3].i != 0.) {
9930
i__3 = *m;
9931
for (i__ = 1; i__ <= i__3; ++i__) {
9932
i__4 = i__ + j * b_dim1;
9933
i__5 = i__ + j * b_dim1;
9934
i__6 = k + j * a_dim1;
9935
i__7 = i__ + k * b_dim1;
9936
z__2.r = a[i__6].r * b[i__7].r - a[i__6].i *
9937
b[i__7].i, z__2.i = a[i__6].r * b[
9938
i__7].i + a[i__6].i * b[i__7].r;
9939
z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
9940
.i - z__2.i;
9941
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
9942
/* L200: */
9943
}
9944
}
9945
/* L210: */
9946
}
9947
if (nounit) {
9948
z_div(&z__1, &c_b359, &a[j + j * a_dim1]);
9949
temp.r = z__1.r, temp.i = z__1.i;
9950
i__2 = *m;
9951
for (i__ = 1; i__ <= i__2; ++i__) {
9952
i__3 = i__ + j * b_dim1;
9953
i__4 = i__ + j * b_dim1;
9954
z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
9955
z__1.i = temp.r * b[i__4].i + temp.i * b[
9956
i__4].r;
9957
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9958
/* L220: */
9959
}
9960
}
9961
/* L230: */
9962
}
9963
} else {
9964
for (j = *n; j >= 1; --j) {
9965
if (alpha->r != 1. || alpha->i != 0.) {
9966
i__1 = *m;
9967
for (i__ = 1; i__ <= i__1; ++i__) {
9968
i__2 = i__ + j * b_dim1;
9969
i__3 = i__ + j * b_dim1;
9970
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
9971
.i, z__1.i = alpha->r * b[i__3].i +
9972
alpha->i * b[i__3].r;
9973
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
9974
/* L240: */
9975
}
9976
}
9977
i__1 = *n;
9978
for (k = j + 1; k <= i__1; ++k) {
9979
i__2 = k + j * a_dim1;
9980
if (a[i__2].r != 0. || a[i__2].i != 0.) {
9981
i__2 = *m;
9982
for (i__ = 1; i__ <= i__2; ++i__) {
9983
i__3 = i__ + j * b_dim1;
9984
i__4 = i__ + j * b_dim1;
9985
i__5 = k + j * a_dim1;
9986
i__6 = i__ + k * b_dim1;
9987
z__2.r = a[i__5].r * b[i__6].r - a[i__5].i *
9988
b[i__6].i, z__2.i = a[i__5].r * b[
9989
i__6].i + a[i__5].i * b[i__6].r;
9990
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
9991
.i - z__2.i;
9992
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
9993
/* L250: */
9994
}
9995
}
9996
/* L260: */
9997
}
9998
if (nounit) {
9999
z_div(&z__1, &c_b359, &a[j + j * a_dim1]);
10000
temp.r = z__1.r, temp.i = z__1.i;
10001
i__1 = *m;
10002
for (i__ = 1; i__ <= i__1; ++i__) {
10003
i__2 = i__ + j * b_dim1;
10004
i__3 = i__ + j * b_dim1;
10005
z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
10006
z__1.i = temp.r * b[i__3].i + temp.i * b[
10007
i__3].r;
10008
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
10009
/* L270: */
10010
}
10011
}
10012
/* L280: */
10013
}
10014
}
10015
} else {
10016
10017
/*
10018
Form B := alpha*B*inv( A' )
10019
or B := alpha*B*inv( conjg( A' ) ).
10020
*/
10021
10022
if (upper) {
10023
for (k = *n; k >= 1; --k) {
10024
if (nounit) {
10025
if (noconj) {
10026
z_div(&z__1, &c_b359, &a[k + k * a_dim1]);
10027
temp.r = z__1.r, temp.i = z__1.i;
10028
} else {
10029
d_cnjg(&z__2, &a[k + k * a_dim1]);
10030
z_div(&z__1, &c_b359, &z__2);
10031
temp.r = z__1.r, temp.i = z__1.i;
10032
}
10033
i__1 = *m;
10034
for (i__ = 1; i__ <= i__1; ++i__) {
10035
i__2 = i__ + k * b_dim1;
10036
i__3 = i__ + k * b_dim1;
10037
z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
10038
z__1.i = temp.r * b[i__3].i + temp.i * b[
10039
i__3].r;
10040
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
10041
/* L290: */
10042
}
10043
}
10044
i__1 = k - 1;
10045
for (j = 1; j <= i__1; ++j) {
10046
i__2 = j + k * a_dim1;
10047
if (a[i__2].r != 0. || a[i__2].i != 0.) {
10048
if (noconj) {
10049
i__2 = j + k * a_dim1;
10050
temp.r = a[i__2].r, temp.i = a[i__2].i;
10051
} else {
10052
d_cnjg(&z__1, &a[j + k * a_dim1]);
10053
temp.r = z__1.r, temp.i = z__1.i;
10054
}
10055
i__2 = *m;
10056
for (i__ = 1; i__ <= i__2; ++i__) {
10057
i__3 = i__ + j * b_dim1;
10058
i__4 = i__ + j * b_dim1;
10059
i__5 = i__ + k * b_dim1;
10060
z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
10061
.i, z__2.i = temp.r * b[i__5].i +
10062
temp.i * b[i__5].r;
10063
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
10064
.i - z__2.i;
10065
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
10066
/* L300: */
10067
}
10068
}
10069
/* L310: */
10070
}
10071
if (alpha->r != 1. || alpha->i != 0.) {
10072
i__1 = *m;
10073
for (i__ = 1; i__ <= i__1; ++i__) {
10074
i__2 = i__ + k * b_dim1;
10075
i__3 = i__ + k * b_dim1;
10076
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
10077
.i, z__1.i = alpha->r * b[i__3].i +
10078
alpha->i * b[i__3].r;
10079
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
10080
/* L320: */
10081
}
10082
}
10083
/* L330: */
10084
}
10085
} else {
10086
i__1 = *n;
10087
for (k = 1; k <= i__1; ++k) {
10088
if (nounit) {
10089
if (noconj) {
10090
z_div(&z__1, &c_b359, &a[k + k * a_dim1]);
10091
temp.r = z__1.r, temp.i = z__1.i;
10092
} else {
10093
d_cnjg(&z__2, &a[k + k * a_dim1]);
10094
z_div(&z__1, &c_b359, &z__2);
10095
temp.r = z__1.r, temp.i = z__1.i;
10096
}
10097
i__2 = *m;
10098
for (i__ = 1; i__ <= i__2; ++i__) {
10099
i__3 = i__ + k * b_dim1;
10100
i__4 = i__ + k * b_dim1;
10101
z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
10102
z__1.i = temp.r * b[i__4].i + temp.i * b[
10103
i__4].r;
10104
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
10105
/* L340: */
10106
}
10107
}
10108
i__2 = *n;
10109
for (j = k + 1; j <= i__2; ++j) {
10110
i__3 = j + k * a_dim1;
10111
if (a[i__3].r != 0. || a[i__3].i != 0.) {
10112
if (noconj) {
10113
i__3 = j + k * a_dim1;
10114
temp.r = a[i__3].r, temp.i = a[i__3].i;
10115
} else {
10116
d_cnjg(&z__1, &a[j + k * a_dim1]);
10117
temp.r = z__1.r, temp.i = z__1.i;
10118
}
10119
i__3 = *m;
10120
for (i__ = 1; i__ <= i__3; ++i__) {
10121
i__4 = i__ + j * b_dim1;
10122
i__5 = i__ + j * b_dim1;
10123
i__6 = i__ + k * b_dim1;
10124
z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
10125
.i, z__2.i = temp.r * b[i__6].i +
10126
temp.i * b[i__6].r;
10127
z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
10128
.i - z__2.i;
10129
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
10130
/* L350: */
10131
}
10132
}
10133
/* L360: */
10134
}
10135
if (alpha->r != 1. || alpha->i != 0.) {
10136
i__2 = *m;
10137
for (i__ = 1; i__ <= i__2; ++i__) {
10138
i__3 = i__ + k * b_dim1;
10139
i__4 = i__ + k * b_dim1;
10140
z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
10141
.i, z__1.i = alpha->r * b[i__4].i +
10142
alpha->i * b[i__4].r;
10143
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
10144
/* L370: */
10145
}
10146
}
10147
/* L380: */
10148
}
10149
}
10150
}
10151
}
10152
10153
return 0;
10154
10155
/* End of ZTRSM . */
10156
10157
} /* ztrsm_ */
10158
10159
/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n,
10160
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
10161
{
10162
/* System generated locals */
10163
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
10164
doublecomplex z__1, z__2, z__3;
10165
10166
/* Builtin functions */
10167
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
10168
doublecomplex *, doublecomplex *);
10169
10170
/* Local variables */
10171
static integer i__, j, ix, jx, kx, info;
10172
static doublecomplex temp;
10173
extern logical lsame_(char *, char *);
10174
extern /* Subroutine */ int xerbla_(char *, integer *);
10175
static logical noconj, nounit;
10176
10177
10178
/*
10179
Purpose
10180
=======
10181
10182
ZTRSV solves one of the systems of equations
10183
10184
A*x = b, or A'*x = b, or conjg( A' )*x = b,
10185
10186
where b and x are n element vectors and A is an n by n unit, or
10187
non-unit, upper or lower triangular matrix.
10188
10189
No test for singularity or near-singularity is included in this
10190
routine. Such tests must be performed before calling this routine.
10191
10192
Parameters
10193
==========
10194
10195
UPLO - CHARACTER*1.
10196
On entry, UPLO specifies whether the matrix is an upper or
10197
lower triangular matrix as follows:
10198
10199
UPLO = 'U' or 'u' A is an upper triangular matrix.
10200
10201
UPLO = 'L' or 'l' A is a lower triangular matrix.
10202
10203
Unchanged on exit.
10204
10205
TRANS - CHARACTER*1.
10206
On entry, TRANS specifies the equations to be solved as
10207
follows:
10208
10209
TRANS = 'N' or 'n' A*x = b.
10210
10211
TRANS = 'T' or 't' A'*x = b.
10212
10213
TRANS = 'C' or 'c' conjg( A' )*x = b.
10214
10215
Unchanged on exit.
10216
10217
DIAG - CHARACTER*1.
10218
On entry, DIAG specifies whether or not A is unit
10219
triangular as follows:
10220
10221
DIAG = 'U' or 'u' A is assumed to be unit triangular.
10222
10223
DIAG = 'N' or 'n' A is not assumed to be unit
10224
triangular.
10225
10226
Unchanged on exit.
10227
10228
N - INTEGER.
10229
On entry, N specifies the order of the matrix A.
10230
N must be at least zero.
10231
Unchanged on exit.
10232
10233
A - COMPLEX*16 array of DIMENSION ( LDA, n ).
10234
Before entry with UPLO = 'U' or 'u', the leading n by n
10235
upper triangular part of the array A must contain the upper
10236
triangular matrix and the strictly lower triangular part of
10237
A is not referenced.
10238
Before entry with UPLO = 'L' or 'l', the leading n by n
10239
lower triangular part of the array A must contain the lower
10240
triangular matrix and the strictly upper triangular part of
10241
A is not referenced.
10242
Note that when DIAG = 'U' or 'u', the diagonal elements of
10243
A are not referenced either, but are assumed to be unity.
10244
Unchanged on exit.
10245
10246
LDA - INTEGER.
10247
On entry, LDA specifies the first dimension of A as declared
10248
in the calling (sub) program. LDA must be at least
10249
max( 1, n ).
10250
Unchanged on exit.
10251
10252
X - COMPLEX*16 array of dimension at least
10253
( 1 + ( n - 1 )*abs( INCX ) ).
10254
Before entry, the incremented array X must contain the n
10255
element right-hand side vector b. On exit, X is overwritten
10256
with the solution vector x.
10257
10258
INCX - INTEGER.
10259
On entry, INCX specifies the increment for the elements of
10260
X. INCX must not be zero.
10261
Unchanged on exit.
10262
10263
10264
Level 2 Blas routine.
10265
10266
-- Written on 22-October-1986.
10267
Jack Dongarra, Argonne National Lab.
10268
Jeremy Du Croz, Nag Central Office.
10269
Sven Hammarling, Nag Central Office.
10270
Richard Hanson, Sandia National Labs.
10271
10272
10273
Test the input parameters.
10274
*/
10275
10276
/* Parameter adjustments */
10277
a_dim1 = *lda;
10278
a_offset = 1 + a_dim1 * 1;
10279
a -= a_offset;
10280
--x;
10281
10282
/* Function Body */
10283
info = 0;
10284
if ((! lsame_(uplo, "U") && ! lsame_(uplo, "L"))) {
10285
info = 1;
10286
} else if (((! lsame_(trans, "N") && ! lsame_(trans,
10287
"T")) && ! lsame_(trans, "C"))) {
10288
info = 2;
10289
} else if ((! lsame_(diag, "U") && ! lsame_(diag,
10290
"N"))) {
10291
info = 3;
10292
} else if (*n < 0) {
10293
info = 4;
10294
} else if (*lda < max(1,*n)) {
10295
info = 6;
10296
} else if (*incx == 0) {
10297
info = 8;
10298
}
10299
if (info != 0) {
10300
xerbla_("ZTRSV ", &info);
10301
return 0;
10302
}
10303
10304
/* Quick return if possible. */
10305
10306
if (*n == 0) {
10307
return 0;
10308
}
10309
10310
noconj = lsame_(trans, "T");
10311
nounit = lsame_(diag, "N");
10312
10313
/*
10314
Set up the start point in X if the increment is not unity. This
10315
will be ( N - 1 )*INCX too small for descending loops.
10316
*/
10317
10318
if (*incx <= 0) {
10319
kx = 1 - (*n - 1) * *incx;
10320
} else if (*incx != 1) {
10321
kx = 1;
10322
}
10323
10324
/*
10325
Start the operations. In this version the elements of A are
10326
accessed sequentially with one pass through A.
10327
*/
10328
10329
if (lsame_(trans, "N")) {
10330
10331
/* Form x := inv( A )*x. */
10332
10333
if (lsame_(uplo, "U")) {
10334
if (*incx == 1) {
10335
for (j = *n; j >= 1; --j) {
10336
i__1 = j;
10337
if (x[i__1].r != 0. || x[i__1].i != 0.) {
10338
if (nounit) {
10339
i__1 = j;
10340
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
10341
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
10342
}
10343
i__1 = j;
10344
temp.r = x[i__1].r, temp.i = x[i__1].i;
10345
for (i__ = j - 1; i__ >= 1; --i__) {
10346
i__1 = i__;
10347
i__2 = i__;
10348
i__3 = i__ + j * a_dim1;
10349
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
10350
z__2.i = temp.r * a[i__3].i + temp.i * a[
10351
i__3].r;
10352
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
10353
z__2.i;
10354
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
10355
/* L10: */
10356
}
10357
}
10358
/* L20: */
10359
}
10360
} else {
10361
jx = kx + (*n - 1) * *incx;
10362
for (j = *n; j >= 1; --j) {
10363
i__1 = jx;
10364
if (x[i__1].r != 0. || x[i__1].i != 0.) {
10365
if (nounit) {
10366
i__1 = jx;
10367
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
10368
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
10369
}
10370
i__1 = jx;
10371
temp.r = x[i__1].r, temp.i = x[i__1].i;
10372
ix = jx;
10373
for (i__ = j - 1; i__ >= 1; --i__) {
10374
ix -= *incx;
10375
i__1 = ix;
10376
i__2 = ix;
10377
i__3 = i__ + j * a_dim1;
10378
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
10379
z__2.i = temp.r * a[i__3].i + temp.i * a[
10380
i__3].r;
10381
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
10382
z__2.i;
10383
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
10384
/* L30: */
10385
}
10386
}
10387
jx -= *incx;
10388
/* L40: */
10389
}
10390
}
10391
} else {
10392
if (*incx == 1) {
10393
i__1 = *n;
10394
for (j = 1; j <= i__1; ++j) {
10395
i__2 = j;
10396
if (x[i__2].r != 0. || x[i__2].i != 0.) {
10397
if (nounit) {
10398
i__2 = j;
10399
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
10400
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
10401
}
10402
i__2 = j;
10403
temp.r = x[i__2].r, temp.i = x[i__2].i;
10404
i__2 = *n;
10405
for (i__ = j + 1; i__ <= i__2; ++i__) {
10406
i__3 = i__;
10407
i__4 = i__;
10408
i__5 = i__ + j * a_dim1;
10409
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
10410
z__2.i = temp.r * a[i__5].i + temp.i * a[
10411
i__5].r;
10412
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
10413
z__2.i;
10414
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
10415
/* L50: */
10416
}
10417
}
10418
/* L60: */
10419
}
10420
} else {
10421
jx = kx;
10422
i__1 = *n;
10423
for (j = 1; j <= i__1; ++j) {
10424
i__2 = jx;
10425
if (x[i__2].r != 0. || x[i__2].i != 0.) {
10426
if (nounit) {
10427
i__2 = jx;
10428
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
10429
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
10430
}
10431
i__2 = jx;
10432
temp.r = x[i__2].r, temp.i = x[i__2].i;
10433
ix = jx;
10434
i__2 = *n;
10435
for (i__ = j + 1; i__ <= i__2; ++i__) {
10436
ix += *incx;
10437
i__3 = ix;
10438
i__4 = ix;
10439
i__5 = i__ + j * a_dim1;
10440
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
10441
z__2.i = temp.r * a[i__5].i + temp.i * a[
10442
i__5].r;
10443
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
10444
z__2.i;
10445
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
10446
/* L70: */
10447
}
10448
}
10449
jx += *incx;
10450
/* L80: */
10451
}
10452
}
10453
}
10454
} else {
10455
10456
/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
10457
10458
if (lsame_(uplo, "U")) {
10459
if (*incx == 1) {
10460
i__1 = *n;
10461
for (j = 1; j <= i__1; ++j) {
10462
i__2 = j;
10463
temp.r = x[i__2].r, temp.i = x[i__2].i;
10464
if (noconj) {
10465
i__2 = j - 1;
10466
for (i__ = 1; i__ <= i__2; ++i__) {
10467
i__3 = i__ + j * a_dim1;
10468
i__4 = i__;
10469
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
10470
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
10471
a[i__3].i * x[i__4].r;
10472
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10473
z__2.i;
10474
temp.r = z__1.r, temp.i = z__1.i;
10475
/* L90: */
10476
}
10477
if (nounit) {
10478
z_div(&z__1, &temp, &a[j + j * a_dim1]);
10479
temp.r = z__1.r, temp.i = z__1.i;
10480
}
10481
} else {
10482
i__2 = j - 1;
10483
for (i__ = 1; i__ <= i__2; ++i__) {
10484
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
10485
i__3 = i__;
10486
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
10487
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
10488
i__3].r;
10489
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10490
z__2.i;
10491
temp.r = z__1.r, temp.i = z__1.i;
10492
/* L100: */
10493
}
10494
if (nounit) {
10495
d_cnjg(&z__2, &a[j + j * a_dim1]);
10496
z_div(&z__1, &temp, &z__2);
10497
temp.r = z__1.r, temp.i = z__1.i;
10498
}
10499
}
10500
i__2 = j;
10501
x[i__2].r = temp.r, x[i__2].i = temp.i;
10502
/* L110: */
10503
}
10504
} else {
10505
jx = kx;
10506
i__1 = *n;
10507
for (j = 1; j <= i__1; ++j) {
10508
ix = kx;
10509
i__2 = jx;
10510
temp.r = x[i__2].r, temp.i = x[i__2].i;
10511
if (noconj) {
10512
i__2 = j - 1;
10513
for (i__ = 1; i__ <= i__2; ++i__) {
10514
i__3 = i__ + j * a_dim1;
10515
i__4 = ix;
10516
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
10517
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
10518
a[i__3].i * x[i__4].r;
10519
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10520
z__2.i;
10521
temp.r = z__1.r, temp.i = z__1.i;
10522
ix += *incx;
10523
/* L120: */
10524
}
10525
if (nounit) {
10526
z_div(&z__1, &temp, &a[j + j * a_dim1]);
10527
temp.r = z__1.r, temp.i = z__1.i;
10528
}
10529
} else {
10530
i__2 = j - 1;
10531
for (i__ = 1; i__ <= i__2; ++i__) {
10532
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
10533
i__3 = ix;
10534
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
10535
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
10536
i__3].r;
10537
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10538
z__2.i;
10539
temp.r = z__1.r, temp.i = z__1.i;
10540
ix += *incx;
10541
/* L130: */
10542
}
10543
if (nounit) {
10544
d_cnjg(&z__2, &a[j + j * a_dim1]);
10545
z_div(&z__1, &temp, &z__2);
10546
temp.r = z__1.r, temp.i = z__1.i;
10547
}
10548
}
10549
i__2 = jx;
10550
x[i__2].r = temp.r, x[i__2].i = temp.i;
10551
jx += *incx;
10552
/* L140: */
10553
}
10554
}
10555
} else {
10556
if (*incx == 1) {
10557
for (j = *n; j >= 1; --j) {
10558
i__1 = j;
10559
temp.r = x[i__1].r, temp.i = x[i__1].i;
10560
if (noconj) {
10561
i__1 = j + 1;
10562
for (i__ = *n; i__ >= i__1; --i__) {
10563
i__2 = i__ + j * a_dim1;
10564
i__3 = i__;
10565
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
10566
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
10567
a[i__2].i * x[i__3].r;
10568
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10569
z__2.i;
10570
temp.r = z__1.r, temp.i = z__1.i;
10571
/* L150: */
10572
}
10573
if (nounit) {
10574
z_div(&z__1, &temp, &a[j + j * a_dim1]);
10575
temp.r = z__1.r, temp.i = z__1.i;
10576
}
10577
} else {
10578
i__1 = j + 1;
10579
for (i__ = *n; i__ >= i__1; --i__) {
10580
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
10581
i__2 = i__;
10582
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
10583
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
10584
i__2].r;
10585
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10586
z__2.i;
10587
temp.r = z__1.r, temp.i = z__1.i;
10588
/* L160: */
10589
}
10590
if (nounit) {
10591
d_cnjg(&z__2, &a[j + j * a_dim1]);
10592
z_div(&z__1, &temp, &z__2);
10593
temp.r = z__1.r, temp.i = z__1.i;
10594
}
10595
}
10596
i__1 = j;
10597
x[i__1].r = temp.r, x[i__1].i = temp.i;
10598
/* L170: */
10599
}
10600
} else {
10601
kx += (*n - 1) * *incx;
10602
jx = kx;
10603
for (j = *n; j >= 1; --j) {
10604
ix = kx;
10605
i__1 = jx;
10606
temp.r = x[i__1].r, temp.i = x[i__1].i;
10607
if (noconj) {
10608
i__1 = j + 1;
10609
for (i__ = *n; i__ >= i__1; --i__) {
10610
i__2 = i__ + j * a_dim1;
10611
i__3 = ix;
10612
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
10613
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
10614
a[i__2].i * x[i__3].r;
10615
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10616
z__2.i;
10617
temp.r = z__1.r, temp.i = z__1.i;
10618
ix -= *incx;
10619
/* L180: */
10620
}
10621
if (nounit) {
10622
z_div(&z__1, &temp, &a[j + j * a_dim1]);
10623
temp.r = z__1.r, temp.i = z__1.i;
10624
}
10625
} else {
10626
i__1 = j + 1;
10627
for (i__ = *n; i__ >= i__1; --i__) {
10628
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
10629
i__2 = ix;
10630
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
10631
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
10632
i__2].r;
10633
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
10634
z__2.i;
10635
temp.r = z__1.r, temp.i = z__1.i;
10636
ix -= *incx;
10637
/* L190: */
10638
}
10639
if (nounit) {
10640
d_cnjg(&z__2, &a[j + j * a_dim1]);
10641
z_div(&z__1, &temp, &z__2);
10642
temp.r = z__1.r, temp.i = z__1.i;
10643
}
10644
}
10645
i__1 = jx;
10646
x[i__1].r = temp.r, x[i__1].i = temp.i;
10647
jx -= *incx;
10648
/* L200: */
10649
}
10650
}
10651
}
10652
}
10653
10654
return 0;
10655
10656
/* End of ZTRSV . */
10657
10658
} /* ztrsv_ */
10659
Loggerhead is a web-based interface for Breezy
Version: 2.0.1