LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:187
subroutine ctrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRMM
Definition: ctrmm.f:177
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
Here is the call graph for this function:
Here is the caller graph for this function: