1
       2
       3
       4
       5
       6
       7
       8
       9
      10
      11
      12
      13
      14
      15
      16
      17
      18
      19
      20
      21
      22
      23
      24
      25
      26
      27
      28
      29
      30
      31
      32
      33
      34
      35
      36
      37
      38
      39
      40
      41
      42
      43
      44
      45
      46
      47
      48
      49
      50
      51
      52
      53
      54
      55
      56
      57
      58
      59
      60
      61
      62
      63
      64
      65
      66
      67
      68
      69
      70
      71
      72
      73
      74
      75
      76
      77
      78
      79
      80
      81
      82
      83
      84
      85
      86
      87
      88
      89
      90
      91
      92
      93
      94
      95
      96
      97
      98
      99
     100
     101
     102
     103
     104
     105
     106
     107
     108
     109
     110
     111
     112
     113
     114
     115
     116
     117
     118
     119
     120
     121
     122
     123
     124
     125
     126
     127
     128
     129
     130
     131
     132
     133
     134
     135
     136
     137
     138
     139
     140
     141
     142
     143
     144
     145
     146
     147
     148
     149
     150
     151
     152
     153
     154
     155
     156
     157
     158
     159
     160
     161
     162
     163
     164
     165
     166
     167
     168
      SUBROUTINE CRQT02MNKAAFQRLDATAUWORKLWORK,
     $                   RWORKRESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            KLDALWORKMN
*     ..
*     .. Array Arguments ..
      REAL               RESULT* ), RWORK* )
      COMPLEX            ALDA* ), AFLDA* ), QLDA* ),
     $                   RLDA* ), TAU* ), WORKLWORK )
*     ..
*
*  Purpose
*  =======
*
*  CRQT02 tests CUNGRQ, which generates an m-by-n matrix Q with
*  orthonornmal rows that is defined as the product of k elementary
*  reflectors.
*
*  Given the RQ factorization of an m-by-n matrix A, CRQT02 generates
*  the orthogonal matrix Q defined by the factorization of the last k
*  rows of A; it compares R(m-k+1:m,n-m+1:n) with
*  A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are
*  orthonormal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix Q to be generated.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix Q to be generated.
*          N >= M >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines the
*          matrix Q. M >= K >= 0.
*
*  A       (input) COMPLEX array, dimension (LDA,N)
*          The m-by-n matrix A which was factorized by CRQT01.
*
*  AF      (input) COMPLEX array, dimension (LDA,N)
*          Details of the RQ factorization of A, as returned by CGERQF.
*          See CGERQF for further details.
*
*  Q       (workspace) COMPLEX array, dimension (LDA,N)
*
*  R       (workspace) COMPLEX array, dimension (LDA,M)
*
*  LDA     (input) INTEGER
*          The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*
*  TAU     (input) COMPLEX array, dimension (M)
*          The scalar factors of the elementary reflectors corresponding
*          to the RQ factorization in AF.
*
*  WORK    (workspace) COMPLEX array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*
*  RWORK   (workspace) REAL array, dimension (M)
*
*  RESULT  (output) REAL array, dimension (2)
*          The test ratios:
*          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
*          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZEROONE
      PARAMETER          ( ZERO = 0.0E+0ONE = 1.0E+0 )
      COMPLEX            ROGUE
      PARAMETER          ( ROGUE = ( -1.0E+10-1.0E+10 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ANORMEPSRESID
*     ..
*     .. External Functions ..
      REAL               CLANGECLANSYSLAMCH
      EXTERNAL           CLANGECLANSYSLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMMCHERKCLACPYCLASETCUNGRQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLXMAXREAL
*     ..
*     .. Scalars in Common ..
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IFM.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         RESULT1 ) = ZERO
         RESULT2 ) = ZERO
         RETURN
      END IF
*
      EPS = SLAMCH'Epsilon' )
*
*     Copy the last k rows of the factorization to the array Q
*
      CALL CLASET'Full'MNROGUEROGUEQLDA )
      IFK.LT.N )
     $   CALL CLACPY'Full'KN-KAFM-K+11 ), LDA,
     $                QM-K+11 ), LDA )
      IFK.GT.1 )
     $   CALL CLACPY'Lower'K-1K-1AFM-K+2N-K+1 ), LDA,
     $                QM-K+2N-K+1 ), LDA )
*
*     Generate the last n rows of the matrix Q
*
      SRNAMT = 'CUNGRQ'
      CALL CUNGRQMNKQLDATAUM-K+1 ), WORKLWORKINFO )
*
*     Copy R(m-k+1:m,n-m+1:n)
*
      CALL CLASET'Full'KMCMPLXZERO ), CMPLXZERO ),
     $             RM-K+1N-M+1 ), LDA )
      CALL CLACPY'Upper'KKAFM-K+1N-K+1 ), LDA,
     $             RM-K+1N-K+1 ), LDA )
*
*     Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)'
*
      CALL CGEMM'No transpose''Conjugate transpose'KMN,
     $            CMPLX-ONE ), AM-K+11 ), LDAQLDA,
     $            CMPLXONE ), RM-K+1N-M+1 ), LDA )
*
*     Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) .
*
      ANORM = CLANGE'1'KNAM-K+11 ), LDARWORK )
      RESID = CLANGE'1'KMRM-K+1N-M+1 ), LDARWORK )
      IFANORM.GT.ZERO ) THEN
         RESULT1 ) = ( ( RESID / REALMAX1N ) ) ) / ANORM ) / EPS
      ELSE
         RESULT1 ) = ZERO
      END IF
*
*     Compute I - Q*Q'
*
      CALL CLASET'Full'MMCMPLXZERO ), CMPLXONE ), RLDA )
      CALL CHERK'Upper''No transpose'MN-ONEQLDAONER,
     $            LDA )
*
*     Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
      RESID = CLANSY'1''Upper'MRLDARWORK )
*
      RESULT2 ) = ( RESID / REALMAX1N ) ) ) / EPS
*
      RETURN
*
*     End of CRQT02
*
      END