TESTING/MATGEN/clarge.f

   1 *> \brief \b CLARGE
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO )
  12 *
  13 *       .. Scalar Arguments ..
  14 *       INTEGER            INFO, LDA, N
  15 *       ..
  16 *       .. Array Arguments ..
  17 *       INTEGER            ISEED( 4 )
  18 *       COMPLEX            A( LDA, * ), WORK( * )
  19 *       ..
  20 *
  21 *
  22 *> \par Purpose:
  23 *  =============
  24 *>
  25 *> \verbatim
  26 *>
  27 *> CLARGE pre- and post-multiplies a complex general n by n matrix A
  28 *> with a random unitary matrix: A = U*D*U'.
  29 *> \endverbatim
  30 *
  31 *  Arguments:
  32 *  ==========
  33 *
  34 *> \param[in] N
  35 *> \verbatim
  36 *>          N is INTEGER
  37 *>          The order of the matrix A.  N >= 0.
  38 *> \endverbatim
  39 *>
  40 *> \param[in,out] A
  41 *> \verbatim
  42 *>          A is COMPLEX array, dimension (LDA,N)
  43 *>          On entry, the original n by n matrix A.
  44 *>          On exit, A is overwritten by U*A*U' for some random
  45 *>          unitary matrix U.
  46 *> \endverbatim
  47 *>
  48 *> \param[in] LDA
  49 *> \verbatim
  50 *>          LDA is INTEGER
  51 *>          The leading dimension of the array A.  LDA >= N.
  52 *> \endverbatim
  53 *>
  54 *> \param[in,out] ISEED
  55 *> \verbatim
  56 *>          ISEED is INTEGER array, dimension (4)
  57 *>          On entry, the seed of the random number generator; the array
  58 *>          elements must be between 0 and 4095, and ISEED(4) must be
  59 *>          odd.
  60 *>          On exit, the seed is updated.
  61 *> \endverbatim
  62 *>
  63 *> \param[out] WORK
  64 *> \verbatim
  65 *>          WORK is COMPLEX array, dimension (2*N)
  66 *> \endverbatim
  67 *>
  68 *> \param[out] INFO
  69 *> \verbatim
  70 *>          INFO is INTEGER
  71 *>          = 0: successful exit
  72 *>          < 0: if INFO = -i, the i-th argument had an illegal value
  73 *> \endverbatim
  74 *
  75 *  Authors:
  76 *  ========
  77 *
  78 *> \author Univ. of Tennessee
  79 *> \author Univ. of California Berkeley
  80 *> \author Univ. of Colorado Denver
  81 *> \author NAG Ltd.
  82 *
  83 *> \date November 2011
  84 *
  85 *> \ingroup complex_matgen
  86 *
  87 *  =====================================================================
  88       SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO )
  89 *
  90 *  -- LAPACK auxiliary routine (version 3.4.0) --
  91 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  92 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  93 *     November 2011
  94 *
  95 *     .. Scalar Arguments ..
  96       INTEGER            INFO, LDA, N
  97 *     ..
  98 *     .. Array Arguments ..
  99       INTEGER            ISEED( 4 )
 100       COMPLEX            A( LDA, * ), WORK( * )
 101 *     ..
 102 *
 103 *  =====================================================================
 104 *
 105 *     .. Parameters ..
 106       COMPLEX            ZERO, ONE
 107       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
 108      $                   ONE = ( 1.0E+0, 0.0E+0 ) )
 109 *     ..
 110 *     .. Local Scalars ..
 111       INTEGER            I
 112       REAL               WN
 113       COMPLEX            TAU, WA, WB
 114 *     ..
 115 *     .. External Subroutines ..
 116       EXTERNAL           CGEMV, CGERC, CLARNV, CSCAL, XERBLA
 117 *     ..
 118 *     .. Intrinsic Functions ..
 119       INTRINSIC          ABS, MAX, REAL
 120 *     ..
 121 *     .. External Functions ..
 122       REAL               SCNRM2
 123       EXTERNAL           SCNRM2
 124 *     ..
 125 *     .. Executable Statements ..
 126 *
 127 *     Test the input arguments
 128 *
 129       INFO = 0
 130       IF( N.LT.0 ) THEN
 131          INFO = -1
 132       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
 133          INFO = -3
 134       END IF
 135       IF( INFO.LT.0 ) THEN
 136          CALL XERBLA( 'CLARGE', -INFO )
 137          RETURN
 138       END IF
 139 *
 140 *     pre- and post-multiply A by random unitary matrix
 141 *
 142       DO 10 I = N, 1, -1
 143 *
 144 *        generate random reflection
 145 *
 146          CALL CLARNV( 3, ISEED, N-I+1, WORK )
 147          WN = SCNRM2( N-I+1, WORK, 1 )
 148          WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
 149          IF( WN.EQ.ZERO ) THEN
 150             TAU = ZERO
 151          ELSE
 152             WB = WORK( 1 ) + WA
 153             CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
 154             WORK( 1 ) = ONE
 155             TAU = REAL( WB / WA )
 156          END IF
 157 *
 158 *        multiply A(i:n,1:n) by random reflection from the left
 159 *
 160          CALL CGEMV( 'Conjugate transpose', N-I+1, N, ONE, A( I, 1 ),
 161      $               LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
 162          CALL CGERC( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
 163      $               LDA )
 164 *
 165 *        multiply A(1:n,i:n) by random reflection from the right
 166 *
 167          CALL CGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
 168      $               WORK, 1, ZERO, WORK( N+1 ), 1 )
 169          CALL CGERC( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
 170      $               LDA )
 171    10 CONTINUE
 172       RETURN
 173 *
 174 *     End of CLARGE
 175 *
 176       END