LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cunm22()

subroutine cunm22 ( character  side,
character  trans,
integer  m,
integer  n,
integer  n1,
integer  n2,
complex, dimension( ldq, * )  q,
integer  ldq,
complex, dimension( ldc, * )  c,
integer  ldc,
complex, dimension( * )  work,
integer  lwork,
integer  info 
)

CUNM22 multiplies a general matrix by a banded unitary matrix.

Download CUNM22 + dependencies [TGZ] [ZIP] [TXT]

Purpose
  CUNM22 overwrites the general complex M-by-N matrix C with

                  SIDE = 'L'     SIDE = 'R'
  TRANS = 'N':      Q * C          C * Q
  TRANS = 'C':      Q**H * C       C * Q**H

  where Q is a complex unitary matrix of order NQ, with NQ = M if
  SIDE = 'L' and NQ = N if SIDE = 'R'.
  The unitary matrix Q processes a 2-by-2 block structure

         [  Q11  Q12  ]
     Q = [            ]
         [  Q21  Q22  ],

  where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an
  N2-by-N2 upper triangular matrix.
Parameters
[in]SIDE
          SIDE is CHARACTER*1
          = 'L': apply Q or Q**H from the Left;
          = 'R': apply Q or Q**H from the Right.
[in]TRANS
          TRANS is CHARACTER*1
          = 'N':  apply Q (No transpose);
          = 'C':  apply Q**H (Conjugate transpose).
[in]M
          M is INTEGER
          The number of rows of the matrix C. M >= 0.
[in]N
          N is INTEGER
          The number of columns of the matrix C. N >= 0.
[in]N1
[in]N2
          N1 is INTEGER
          N2 is INTEGER
          The dimension of Q12 and Q21, respectively. N1, N2 >= 0.
          The following requirement must be satisfied:
          N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'.
[in]Q
          Q is COMPLEX array, dimension
                              (LDQ,M) if SIDE = 'L'
                              (LDQ,N) if SIDE = 'R'
[in]LDQ
          LDQ is INTEGER
          The leading dimension of the array Q.
          LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'.
[in,out]C
          C is COMPLEX array, dimension (LDC,N)
          On entry, the M-by-N matrix C.
          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
[in]LDC
          LDC is INTEGER
          The leading dimension of the array C. LDC >= max(1,M).
[out]WORK
          WORK is COMPLEX array, dimension (MAX(1,LWORK))
          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
[in]LWORK
          LWORK is INTEGER
          The dimension of the array WORK.
          If SIDE = 'L', LWORK >= max(1,N);
          if SIDE = 'R', LWORK >= max(1,M).
          For optimum performance LWORK >= M*N.

          If LWORK = -1, then a workspace query is assumed; the routine
          only calculates the optimal size of the WORK array, returns
          this value as the first entry of the WORK array, and no error
          message related to LWORK is issued by XERBLA.
[out]INFO
          INFO is INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal value
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 160 of file cunm22.f.

162*
163* -- LAPACK computational routine --
164* -- LAPACK is a software package provided by Univ. of Tennessee, --
165* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
166*
167 IMPLICIT NONE
168*
169* .. Scalar Arguments ..
170 CHARACTER SIDE, TRANS
171 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
172* ..
173* .. Array Arguments ..
174 COMPLEX Q( LDQ, * ), C( LDC, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 COMPLEX ONE
181 parameter( one = ( 1.0e+0, 0.0e+0 ) )
182*
183* .. Local Scalars ..
184 LOGICAL LEFT, LQUERY, NOTRAN
185 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 EXTERNAL lsame
190* ..
191* .. External Subroutines ..
192 EXTERNAL cgemm, clacpy, ctrmm, xerbla
193* ..
194* .. Intrinsic Functions ..
195 INTRINSIC cmplx, max, min
196* ..
197* .. Executable Statements ..
198*
199* Test the input arguments
200*
201 info = 0
202 left = lsame( side, 'L' )
203 notran = lsame( trans, 'N' )
204 lquery = ( lwork.EQ.-1 )
205*
206* NQ is the order of Q;
207* NW is the minimum dimension of WORK.
208*
209 IF( left ) THEN
210 nq = m
211 ELSE
212 nq = n
213 END IF
214 nw = nq
215 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
216 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
217 info = -1
218 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
219 $ THEN
220 info = -2
221 ELSE IF( m.LT.0 ) THEN
222 info = -3
223 ELSE IF( n.LT.0 ) THEN
224 info = -4
225 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq ) THEN
226 info = -5
227 ELSE IF( n2.LT.0 ) THEN
228 info = -6
229 ELSE IF( ldq.LT.max( 1, nq ) ) THEN
230 info = -8
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -10
233 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
234 info = -12
235 END IF
236*
237 IF( info.EQ.0 ) THEN
238 lwkopt = m*n
239 work( 1 ) = cmplx( lwkopt )
240 END IF
241*
242 IF( info.NE.0 ) THEN
243 CALL xerbla( 'CUNM22', -info )
244 RETURN
245 ELSE IF( lquery ) THEN
246 RETURN
247 END IF
248*
249* Quick return if possible
250*
251 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
252 work( 1 ) = 1
253 RETURN
254 END IF
255*
256* Degenerate cases (N1 = 0 or N2 = 0) are handled using CTRMM.
257*
258 IF( n1.EQ.0 ) THEN
259 CALL ctrmm( side, 'Upper', trans, 'Non-Unit', m, n, one,
260 $ q, ldq, c, ldc )
261 work( 1 ) = one
262 RETURN
263 ELSE IF( n2.EQ.0 ) THEN
264 CALL ctrmm( side, 'Lower', trans, 'Non-Unit', m, n, one,
265 $ q, ldq, c, ldc )
266 work( 1 ) = one
267 RETURN
268 END IF
269*
270* Compute the largest chunk size available from the workspace.
271*
272 nb = max( 1, min( lwork, lwkopt ) / nq )
273*
274 IF( left ) THEN
275 IF( notran ) THEN
276 DO i = 1, n, nb
277 len = min( nb, n-i+1 )
278 ldwork = m
279*
280* Multiply bottom part of C by Q12.
281*
282 CALL clacpy( 'All', n1, len, c( n2+1, i ), ldc, work,
283 $ ldwork )
284 CALL ctrmm( 'Left', 'Lower', 'No Transpose', 'Non-Unit',
285 $ n1, len, one, q( 1, n2+1 ), ldq, work,
286 $ ldwork )
287*
288* Multiply top part of C by Q11.
289*
290 CALL cgemm( 'No Transpose', 'No Transpose', n1, len, n2,
291 $ one, q, ldq, c( 1, i ), ldc, one, work,
292 $ ldwork )
293*
294* Multiply top part of C by Q21.
295*
296 CALL clacpy( 'All', n2, len, c( 1, i ), ldc,
297 $ work( n1+1 ), ldwork )
298 CALL ctrmm( 'Left', 'Upper', 'No Transpose', 'Non-Unit',
299 $ n2, len, one, q( n1+1, 1 ), ldq,
300 $ work( n1+1 ), ldwork )
301*
302* Multiply bottom part of C by Q22.
303*
304 CALL cgemm( 'No Transpose', 'No Transpose', n2, len, n1,
305 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
306 $ one, work( n1+1 ), ldwork )
307*
308* Copy everything back.
309*
310 CALL clacpy( 'All', m, len, work, ldwork, c( 1, i ),
311 $ ldc )
312 END DO
313 ELSE
314 DO i = 1, n, nb
315 len = min( nb, n-i+1 )
316 ldwork = m
317*
318* Multiply bottom part of C by Q21**H.
319*
320 CALL clacpy( 'All', n2, len, c( n1+1, i ), ldc, work,
321 $ ldwork )
322 CALL ctrmm( 'Left', 'Upper', 'Conjugate', 'Non-Unit',
323 $ n2, len, one, q( n1+1, 1 ), ldq, work,
324 $ ldwork )
325*
326* Multiply top part of C by Q11**H.
327*
328 CALL cgemm( 'Conjugate', 'No Transpose', n2, len, n1,
329 $ one, q, ldq, c( 1, i ), ldc, one, work,
330 $ ldwork )
331*
332* Multiply top part of C by Q12**H.
333*
334 CALL clacpy( 'All', n1, len, c( 1, i ), ldc,
335 $ work( n2+1 ), ldwork )
336 CALL ctrmm( 'Left', 'Lower', 'Conjugate', 'Non-Unit',
337 $ n1, len, one, q( 1, n2+1 ), ldq,
338 $ work( n2+1 ), ldwork )
339*
340* Multiply bottom part of C by Q22**H.
341*
342 CALL cgemm( 'Conjugate', 'No Transpose', n1, len, n2,
343 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
344 $ one, work( n2+1 ), ldwork )
345*
346* Copy everything back.
347*
348 CALL clacpy( 'All', m, len, work, ldwork, c( 1, i ),
349 $ ldc )
350 END DO
351 END IF
352 ELSE
353 IF( notran ) THEN
354 DO i = 1, m, nb
355 len = min( nb, m-i+1 )
356 ldwork = len
357*
358* Multiply right part of C by Q21.
359*
360 CALL clacpy( 'All', len, n2, c( i, n1+1 ), ldc, work,
361 $ ldwork )
362 CALL ctrmm( 'Right', 'Upper', 'No Transpose', 'Non-Unit',
363 $ len, n2, one, q( n1+1, 1 ), ldq, work,
364 $ ldwork )
365*
366* Multiply left part of C by Q11.
367*
368 CALL cgemm( 'No Transpose', 'No Transpose', len, n2, n1,
369 $ one, c( i, 1 ), ldc, q, ldq, one, work,
370 $ ldwork )
371*
372* Multiply left part of C by Q12.
373*
374 CALL clacpy( 'All', len, n1, c( i, 1 ), ldc,
375 $ work( 1 + n2*ldwork ), ldwork )
376 CALL ctrmm( 'Right', 'Lower', 'No Transpose', 'Non-Unit',
377 $ len, n1, one, q( 1, n2+1 ), ldq,
378 $ work( 1 + n2*ldwork ), ldwork )
379*
380* Multiply right part of C by Q22.
381*
382 CALL cgemm( 'No Transpose', 'No Transpose', len, n1, n2,
383 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
384 $ one, work( 1 + n2*ldwork ), ldwork )
385*
386* Copy everything back.
387*
388 CALL clacpy( 'All', len, n, work, ldwork, c( i, 1 ),
389 $ ldc )
390 END DO
391 ELSE
392 DO i = 1, m, nb
393 len = min( nb, m-i+1 )
394 ldwork = len
395*
396* Multiply right part of C by Q12**H.
397*
398 CALL clacpy( 'All', len, n1, c( i, n2+1 ), ldc, work,
399 $ ldwork )
400 CALL ctrmm( 'Right', 'Lower', 'Conjugate', 'Non-Unit',
401 $ len, n1, one, q( 1, n2+1 ), ldq, work,
402 $ ldwork )
403*
404* Multiply left part of C by Q11**H.
405*
406 CALL cgemm( 'No Transpose', 'Conjugate', len, n1, n2,
407 $ one, c( i, 1 ), ldc, q, ldq, one, work,
408 $ ldwork )
409*
410* Multiply left part of C by Q21**H.
411*
412 CALL clacpy( 'All', len, n2, c( i, 1 ), ldc,
413 $ work( 1 + n1*ldwork ), ldwork )
414 CALL ctrmm( 'Right', 'Upper', 'Conjugate', 'Non-Unit',
415 $ len, n2, one, q( n1+1, 1 ), ldq,
416 $ work( 1 + n1*ldwork ), ldwork )
417*
418* Multiply right part of C by Q22**H.
419*
420 CALL cgemm( 'No Transpose', 'Conjugate', len, n2, n1,
421 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
422 $ one, work( 1 + n1*ldwork ), ldwork )
423*
424* Copy everything back.
425*
426 CALL clacpy( 'All', len, n, work, ldwork, c( i, 1 ),
427 $ ldc )
428 END DO
429 END IF
430 END IF
431*
432 work( 1 ) = cmplx( lwkopt )
433 RETURN
434*
435* End of CUNM22
436*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:188
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177
Here is the call graph for this function:
Here is the caller graph for this function: