161 SUBROUTINE sorm22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC,
162 $ WORK, LWORK, INFO )
171 CHARACTER SIDE, TRANS
172 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
175 REAL Q( LDQ, * ), C( LDC, * ), WORK( * )
182 parameter( one = 1.0e+0 )
185 LOGICAL LEFT, LQUERY, NOTRAN
186 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
196 INTRINSIC real, max, min
203 left = lsame( side,
'L' )
204 notran = lsame( trans,
'N' )
205 lquery = ( lwork.EQ.-1 )
216 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
217 IF( .NOT.left .AND. .NOT.lsame( side,
'R' ) )
THEN
219 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.lsame( trans,
'T' ) )
222 ELSE IF( m.LT.0 )
THEN
224 ELSE IF( n.LT.0 )
THEN
226 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq )
THEN
228 ELSE IF( n2.LT.0 )
THEN
230 ELSE IF( ldq.LT.max( 1, nq ) )
THEN
232 ELSE IF( ldc.LT.max( 1, m ) )
THEN
234 ELSE IF( lwork.LT.nw .AND. .NOT.lquery )
THEN
240 work( 1 ) = real( lwkopt )
244 CALL xerbla(
'SORM22', -info )
246 ELSE IF( lquery )
THEN
252 IF( m.EQ.0 .OR. n.EQ.0 )
THEN
260 CALL strmm( side,
'Upper', trans,
'Non-Unit', m, n, one,
264 ELSE IF( n2.EQ.0 )
THEN
265 CALL strmm( side,
'Lower', trans,
'Non-Unit', m, n, one,
273 nb = max( 1, min( lwork, lwkopt ) / nq )
278 len = min( nb, n-i+1 )
283 CALL slacpy(
'All', n1, len, c( n2+1, i ), ldc, work,
285 CALL strmm(
'Left',
'Lower',
'No Transpose',
'Non-Unit',
286 $ n1, len, one, q( 1, n2+1 ), ldq, work,
291 CALL sgemm(
'No Transpose',
'No Transpose', n1, len, n2,
292 $ one, q, ldq, c( 1, i ), ldc, one, work,
297 CALL slacpy(
'All', n2, len, c( 1, i ), ldc,
298 $ work( n1+1 ), ldwork )
299 CALL strmm(
'Left',
'Upper',
'No Transpose',
'Non-Unit',
300 $ n2, len, one, q( n1+1, 1 ), ldq,
301 $ work( n1+1 ), ldwork )
305 CALL sgemm(
'No Transpose',
'No Transpose', n2, len, n1,
306 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
307 $ one, work( n1+1 ), ldwork )
311 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
316 len = min( nb, n-i+1 )
321 CALL slacpy(
'All', n2, len, c( n1+1, i ), ldc, work,
323 CALL strmm(
'Left',
'Upper',
'Transpose',
'Non-Unit',
324 $ n2, len, one, q( n1+1, 1 ), ldq, work,
329 CALL sgemm(
'Transpose',
'No Transpose', n2, len, n1,
330 $ one, q, ldq, c( 1, i ), ldc, one, work,
335 CALL slacpy(
'All', n1, len, c( 1, i ), ldc,
336 $ work( n2+1 ), ldwork )
337 CALL strmm(
'Left',
'Lower',
'Transpose',
'Non-Unit',
338 $ n1, len, one, q( 1, n2+1 ), ldq,
339 $ work( n2+1 ), ldwork )
343 CALL sgemm(
'Transpose',
'No Transpose', n1, len, n2,
344 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
345 $ one, work( n2+1 ), ldwork )
349 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
356 len = min( nb, m-i+1 )
361 CALL slacpy(
'All', len, n2, c( i, n1+1 ), ldc, work,
363 CALL strmm(
'Right',
'Upper',
'No Transpose',
'Non-Unit',
364 $ len, n2, one, q( n1+1, 1 ), ldq, work,
369 CALL sgemm(
'No Transpose',
'No Transpose', len, n2, n1,
370 $ one, c( i, 1 ), ldc, q, ldq, one, work,
375 CALL slacpy(
'All', len, n1, c( i, 1 ), ldc,
376 $ work( 1 + n2*ldwork ), ldwork )
377 CALL strmm(
'Right',
'Lower',
'No Transpose',
'Non-Unit',
378 $ len, n1, one, q( 1, n2+1 ), ldq,
379 $ work( 1 + n2*ldwork ), ldwork )
383 CALL sgemm(
'No Transpose',
'No Transpose', len, n1, n2,
384 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
385 $ one, work( 1 + n2*ldwork ), ldwork )
389 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
394 len = min( nb, m-i+1 )
399 CALL slacpy(
'All', len, n1, c( i, n2+1 ), ldc, work,
401 CALL strmm(
'Right',
'Lower',
'Transpose',
'Non-Unit',
402 $ len, n1, one, q( 1, n2+1 ), ldq, work,
407 CALL sgemm(
'No Transpose',
'Transpose', len, n1, n2,
408 $ one, c( i, 1 ), ldc, q, ldq, one, work,
413 CALL slacpy(
'All', len, n2, c( i, 1 ), ldc,
414 $ work( 1 + n1*ldwork ), ldwork )
415 CALL strmm(
'Right',
'Upper',
'Transpose',
'Non-Unit',
416 $ len, n2, one, q( n1+1, 1 ), ldq,
417 $ work( 1 + n1*ldwork ), ldwork )
421 CALL sgemm(
'No Transpose',
'Transpose', len, n2, n1,
422 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
423 $ one, work( 1 + n1*ldwork ), ldwork )
427 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
433 work( 1 ) = real( lwkopt )
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
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 strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM