163 SUBROUTINE sorm22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC,
164 $ work, lwork, info )
174 CHARACTER SIDE, TRANS
175 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
178 REAL Q( ldq, * ), C( ldc, * ), WORK( * )
185 parameter ( one = 1.0e+0 )
188 LOGICAL LEFT, LQUERY, NOTRAN
189 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
199 INTRINSIC REAL, MAX, MIN
206 left = lsame( side,
'L' )
207 notran = lsame( trans,
'N' )
208 lquery = ( lwork.EQ.-1 )
219 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
220 IF( .NOT.left .AND. .NOT.lsame( side,
'R' ) )
THEN
222 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.lsame( trans,
'T' ) )
225 ELSE IF( m.LT.0 )
THEN
227 ELSE IF( n.LT.0 )
THEN
229 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq )
THEN
231 ELSE IF( n2.LT.0 )
THEN
233 ELSE IF( ldq.LT.max( 1, nq ) )
THEN
235 ELSE IF( ldc.LT.max( 1, m ) )
THEN
237 ELSE IF( lwork.LT.nw .AND. .NOT.lquery )
THEN
243 work( 1 ) =
REAL( lwkopt )
247 CALL xerbla(
'SORM22', -info )
249 ELSE IF( lquery )
THEN
255 IF( m.EQ.0 .OR. n.EQ.0 )
THEN
263 CALL strmm( side,
'Upper', trans,
'Non-Unit', m, n, one,
267 ELSE IF( n2.EQ.0 )
THEN
268 CALL strmm( side,
'Lower', trans,
'Non-Unit', m, n, one,
276 nb = max( 1, min( lwork, lwkopt ) / nq )
281 len = min( nb, n-i+1 )
286 CALL slacpy(
'All', n1, len, c( n2+1, i ), ldc, work,
288 CALL strmm(
'Left',
'Lower',
'No Transpose',
'Non-Unit',
289 $ n1, len, one, q( 1, n2+1 ), ldq, work,
294 CALL sgemm(
'No Transpose',
'No Transpose', n1, len, n2,
295 $ one, q, ldq, c( 1, i ), ldc, one, work,
300 CALL slacpy(
'All', n2, len, c( 1, i ), ldc,
301 $ work( n1+1 ), ldwork )
302 CALL strmm(
'Left',
'Upper',
'No Transpose',
'Non-Unit',
303 $ n2, len, one, q( n1+1, 1 ), ldq,
304 $ work( n1+1 ), ldwork )
308 CALL sgemm(
'No Transpose',
'No Transpose', n2, len, n1,
309 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
310 $ one, work( n1+1 ), ldwork )
314 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
319 len = min( nb, n-i+1 )
324 CALL slacpy(
'All', n2, len, c( n1+1, i ), ldc, work,
326 CALL strmm(
'Left',
'Upper',
'Transpose',
'Non-Unit',
327 $ n2, len, one, q( n1+1, 1 ), ldq, work,
332 CALL sgemm(
'Transpose',
'No Transpose', n2, len, n1,
333 $ one, q, ldq, c( 1, i ), ldc, one, work,
338 CALL slacpy(
'All', n1, len, c( 1, i ), ldc,
339 $ work( n2+1 ), ldwork )
340 CALL strmm(
'Left',
'Lower',
'Transpose',
'Non-Unit',
341 $ n1, len, one, q( 1, n2+1 ), ldq,
342 $ work( n2+1 ), ldwork )
346 CALL sgemm(
'Transpose',
'No Transpose', n1, len, n2,
347 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
348 $ one, work( n2+1 ), ldwork )
352 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
359 len = min( nb, m-i+1 )
364 CALL slacpy(
'All', len, n2, c( i, n1+1 ), ldc, work,
366 CALL strmm(
'Right',
'Upper',
'No Transpose',
'Non-Unit',
367 $ len, n2, one, q( n1+1, 1 ), ldq, work,
372 CALL sgemm(
'No Transpose',
'No Transpose', len, n2, n1,
373 $ one, c( i, 1 ), ldc, q, ldq, one, work,
378 CALL slacpy(
'All', len, n1, c( i, 1 ), ldc,
379 $ work( 1 + n2*ldwork ), ldwork )
380 CALL strmm(
'Right',
'Lower',
'No Transpose',
'Non-Unit',
381 $ len, n1, one, q( 1, n2+1 ), ldq,
382 $ work( 1 + n2*ldwork ), ldwork )
386 CALL sgemm(
'No Transpose',
'No Transpose', len, n1, n2,
387 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
388 $ one, work( 1 + n2*ldwork ), ldwork )
392 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
397 len = min( nb, m-i+1 )
402 CALL slacpy(
'All', len, n1, c( i, n2+1 ), ldc, work,
404 CALL strmm(
'Right',
'Lower',
'Transpose',
'Non-Unit',
405 $ len, n1, one, q( 1, n2+1 ), ldq, work,
410 CALL sgemm(
'No Transpose',
'Transpose', len, n1, n2,
411 $ one, c( i, 1 ), ldc, q, ldq, one, work,
416 CALL slacpy(
'All', len, n2, c( i, 1 ), ldc,
417 $ work( 1 + n1*ldwork ), ldwork )
418 CALL strmm(
'Right',
'Upper',
'Transpose',
'Non-Unit',
419 $ len, n2, one, q( n1+1, 1 ), ldq,
420 $ work( 1 + n1*ldwork ), ldwork )
424 CALL sgemm(
'No Transpose',
'Transpose', len, n2, n1,
425 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
426 $ one, work( 1 + n1*ldwork ), ldwork )
430 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
436 work( 1 ) =
REAL( lwkopt )
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sorm22(SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, WORK, LWORK, INFO)
SORM22 multiplies a general matrix by a banded orthogonal matrix.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.