|
- *> \brief \b SQRT03
- *
- * =========== DOCUMENTATION ===========
- *
- * Online html documentation available at
- * http://www.netlib.org/lapack/explore-html/
- *
- * Definition:
- * ===========
- *
- * SUBROUTINE SQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
- * RWORK, RESULT )
- *
- * .. Scalar Arguments ..
- * INTEGER K, LDA, LWORK, M, N
- * ..
- * .. Array Arguments ..
- * REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
- * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
- * $ WORK( LWORK )
- * ..
- *
- *
- *> \par Purpose:
- * =============
- *>
- *> \verbatim
- *>
- *> SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
- *>
- *> SQRT03 compares the results of a call to SORMQR with the results of
- *> forming Q explicitly by a call to SORGQR and then performing matrix
- *> multiplication by a call to SGEMM.
- *> \endverbatim
- *
- * Arguments:
- * ==========
- *
- *> \param[in] M
- *> \verbatim
- *> M is INTEGER
- *> The order of the orthogonal matrix Q. M >= 0.
- *> \endverbatim
- *>
- *> \param[in] N
- *> \verbatim
- *> N is INTEGER
- *> The number of rows or columns of the matrix C; C is m-by-n if
- *> Q is applied from the left, or n-by-m if Q is applied from
- *> the right. N >= 0.
- *> \endverbatim
- *>
- *> \param[in] K
- *> \verbatim
- *> K is INTEGER
- *> The number of elementary reflectors whose product defines the
- *> orthogonal matrix Q. M >= K >= 0.
- *> \endverbatim
- *>
- *> \param[in] AF
- *> \verbatim
- *> AF is REAL array, dimension (LDA,N)
- *> Details of the QR factorization of an m-by-n matrix, as
- *> returned by SGEQRF. See SGEQRF for further details.
- *> \endverbatim
- *>
- *> \param[out] C
- *> \verbatim
- *> C is REAL array, dimension (LDA,N)
- *> \endverbatim
- *>
- *> \param[out] CC
- *> \verbatim
- *> CC is REAL array, dimension (LDA,N)
- *> \endverbatim
- *>
- *> \param[out] Q
- *> \verbatim
- *> Q is REAL array, dimension (LDA,M)
- *> \endverbatim
- *>
- *> \param[in] LDA
- *> \verbatim
- *> LDA is INTEGER
- *> The leading dimension of the arrays AF, C, CC, and Q.
- *> \endverbatim
- *>
- *> \param[in] TAU
- *> \verbatim
- *> TAU is REAL array, dimension (min(M,N))
- *> The scalar factors of the elementary reflectors corresponding
- *> to the QR factorization in AF.
- *> \endverbatim
- *>
- *> \param[out] WORK
- *> \verbatim
- *> WORK is REAL array, dimension (LWORK)
- *> \endverbatim
- *>
- *> \param[in] LWORK
- *> \verbatim
- *> LWORK is INTEGER
- *> The length of WORK. LWORK must be at least M, and should be
- *> M*NB, where NB is the blocksize for this environment.
- *> \endverbatim
- *>
- *> \param[out] RWORK
- *> \verbatim
- *> RWORK is REAL array, dimension (M)
- *> \endverbatim
- *>
- *> \param[out] RESULT
- *> \verbatim
- *> RESULT is REAL array, dimension (4)
- *> The test ratios compare two techniques for multiplying a
- *> random matrix C by an m-by-m orthogonal matrix Q.
- *> RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS )
- *> RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS )
- *> RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
- *> RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
- *> \endverbatim
- *
- * Authors:
- * ========
- *
- *> \author Univ. of Tennessee
- *> \author Univ. of California Berkeley
- *> \author Univ. of Colorado Denver
- *> \author NAG Ltd.
- *
- *> \ingroup single_lin
- *
- * =====================================================================
- SUBROUTINE SQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
- $ RWORK, RESULT )
- *
- * -- LAPACK test routine --
- * -- LAPACK is a software package provided by Univ. of Tennessee, --
- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
- *
- * .. Scalar Arguments ..
- INTEGER K, LDA, LWORK, M, N
- * ..
- * .. Array Arguments ..
- REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
- $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
- $ WORK( LWORK )
- * ..
- *
- * =====================================================================
- *
- * .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E0 )
- REAL ROGUE
- PARAMETER ( ROGUE = -1.0E+10 )
- * ..
- * .. Local Scalars ..
- CHARACTER SIDE, TRANS
- INTEGER INFO, ISIDE, ITRANS, J, MC, NC
- REAL CNORM, EPS, RESID
- * ..
- * .. External Functions ..
- LOGICAL LSAME
- REAL SLAMCH, SLANGE
- EXTERNAL LSAME, SLAMCH, SLANGE
- * ..
- * .. External Subroutines ..
- EXTERNAL SGEMM, SLACPY, SLARNV, SLASET, SORGQR, SORMQR
- * ..
- * .. Local Arrays ..
- INTEGER ISEED( 4 )
- * ..
- * .. Intrinsic Functions ..
- INTRINSIC MAX, REAL
- * ..
- * .. Scalars in Common ..
- CHARACTER*32 SRNAMT
- * ..
- * .. Common blocks ..
- COMMON / SRNAMC / SRNAMT
- * ..
- * .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
- * ..
- * .. Executable Statements ..
- *
- EPS = SLAMCH( 'Epsilon' )
- *
- * Copy the first k columns of the factorization to the array Q
- *
- CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
- CALL SLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
- *
- * Generate the m-by-m matrix Q
- *
- SRNAMT = 'SORGQR'
- CALL SORGQR( M, M, K, Q, LDA, TAU, WORK, LWORK, INFO )
- *
- DO 30 ISIDE = 1, 2
- IF( ISIDE.EQ.1 ) THEN
- SIDE = 'L'
- MC = M
- NC = N
- ELSE
- SIDE = 'R'
- MC = N
- NC = M
- END IF
- *
- * Generate MC by NC matrix C
- *
- DO 10 J = 1, NC
- CALL SLARNV( 2, ISEED, MC, C( 1, J ) )
- 10 CONTINUE
- CNORM = SLANGE( '1', MC, NC, C, LDA, RWORK )
- IF( CNORM.EQ.0.0 )
- $ CNORM = ONE
- *
- DO 20 ITRANS = 1, 2
- IF( ITRANS.EQ.1 ) THEN
- TRANS = 'N'
- ELSE
- TRANS = 'T'
- END IF
- *
- * Copy C
- *
- CALL SLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
- *
- * Apply Q or Q' to C
- *
- SRNAMT = 'SORMQR'
- CALL SORMQR( SIDE, TRANS, MC, NC, K, AF, LDA, TAU, CC, LDA,
- $ WORK, LWORK, INFO )
- *
- * Form explicit product and subtract
- *
- IF( LSAME( SIDE, 'L' ) ) THEN
- CALL SGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
- $ LDA, C, LDA, ONE, CC, LDA )
- ELSE
- CALL SGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
- $ LDA, Q, LDA, ONE, CC, LDA )
- END IF
- *
- * Compute error in the difference
- *
- RESID = SLANGE( '1', MC, NC, CC, LDA, RWORK )
- RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
- $ ( REAL( MAX( 1, M ) )*CNORM*EPS )
- *
- 20 CONTINUE
- 30 CONTINUE
- *
- RETURN
- *
- * End of SQRT03
- *
- END
|