da/d5d/cqrt13_8f_source.html

00001       SUBROUTINE CQRT13( SCALE, M, N, A, LDA, NORMA, ISEED )
00002 *
00003 *  -- LAPACK test routine (version 3.1) --
00004 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00005 *     November 2006
00006 *
00007 *     .. Scalar Arguments ..
00008       INTEGER            LDA, M, N, SCALE
00009       REAL               NORMA
00010 *     ..
00011 *     .. Array Arguments ..
00012       INTEGER            ISEED( 4 )
00013       COMPLEX            A( LDA, * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  CQRT13 generates a full-rank matrix that may be scaled to have large
00020 *  or small norm.
00021 *
00022 *  Arguments
00023 *  =========
00024 *
00025 *  SCALE   (input) INTEGER
00026 *          SCALE = 1: normally scaled matrix
00027 *          SCALE = 2: matrix scaled up
00028 *          SCALE = 3: matrix scaled down
00029 *
00030 *  M       (input) INTEGER
00031 *          The number of rows of the matrix A.
00032 *
00033 *  N       (input) INTEGER
00034 *          The number of columns of A.
00035 *
00036 *  A       (output) COMPLEX array, dimension (LDA,N)
00037 *          The M-by-N matrix A.
00038 *
00039 *  LDA     (input) INTEGER
00040 *          The leading dimension of the array A.
00041 *
00042 *  NORMA   (output) REAL
00043 *          The one-norm of A.
00044 *
00045 *  ISEED   (input/output) integer array, dimension (4)
00046 *          Seed for random number generator
00047 *
00048 *  =====================================================================
00049 *
00050 *     .. Parameters ..
00051       REAL               ONE
00052       PARAMETER          ( ONE = 1.0E0 )
00053 *     ..
00054 *     .. Local Scalars ..
00055       INTEGER            INFO, J
00056       REAL               BIGNUM, SMLNUM
00057 *     ..
00058 *     .. External Functions ..
00059       REAL               CLANGE, SCASUM, SLAMCH
00060       EXTERNAL           CLANGE, SCASUM, SLAMCH
00061 *     ..
00062 *     .. External Subroutines ..
00063       EXTERNAL           CLARNV, CLASCL, SLABAD
00064 *     ..
00065 *     .. Intrinsic Functions ..
00066       INTRINSIC          CMPLX, REAL, SIGN
00067 *     ..
00068 *     .. Local Arrays ..
00069       REAL               DUMMY( 1 )
00070 *     ..
00071 *     .. Executable Statements ..
00072 *
00073       IF( M.LE.0 .OR. N.LE.0 )
00074      $   RETURN
00075 *
00076 *     benign matrix
00077 *
00078       DO 10 J = 1, N
00079          CALL CLARNV( 2, ISEED, M, A( 1, J ) )
00080          IF( J.LE.M ) THEN
00081             A( J, J ) = A( J, J ) + CMPLX( SIGN( SCASUM( M, A( 1, J ),
00082      $                  1 ), REAL( A( J, J ) ) ) )
00083          END IF
00084    10 CONTINUE
00085 *
00086 *     scaled versions
00087 *
00088       IF( SCALE.NE.1 ) THEN
00089          NORMA = CLANGE( 'Max', M, N, A, LDA, DUMMY )
00090          SMLNUM = SLAMCH( 'Safe minimum' )
00091          BIGNUM = ONE / SMLNUM
00092          CALL SLABAD( SMLNUM, BIGNUM )
00093          SMLNUM = SMLNUM / SLAMCH( 'Epsilon' )
00094          BIGNUM = ONE / SMLNUM
00095 *
00096          IF( SCALE.EQ.2 ) THEN
00097 *
00098 *           matrix scaled up
00099 *
00100             CALL CLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, LDA,
00101      $                   INFO )
00102          ELSE IF( SCALE.EQ.3 ) THEN
00103 *
00104 *           matrix scaled down
00105 *
00106             CALL CLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, LDA,
00107      $                   INFO )
00108          END IF
00109       END IF
00110 *
00111       NORMA = CLANGE( 'One-norm', M, N, A, LDA, DUMMY )
00112       RETURN
00113 *
00114 *     End of CQRT13
00115 *
00116       END