1 /* ./src_f77/slarf.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Table of constant values */
9
10 static real c_b4 = 1.f;
11 static real c_b5 = 0.f;
12 static integer c__1 = 1;
13
slarf_(char * side,integer * m,integer * n,real * v,integer * incv,real * tau,real * c__,integer * ldc,real * work,ftnlen side_len)14 /* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v,
15 integer *incv, real *tau, real *c__, integer *ldc, real *work, ftnlen
16 side_len)
17 {
18 /* System generated locals */
19 integer c_dim1, c_offset;
20 real r__1;
21
22 /* Local variables */
23 extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
24 integer *, real *, integer *, real *, integer *);
25 extern logical lsame_(char *, char *, ftnlen, ftnlen);
26 extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
27 real *, integer *, real *, integer *, real *, real *, integer *,
28 ftnlen);
29
30
31 /* -- LAPACK auxiliary routine (version 3.0) -- */
32 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
33 /* Courant Institute, Argonne National Lab, and Rice University */
34 /* February 29, 1992 */
35
36 /* .. Scalar Arguments .. */
37 /* .. */
38 /* .. Array Arguments .. */
39 /* .. */
40
41 /* Purpose */
42 /* ======= */
43
44 /* SLARF applies a real elementary reflector H to a real m by n matrix */
45 /* C, from either the left or the right. H is represented in the form */
46
47 /* H = I - tau * v * v' */
48
49 /* where tau is a real scalar and v is a real vector. */
50
51 /* If tau = 0, then H is taken to be the unit matrix. */
52
53 /* Arguments */
54 /* ========= */
55
56 /* SIDE (input) CHARACTER*1 */
57 /* = 'L': form H * C */
58 /* = 'R': form C * H */
59
60 /* M (input) INTEGER */
61 /* The number of rows of the matrix C. */
62
63 /* N (input) INTEGER */
64 /* The number of columns of the matrix C. */
65
66 /* V (input) REAL array, dimension */
67 /* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
68 /* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
69 /* The vector v in the representation of H. V is not used if */
70 /* TAU = 0. */
71
72 /* INCV (input) INTEGER */
73 /* The increment between elements of v. INCV <> 0. */
74
75 /* TAU (input) REAL */
76 /* The value tau in the representation of H. */
77
78 /* C (input/output) REAL array, dimension (LDC,N) */
79 /* On entry, the m by n matrix C. */
80 /* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
81 /* or C * H if SIDE = 'R'. */
82
83 /* LDC (input) INTEGER */
84 /* The leading dimension of the array C. LDC >= max(1,M). */
85
86 /* WORK (workspace) REAL array, dimension */
87 /* (N) if SIDE = 'L' */
88 /* or (M) if SIDE = 'R' */
89
90 /* ===================================================================== */
91
92 /* .. Parameters .. */
93 /* .. */
94 /* .. External Subroutines .. */
95 /* .. */
96 /* .. External Functions .. */
97 /* .. */
98 /* .. Executable Statements .. */
99
100 /* Parameter adjustments */
101 --v;
102 c_dim1 = *ldc;
103 c_offset = 1 + c_dim1;
104 c__ -= c_offset;
105 --work;
106
107 /* Function Body */
108 if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
109
110 /* Form H * C */
111
112 if (*tau != 0.f) {
113
114 /* w := C' * v */
115
116 sgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
117 &c_b5, &work[1], &c__1, (ftnlen)9);
118
119 /* C := C - v * w' */
120
121 r__1 = -(*tau);
122 sger_(m, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
123 ldc);
124 }
125 } else {
126
127 /* Form C * H */
128
129 if (*tau != 0.f) {
130
131 /* w := C * v */
132
133 sgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
134 incv, &c_b5, &work[1], &c__1, (ftnlen)12);
135
136 /* C := C - w * v' */
137
138 r__1 = -(*tau);
139 sger_(m, n, &r__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
140 ldc);
141 }
142 }
143 return 0;
144
145 /* End of SLARF */
146
147 } /* slarf_ */
148
149