libflame revision_anchor
Functions
sopgtr.c File Reference

(r)

Functions

int sopgtr_ (char *uplo, integer *n, real *ap, real *tau, real *q, integer *ldq, real *work, integer *info)
 

Function Documentation

◆ sopgtr_()

int sopgtr_ ( char uplo,
integer n,
real ap,
real tau,
real q,
integer ldq,
real work,
integer info 
)
105{
106 /* System generated locals */
108 /* Local variables */
109 integer i__, j, ij;
110 extern logical lsame_(char *, char *);
113 extern /* Subroutine */
114 int sorg2l_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorg2r_fla(integer *, integer *, integer *, real *, integer *, real *, real *, integer * ), xerbla_(char *, integer *);
115 /* -- LAPACK computational routine (version 3.4.0) -- */
116 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
117 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
118 /* November 2011 */
119 /* .. Scalar Arguments .. */
120 /* .. */
121 /* .. Array Arguments .. */
122 /* .. */
123 /* ===================================================================== */
124 /* .. Parameters .. */
125 /* .. */
126 /* .. Local Scalars .. */
127 /* .. */
128 /* .. External Functions .. */
129 /* .. */
130 /* .. External Subroutines .. */
131 /* .. */
132 /* .. Intrinsic Functions .. */
133 /* .. */
134 /* .. Executable Statements .. */
135 /* Test the input arguments */
136 /* Parameter adjustments */
137 --ap;
138 --tau;
139 q_dim1 = *ldq;
140 q_offset = 1 + q_dim1;
141 q -= q_offset;
142 --work;
143 /* Function Body */
144 *info = 0;
145 upper = lsame_(uplo, "U");
146 if (! upper && ! lsame_(uplo, "L"))
147 {
148 *info = -1;
149 }
150 else if (*n < 0)
151 {
152 *info = -2;
153 }
154 else if (*ldq < max(1,*n))
155 {
156 *info = -6;
157 }
158 if (*info != 0)
159 {
160 i__1 = -(*info);
161 xerbla_("SOPGTR", &i__1);
162 return 0;
163 }
164 /* Quick return if possible */
165 if (*n == 0)
166 {
167 return 0;
168 }
169 if (upper)
170 {
171 /* Q was determined by a call to SSPTRD with UPLO = 'U' */
172 /* Unpack the vectors which define the elementary reflectors and */
173 /* set the last row and column of Q equal to those of the unit */
174 /* matrix */
175 ij = 2;
176 i__1 = *n - 1;
177 for (j = 1;
178 j <= i__1;
179 ++j)
180 {
181 i__2 = j - 1;
182 for (i__ = 1;
183 i__ <= i__2;
184 ++i__)
185 {
186 q[i__ + j * q_dim1] = ap[ij];
187 ++ij;
188 /* L10: */
189 }
190 ij += 2;
191 q[*n + j * q_dim1] = 0.f;
192 /* L20: */
193 }
194 i__1 = *n - 1;
195 for (i__ = 1;
196 i__ <= i__1;
197 ++i__)
198 {
199 q[i__ + *n * q_dim1] = 0.f;
200 /* L30: */
201 }
202 q[*n + *n * q_dim1] = 1.f;
203 /* Generate Q(1:n-1,1:n-1) */
204 i__1 = *n - 1;
205 i__2 = *n - 1;
206 i__3 = *n - 1;
207 sorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo);
208 }
209 else
210 {
211 /* Q was determined by a call to SSPTRD with UPLO = 'L'. */
212 /* Unpack the vectors which define the elementary reflectors and */
213 /* set the first row and column of Q equal to those of the unit */
214 /* matrix */
215 q[q_dim1 + 1] = 1.f;
216 i__1 = *n;
217 for (i__ = 2;
218 i__ <= i__1;
219 ++i__)
220 {
221 q[i__ + q_dim1] = 0.f;
222 /* L40: */
223 }
224 ij = 3;
225 i__1 = *n;
226 for (j = 2;
227 j <= i__1;
228 ++j)
229 {
230 q[j * q_dim1 + 1] = 0.f;
231 i__2 = *n;
232 for (i__ = j + 1;
233 i__ <= i__2;
234 ++i__)
235 {
236 q[i__ + j * q_dim1] = ap[ij];
237 ++ij;
238 /* L50: */
239 }
240 ij += 2;
241 /* L60: */
242 }
243 if (*n > 1)
244 {
245 /* Generate Q(2:n,2:n) */
246 i__1 = *n - 1;
247 i__2 = *n - 1;
248 i__3 = *n - 1;
249 sorg2r_fla(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], &work[1], &iinfo);
250 }
251 }
252 return 0;
253 /* End of SOPGTR */
254}
int integer
Definition FLA_f2c.h:25
int logical
Definition FLA_f2c.h:36
float real
Definition FLA_f2c.h:30
int i
Definition bl1_axmyv2.c:145
int sorg2r_fla(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info)
Definition sorg2r.c:105

References i, and sorg2r_fla().