159 SUBROUTINE sorm22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC,
160 $ WORK, LWORK, INFO )
169 CHARACTER SIDE, TRANS
170 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
173 REAL Q( LDQ, * ), C( LDC, * ), WORK( * )
180 parameter( one = 1.0e+0 )
183 LOGICAL LEFT, LQUERY, NOTRAN
184 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
189 EXTERNAL lsame, sroundup_lwork
202 left = lsame( side,
'L' )
203 notran = lsame( trans,
'N' )
204 lquery = ( lwork.EQ.-1 )
215 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
216 IF( .NOT.left .AND. .NOT.lsame( side,
'R' ) )
THEN
218 ELSE IF( .NOT.lsame( trans,
'N' ) .AND.
219 $ .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 ) = sroundup_lwork( 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',
287 $ n1, len, one, q( 1, n2+1 ), ldq, work,
292 CALL sgemm(
'No Transpose',
'No Transpose', n1, len,
294 $ one, q, ldq, c( 1, i ), ldc, one, work,
299 CALL slacpy(
'All', n2, len, c( 1, i ), ldc,
300 $ work( n1+1 ), ldwork )
301 CALL strmm(
'Left',
'Upper',
'No Transpose',
303 $ n2, len, one, q( n1+1, 1 ), ldq,
304 $ work( n1+1 ), ldwork )
308 CALL sgemm(
'No Transpose',
'No Transpose', n2, len,
310 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
311 $ one, work( n1+1 ), ldwork )
315 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
320 len = min( nb, n-i+1 )
325 CALL slacpy(
'All', n2, len, c( n1+1, i ), ldc, work,
327 CALL strmm(
'Left',
'Upper',
'Transpose',
'Non-Unit',
328 $ n2, len, one, q( n1+1, 1 ), ldq, work,
333 CALL sgemm(
'Transpose',
'No Transpose', n2, len, n1,
334 $ one, q, ldq, c( 1, i ), ldc, one, work,
339 CALL slacpy(
'All', n1, len, c( 1, i ), ldc,
340 $ work( n2+1 ), ldwork )
341 CALL strmm(
'Left',
'Lower',
'Transpose',
'Non-Unit',
342 $ n1, len, one, q( 1, n2+1 ), ldq,
343 $ work( n2+1 ), ldwork )
347 CALL sgemm(
'Transpose',
'No Transpose', n1, len, n2,
348 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
349 $ one, work( n2+1 ), ldwork )
353 CALL slacpy(
'All', m, len, work, ldwork, c( 1, i ),
360 len = min( nb, m-i+1 )
365 CALL slacpy(
'All', len, n2, c( i, n1+1 ), ldc, work,
367 CALL strmm(
'Right',
'Upper',
'No Transpose',
369 $ len, n2, one, q( n1+1, 1 ), ldq, work,
374 CALL sgemm(
'No Transpose',
'No Transpose', len, n2,
376 $ one, c( i, 1 ), ldc, q, ldq, one, work,
381 CALL slacpy(
'All', len, n1, c( i, 1 ), ldc,
382 $ work( 1 + n2*ldwork ), ldwork )
383 CALL strmm(
'Right',
'Lower',
'No Transpose',
385 $ len, n1, one, q( 1, n2+1 ), ldq,
386 $ work( 1 + n2*ldwork ), ldwork )
390 CALL sgemm(
'No Transpose',
'No Transpose', len, n1,
392 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
393 $ one, work( 1 + n2*ldwork ), ldwork )
397 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
402 len = min( nb, m-i+1 )
407 CALL slacpy(
'All', len, n1, c( i, n2+1 ), ldc, work,
409 CALL strmm(
'Right',
'Lower',
'Transpose',
'Non-Unit',
410 $ len, n1, one, q( 1, n2+1 ), ldq, work,
415 CALL sgemm(
'No Transpose',
'Transpose', len, n1, n2,
416 $ one, c( i, 1 ), ldc, q, ldq, one, work,
421 CALL slacpy(
'All', len, n2, c( i, 1 ), ldc,
422 $ work( 1 + n1*ldwork ), ldwork )
423 CALL strmm(
'Right',
'Upper',
'Transpose',
'Non-Unit',
424 $ len, n2, one, q( n1+1, 1 ), ldq,
425 $ work( 1 + n1*ldwork ), ldwork )
429 CALL sgemm(
'No Transpose',
'Transpose', len, n2, n1,
430 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
431 $ one, work( 1 + n1*ldwork ), ldwork )
435 CALL slacpy(
'All', len, n, work, ldwork, c( i, 1 ),
441 work( 1 ) = sroundup_lwork( lwkopt )