![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SGESC2 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SGESC2 + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgesc2.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgesc2.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgesc2.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) 00022 * 00023 * .. Scalar Arguments .. 00024 * INTEGER LDA, N 00025 * REAL SCALE 00026 * .. 00027 * .. Array Arguments .. 00028 * INTEGER IPIV( * ), JPIV( * ) 00029 * REAL A( LDA, * ), RHS( * ) 00030 * .. 00031 * 00032 * 00033 *> \par Purpose: 00034 * ============= 00035 *> 00036 *> \verbatim 00037 *> 00038 *> SGESC2 solves a system of linear equations 00039 *> 00040 *> A * X = scale* RHS 00041 *> 00042 *> with a general N-by-N matrix A using the LU factorization with 00043 *> complete pivoting computed by SGETC2. 00044 *> \endverbatim 00045 * 00046 * Arguments: 00047 * ========== 00048 * 00049 *> \param[in] N 00050 *> \verbatim 00051 *> N is INTEGER 00052 *> The order of the matrix A. 00053 *> \endverbatim 00054 *> 00055 *> \param[in] A 00056 *> \verbatim 00057 *> A is REAL array, dimension (LDA,N) 00058 *> On entry, the LU part of the factorization of the n-by-n 00059 *> matrix A computed by SGETC2: A = P * L * U * Q 00060 *> \endverbatim 00061 *> 00062 *> \param[in] LDA 00063 *> \verbatim 00064 *> LDA is INTEGER 00065 *> The leading dimension of the array A. LDA >= max(1, N). 00066 *> \endverbatim 00067 *> 00068 *> \param[in,out] RHS 00069 *> \verbatim 00070 *> RHS is REAL array, dimension (N). 00071 *> On entry, the right hand side vector b. 00072 *> On exit, the solution vector X. 00073 *> \endverbatim 00074 *> 00075 *> \param[in] IPIV 00076 *> \verbatim 00077 *> IPIV is INTEGER array, dimension (N). 00078 *> The pivot indices; for 1 <= i <= N, row i of the 00079 *> matrix has been interchanged with row IPIV(i). 00080 *> \endverbatim 00081 *> 00082 *> \param[in] JPIV 00083 *> \verbatim 00084 *> JPIV is INTEGER array, dimension (N). 00085 *> The pivot indices; for 1 <= j <= N, column j of the 00086 *> matrix has been interchanged with column JPIV(j). 00087 *> \endverbatim 00088 *> 00089 *> \param[out] SCALE 00090 *> \verbatim 00091 *> SCALE is REAL 00092 *> On exit, SCALE contains the scale factor. SCALE is chosen 00093 *> 0 <= SCALE <= 1 to prevent owerflow in the solution. 00094 *> \endverbatim 00095 * 00096 * Authors: 00097 * ======== 00098 * 00099 *> \author Univ. of Tennessee 00100 *> \author Univ. of California Berkeley 00101 *> \author Univ. of Colorado Denver 00102 *> \author NAG Ltd. 00103 * 00104 *> \date November 2011 00105 * 00106 *> \ingroup realGEauxiliary 00107 * 00108 *> \par Contributors: 00109 * ================== 00110 *> 00111 *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, 00112 *> Umea University, S-901 87 Umea, Sweden. 00113 * 00114 * ===================================================================== 00115 SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) 00116 * 00117 * -- LAPACK auxiliary routine (version 3.4.0) -- 00118 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00119 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00120 * November 2011 00121 * 00122 * .. Scalar Arguments .. 00123 INTEGER LDA, N 00124 REAL SCALE 00125 * .. 00126 * .. Array Arguments .. 00127 INTEGER IPIV( * ), JPIV( * ) 00128 REAL A( LDA, * ), RHS( * ) 00129 * .. 00130 * 00131 * ===================================================================== 00132 * 00133 * .. Parameters .. 00134 REAL ONE, TWO 00135 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) 00136 * .. 00137 * .. Local Scalars .. 00138 INTEGER I, J 00139 REAL BIGNUM, EPS, SMLNUM, TEMP 00140 * .. 00141 * .. External Subroutines .. 00142 EXTERNAL SLABAD, SLASWP, SSCAL 00143 * .. 00144 * .. External Functions .. 00145 INTEGER ISAMAX 00146 REAL SLAMCH 00147 EXTERNAL ISAMAX, SLAMCH 00148 * .. 00149 * .. Intrinsic Functions .. 00150 INTRINSIC ABS 00151 * .. 00152 * .. Executable Statements .. 00153 * 00154 * Set constant to control owerflow 00155 * 00156 EPS = SLAMCH( 'P' ) 00157 SMLNUM = SLAMCH( 'S' ) / EPS 00158 BIGNUM = ONE / SMLNUM 00159 CALL SLABAD( SMLNUM, BIGNUM ) 00160 * 00161 * Apply permutations IPIV to RHS 00162 * 00163 CALL SLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) 00164 * 00165 * Solve for L part 00166 * 00167 DO 20 I = 1, N - 1 00168 DO 10 J = I + 1, N 00169 RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 00170 10 CONTINUE 00171 20 CONTINUE 00172 * 00173 * Solve for U part 00174 * 00175 SCALE = ONE 00176 * 00177 * Check for scaling 00178 * 00179 I = ISAMAX( N, RHS, 1 ) 00180 IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN 00181 TEMP = ( ONE / TWO ) / ABS( RHS( I ) ) 00182 CALL SSCAL( N, TEMP, RHS( 1 ), 1 ) 00183 SCALE = SCALE*TEMP 00184 END IF 00185 * 00186 DO 40 I = N, 1, -1 00187 TEMP = ONE / A( I, I ) 00188 RHS( I ) = RHS( I )*TEMP 00189 DO 30 J = I + 1, N 00190 RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 00191 30 CONTINUE 00192 40 CONTINUE 00193 * 00194 * Apply permutations JPIV to the solution (RHS) 00195 * 00196 CALL SLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) 00197 RETURN 00198 * 00199 * End of SGESC2 00200 * 00201 END