src/LAPACK/zunm2r.f

   1       SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
   2      $                   WORK, INFO )
   3 *
   4 *  -- LAPACK routine (version 3.1) --
   5 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
   6 *     November 2006
   7 *
   8 *     .. Scalar Arguments ..
   9       CHARACTER          SIDE, TRANS
  10       INTEGER            INFO, K, LDA, LDC, M, N
  11 *     ..
  12 *     .. Array Arguments ..
  13       COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
  14 *     ..
  15 *
  16 *  Purpose
  17 *  =======
  18 *
  19 *  ZUNM2R overwrites the general complex m-by-n matrix C with
  20 *
  21 *        Q * C  if SIDE = 'L' and TRANS = 'N', or
  22 *
  23 *        Q'* C  if SIDE = 'L' and TRANS = 'C', or
  24 *
  25 *        C * Q  if SIDE = 'R' and TRANS = 'N', or
  26 *
  27 *        C * Q' if SIDE = 'R' and TRANS = 'C',
  28 *
  29 *  where Q is a complex unitary matrix defined as the product of k
  30 *  elementary reflectors
  31 *
  32 *        Q = H(1) H(2) . . . H(k)
  33 *
  34 *  as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
  35 *  if SIDE = 'R'.
  36 *
  37 *  Arguments
  38 *  =========
  39 *
  40 *  SIDE    (input) CHARACTER*1
  41 *          = 'L': apply Q or Q' from the Left
  42 *          = 'R': apply Q or Q' from the Right
  43 *
  44 *  TRANS   (input) CHARACTER*1
  45 *          = 'N': apply Q  (No transpose)
  46 *          = 'C': apply Q' (Conjugate transpose)
  47 *
  48 *  M       (input) INTEGER
  49 *          The number of rows of the matrix C. M >= 0.
  50 *
  51 *  N       (input) INTEGER
  52 *          The number of columns of the matrix C. N >= 0.
  53 *
  54 *  K       (input) INTEGER
  55 *          The number of elementary reflectors whose product defines
  56 *          the matrix Q.
  57 *          If SIDE = 'L', M >= K >= 0;
  58 *          if SIDE = 'R', N >= K >= 0.
  59 *
  60 *  A       (input) COMPLEX*16 array, dimension (LDA,K)
  61 *          The i-th column must contain the vector which defines the
  62 *          elementary reflector H(i), for i = 1,2,...,k, as returned by
  63 *          ZGEQRF in the first k columns of its array argument A.
  64 *          A is modified by the routine but restored on exit.
  65 *
  66 *  LDA     (input) INTEGER
  67 *          The leading dimension of the array A.
  68 *          If SIDE = 'L', LDA >= max(1,M);
  69 *          if SIDE = 'R', LDA >= max(1,N).
  70 *
  71 *  TAU     (input) COMPLEX*16 array, dimension (K)
  72 *          TAU(i) must contain the scalar factor of the elementary
  73 *          reflector H(i), as returned by ZGEQRF.
  74 *
  75 *  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
  76 *          On entry, the m-by-n matrix C.
  77 *          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
  78 *
  79 *  LDC     (input) INTEGER
  80 *          The leading dimension of the array C. LDC >= max(1,M).
  81 *
  82 *  WORK    (workspace) COMPLEX*16 array, dimension
  83 *                                   (N) if SIDE = 'L',
  84 *                                   (M) if SIDE = 'R'
  85 *
  86 *  INFO    (output) INTEGER
  87 *          = 0: successful exit
  88 *          < 0: if INFO = -i, the i-th argument had an illegal value
  89 *
  90 *  =====================================================================
  91 *
  92 *     .. Parameters ..
  93       COMPLEX*16         ONE
  94       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
  95 *     ..
  96 *     .. Local Scalars ..
  97       LOGICAL            LEFT, NOTRAN
  98       INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
  99       COMPLEX*16         AII, TAUI
 100 *     ..
 101 *     .. External Functions ..
 102       LOGICAL            LSAME
 103       EXTERNAL           LSAME
 104 *     ..
 105 *     .. External Subroutines ..
 106       EXTERNAL           XERBLA, ZLARF
 107 *     ..
 108 *     .. Intrinsic Functions ..
 109       INTRINSIC          DCONJG, MAX
 110 *     ..
 111 *     .. Executable Statements ..
 112 *
 113 *     Test the input arguments
 114 *
 115       INFO = 0
 116       LEFT = LSAME( SIDE, 'L' )
 117       NOTRAN = LSAME( TRANS, 'N' )
 118 *
 119 *     NQ is the order of Q
 120 *
 121       IF( LEFT ) THEN
 122          NQ = M
 123       ELSE
 124          NQ = N
 125       END IF
 126       IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
 127          INFO = -1
 128       ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
 129          INFO = -2
 130       ELSE IF( M.LT.0 ) THEN
 131          INFO = -3
 132       ELSE IF( N.LT.0 ) THEN
 133          INFO = -4
 134       ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
 135          INFO = -5
 136       ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
 137          INFO = -7
 138       ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
 139          INFO = -10
 140       END IF
 141       IF( INFO.NE.0 ) THEN
 142          CALL XERBLA( 'ZUNM2R', -INFO )
 143          RETURN
 144       END IF
 145 *
 146 *     Quick return if possible
 147 *
 148       IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
 149      $   RETURN
 150 *
 151       IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
 152          I1 = 1
 153          I2 = K
 154          I3 = 1
 155       ELSE
 156          I1 = K
 157          I2 = 1
 158          I3 = -1
 159       END IF
 160 *
 161       IF( LEFT ) THEN
 162          NI = N
 163          JC = 1
 164       ELSE
 165          MI = M
 166          IC = 1
 167       END IF
 168 *
 169       DO 10 I = I1, I2, I3
 170          IF( LEFT ) THEN
 171 *
 172 *           H(i) or H(i)' is applied to C(i:m,1:n)
 173 *
 174             MI = M - I + 1
 175             IC = I
 176          ELSE
 177 *
 178 *           H(i) or H(i)' is applied to C(1:m,i:n)
 179 *
 180             NI = N - I + 1
 181             JC = I
 182          END IF
 183 *
 184 *        Apply H(i) or H(i)'
 185 *
 186          IF( NOTRAN ) THEN
 187             TAUI = TAU( I )
 188          ELSE
 189             TAUI = DCONJG( TAU( I ) )
 190          END IF
 191          AII = A( I, I )
 192          A( I, I ) = ONE
 193          CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
 194      $               WORK )
 195          A( I, I ) = AII
 196    10 CONTINUE
 197       RETURN
 198 *
 199 *     End of ZUNM2R
 200 *
 201       END