|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 REAL FUNCTION SQRT17( TRANS, IRESID, M, N, NRHS, A, 00002 $ LDA, X, LDX, B, LDB, C, WORK, LWORK ) 00003 * 00004 * -- LAPACK test routine (version 3.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER TRANS 00010 INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS 00011 * .. 00012 * .. Array Arguments .. 00013 REAL A( LDA, * ), B( LDB, * ), C( LDB, * ), 00014 $ WORK( LWORK ), X( LDX, * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * SQRT17 computes the ratio 00021 * 00022 * || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps) 00023 * 00024 * where R = op(A)*X - B, op(A) is A or A', and 00025 * 00026 * alpha = ||B|| if IRESID = 1 (zero-residual problem) 00027 * alpha = ||R|| if IRESID = 2 (otherwise). 00028 * 00029 * Arguments 00030 * ========= 00031 * 00032 * TRANS (input) CHARACTER*1 00033 * Specifies whether or not the transpose of A is used. 00034 * = 'N': No transpose, op(A) = A. 00035 * = 'T': Transpose, op(A) = A'. 00036 * 00037 * IRESID (input) INTEGER 00038 * IRESID = 1 indicates zero-residual problem. 00039 * IRESID = 2 indicates non-zero residual. 00040 * 00041 * M (input) INTEGER 00042 * The number of rows of the matrix A. 00043 * If TRANS = 'N', the number of rows of the matrix B. 00044 * If TRANS = 'T', the number of rows of the matrix X. 00045 * 00046 * N (input) INTEGER 00047 * The number of columns of the matrix A. 00048 * If TRANS = 'N', the number of rows of the matrix X. 00049 * If TRANS = 'T', the number of rows of the matrix B. 00050 * 00051 * NRHS (input) INTEGER 00052 * The number of columns of the matrices X and B. 00053 * 00054 * A (input) REAL array, dimension (LDA,N) 00055 * The m-by-n matrix A. 00056 * 00057 * LDA (input) INTEGER 00058 * The leading dimension of the array A. LDA >= M. 00059 * 00060 * X (input) REAL array, dimension (LDX,NRHS) 00061 * If TRANS = 'N', the n-by-nrhs matrix X. 00062 * If TRANS = 'T', the m-by-nrhs matrix X. 00063 * 00064 * LDX (input) INTEGER 00065 * The leading dimension of the array X. 00066 * If TRANS = 'N', LDX >= N. 00067 * If TRANS = 'T', LDX >= M. 00068 * 00069 * B (input) REAL array, dimension (LDB,NRHS) 00070 * If TRANS = 'N', the m-by-nrhs matrix B. 00071 * If TRANS = 'T', the n-by-nrhs matrix B. 00072 * 00073 * LDB (input) INTEGER 00074 * The leading dimension of the array B. 00075 * If TRANS = 'N', LDB >= M. 00076 * If TRANS = 'T', LDB >= N. 00077 * 00078 * C (workspace) REAL array, dimension (LDB,NRHS) 00079 * 00080 * WORK (workspace) REAL array, dimension (LWORK) 00081 * 00082 * LWORK (input) INTEGER 00083 * The length of the array WORK. LWORK >= NRHS*(M+N). 00084 * 00085 * ===================================================================== 00086 * 00087 * .. Parameters .. 00088 REAL ZERO, ONE 00089 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) 00090 * .. 00091 * .. Local Scalars .. 00092 INTEGER INFO, ISCL, NCOLS, NROWS 00093 REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX, 00094 $ SMLNUM 00095 * .. 00096 * .. Local Arrays .. 00097 REAL RWORK( 1 ) 00098 * .. 00099 * .. External Functions .. 00100 LOGICAL LSAME 00101 REAL SLAMCH, SLANGE 00102 EXTERNAL LSAME, SLAMCH, SLANGE 00103 * .. 00104 * .. External Subroutines .. 00105 EXTERNAL SGEMM, SLACPY, SLASCL, XERBLA 00106 * .. 00107 * .. Intrinsic Functions .. 00108 INTRINSIC MAX, REAL 00109 * .. 00110 * .. Executable Statements .. 00111 * 00112 SQRT17 = ZERO 00113 * 00114 IF( LSAME( TRANS, 'N' ) ) THEN 00115 NROWS = M 00116 NCOLS = N 00117 ELSE IF( LSAME( TRANS, 'T' ) ) THEN 00118 NROWS = N 00119 NCOLS = M 00120 ELSE 00121 CALL XERBLA( 'SQRT17', 1 ) 00122 RETURN 00123 END IF 00124 * 00125 IF( LWORK.LT.NCOLS*NRHS ) THEN 00126 CALL XERBLA( 'SQRT17', 13 ) 00127 RETURN 00128 END IF 00129 * 00130 IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.LE.0 ) THEN 00131 RETURN 00132 END IF 00133 * 00134 NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK ) 00135 SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' ) 00136 BIGNUM = ONE / SMLNUM 00137 ISCL = 0 00138 * 00139 * compute residual and scale it 00140 * 00141 CALL SLACPY( 'All', NROWS, NRHS, B, LDB, C, LDB ) 00142 CALL SGEMM( TRANS, 'No transpose', NROWS, NRHS, NCOLS, -ONE, A, 00143 $ LDA, X, LDX, ONE, C, LDB ) 00144 NORMRS = SLANGE( 'Max', NROWS, NRHS, C, LDB, RWORK ) 00145 IF( NORMRS.GT.SMLNUM ) THEN 00146 ISCL = 1 00147 CALL SLASCL( 'General', 0, 0, NORMRS, ONE, NROWS, NRHS, C, LDB, 00148 $ INFO ) 00149 END IF 00150 * 00151 * compute R'*A 00152 * 00153 CALL SGEMM( 'Transpose', TRANS, NRHS, NCOLS, NROWS, ONE, C, LDB, 00154 $ A, LDA, ZERO, WORK, NRHS ) 00155 * 00156 * compute and properly scale error 00157 * 00158 ERR = SLANGE( 'One-norm', NRHS, NCOLS, WORK, NRHS, RWORK ) 00159 IF( NORMA.NE.ZERO ) 00160 $ ERR = ERR / NORMA 00161 * 00162 IF( ISCL.EQ.1 ) 00163 $ ERR = ERR*NORMRS 00164 * 00165 IF( IRESID.EQ.1 ) THEN 00166 NORMB = SLANGE( 'One-norm', NROWS, NRHS, B, LDB, RWORK ) 00167 IF( NORMB.NE.ZERO ) 00168 $ ERR = ERR / NORMB 00169 ELSE 00170 NORMX = SLANGE( 'One-norm', NCOLS, NRHS, X, LDX, RWORK ) 00171 IF( NORMX.NE.ZERO ) 00172 $ ERR = ERR / NORMX 00173 END IF 00174 * 00175 SQRT17 = ERR / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N, NRHS ) ) ) 00176 RETURN 00177 * 00178 * End of SQRT17 00179 * 00180 END
1.7.3 
