![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SGTTS2 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SGTTS2 + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgtts2.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgtts2.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgtts2.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) 00022 * 00023 * .. Scalar Arguments .. 00024 * INTEGER ITRANS, LDB, N, NRHS 00025 * .. 00026 * .. Array Arguments .. 00027 * INTEGER IPIV( * ) 00028 * REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) 00029 * .. 00030 * 00031 * 00032 *> \par Purpose: 00033 * ============= 00034 *> 00035 *> \verbatim 00036 *> 00037 *> SGTTS2 solves one of the systems of equations 00038 *> A*X = B or A**T*X = B, 00039 *> with a tridiagonal matrix A using the LU factorization computed 00040 *> by SGTTRF. 00041 *> \endverbatim 00042 * 00043 * Arguments: 00044 * ========== 00045 * 00046 *> \param[in] ITRANS 00047 *> \verbatim 00048 *> ITRANS is INTEGER 00049 *> Specifies the form of the system of equations. 00050 *> = 0: A * X = B (No transpose) 00051 *> = 1: A**T* X = B (Transpose) 00052 *> = 2: A**T* X = B (Conjugate transpose = Transpose) 00053 *> \endverbatim 00054 *> 00055 *> \param[in] N 00056 *> \verbatim 00057 *> N is INTEGER 00058 *> The order of the matrix A. 00059 *> \endverbatim 00060 *> 00061 *> \param[in] NRHS 00062 *> \verbatim 00063 *> NRHS is INTEGER 00064 *> The number of right hand sides, i.e., the number of columns 00065 *> of the matrix B. NRHS >= 0. 00066 *> \endverbatim 00067 *> 00068 *> \param[in] DL 00069 *> \verbatim 00070 *> DL is REAL array, dimension (N-1) 00071 *> The (n-1) multipliers that define the matrix L from the 00072 *> LU factorization of A. 00073 *> \endverbatim 00074 *> 00075 *> \param[in] D 00076 *> \verbatim 00077 *> D is REAL array, dimension (N) 00078 *> The n diagonal elements of the upper triangular matrix U from 00079 *> the LU factorization of A. 00080 *> \endverbatim 00081 *> 00082 *> \param[in] DU 00083 *> \verbatim 00084 *> DU is REAL array, dimension (N-1) 00085 *> The (n-1) elements of the first super-diagonal of U. 00086 *> \endverbatim 00087 *> 00088 *> \param[in] DU2 00089 *> \verbatim 00090 *> DU2 is REAL array, dimension (N-2) 00091 *> The (n-2) elements of the second super-diagonal of U. 00092 *> \endverbatim 00093 *> 00094 *> \param[in] IPIV 00095 *> \verbatim 00096 *> IPIV is INTEGER array, dimension (N) 00097 *> The pivot indices; for 1 <= i <= n, row i of the matrix was 00098 *> interchanged with row IPIV(i). IPIV(i) will always be either 00099 *> i or i+1; IPIV(i) = i indicates a row interchange was not 00100 *> required. 00101 *> \endverbatim 00102 *> 00103 *> \param[in,out] B 00104 *> \verbatim 00105 *> B is REAL array, dimension (LDB,NRHS) 00106 *> On entry, the matrix of right hand side vectors B. 00107 *> On exit, B is overwritten by the solution vectors X. 00108 *> \endverbatim 00109 *> 00110 *> \param[in] LDB 00111 *> \verbatim 00112 *> LDB is INTEGER 00113 *> The leading dimension of the array B. LDB >= max(1,N). 00114 *> \endverbatim 00115 * 00116 * Authors: 00117 * ======== 00118 * 00119 *> \author Univ. of Tennessee 00120 *> \author Univ. of California Berkeley 00121 *> \author Univ. of Colorado Denver 00122 *> \author NAG Ltd. 00123 * 00124 *> \date November 2011 00125 * 00126 *> \ingroup realOTHERauxiliary 00127 * 00128 * ===================================================================== 00129 SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) 00130 * 00131 * -- LAPACK auxiliary routine (version 3.4.0) -- 00132 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00133 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00134 * November 2011 00135 * 00136 * .. Scalar Arguments .. 00137 INTEGER ITRANS, LDB, N, NRHS 00138 * .. 00139 * .. Array Arguments .. 00140 INTEGER IPIV( * ) 00141 REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) 00142 * .. 00143 * 00144 * ===================================================================== 00145 * 00146 * .. Local Scalars .. 00147 INTEGER I, IP, J 00148 REAL TEMP 00149 * .. 00150 * .. Executable Statements .. 00151 * 00152 * Quick return if possible 00153 * 00154 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 00155 $ RETURN 00156 * 00157 IF( ITRANS.EQ.0 ) THEN 00158 * 00159 * Solve A*X = B using the LU factorization of A, 00160 * overwriting each right hand side vector with its solution. 00161 * 00162 IF( NRHS.LE.1 ) THEN 00163 J = 1 00164 10 CONTINUE 00165 * 00166 * Solve L*x = b. 00167 * 00168 DO 20 I = 1, N - 1 00169 IP = IPIV( I ) 00170 TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J ) 00171 B( I, J ) = B( IP, J ) 00172 B( I+1, J ) = TEMP 00173 20 CONTINUE 00174 * 00175 * Solve U*x = b. 00176 * 00177 B( N, J ) = B( N, J ) / D( N ) 00178 IF( N.GT.1 ) 00179 $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / 00180 $ D( N-1 ) 00181 DO 30 I = N - 2, 1, -1 00182 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* 00183 $ B( I+2, J ) ) / D( I ) 00184 30 CONTINUE 00185 IF( J.LT.NRHS ) THEN 00186 J = J + 1 00187 GO TO 10 00188 END IF 00189 ELSE 00190 DO 60 J = 1, NRHS 00191 * 00192 * Solve L*x = b. 00193 * 00194 DO 40 I = 1, N - 1 00195 IF( IPIV( I ).EQ.I ) THEN 00196 B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) 00197 ELSE 00198 TEMP = B( I, J ) 00199 B( I, J ) = B( I+1, J ) 00200 B( I+1, J ) = TEMP - DL( I )*B( I, J ) 00201 END IF 00202 40 CONTINUE 00203 * 00204 * Solve U*x = b. 00205 * 00206 B( N, J ) = B( N, J ) / D( N ) 00207 IF( N.GT.1 ) 00208 $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / 00209 $ D( N-1 ) 00210 DO 50 I = N - 2, 1, -1 00211 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* 00212 $ B( I+2, J ) ) / D( I ) 00213 50 CONTINUE 00214 60 CONTINUE 00215 END IF 00216 ELSE 00217 * 00218 * Solve A**T * X = B. 00219 * 00220 IF( NRHS.LE.1 ) THEN 00221 * 00222 * Solve U**T*x = b. 00223 * 00224 J = 1 00225 70 CONTINUE 00226 B( 1, J ) = B( 1, J ) / D( 1 ) 00227 IF( N.GT.1 ) 00228 $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) 00229 DO 80 I = 3, N 00230 B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* 00231 $ B( I-2, J ) ) / D( I ) 00232 80 CONTINUE 00233 * 00234 * Solve L**T*x = b. 00235 * 00236 DO 90 I = N - 1, 1, -1 00237 IP = IPIV( I ) 00238 TEMP = B( I, J ) - DL( I )*B( I+1, J ) 00239 B( I, J ) = B( IP, J ) 00240 B( IP, J ) = TEMP 00241 90 CONTINUE 00242 IF( J.LT.NRHS ) THEN 00243 J = J + 1 00244 GO TO 70 00245 END IF 00246 * 00247 ELSE 00248 DO 120 J = 1, NRHS 00249 * 00250 * Solve U**T*x = b. 00251 * 00252 B( 1, J ) = B( 1, J ) / D( 1 ) 00253 IF( N.GT.1 ) 00254 $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) 00255 DO 100 I = 3, N 00256 B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- 00257 $ DU2( I-2 )*B( I-2, J ) ) / D( I ) 00258 100 CONTINUE 00259 DO 110 I = N - 1, 1, -1 00260 IF( IPIV( I ).EQ.I ) THEN 00261 B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) 00262 ELSE 00263 TEMP = B( I+1, J ) 00264 B( I+1, J ) = B( I, J ) - DL( I )*TEMP 00265 B( I, J ) = TEMP 00266 END IF 00267 110 CONTINUE 00268 120 CONTINUE 00269 END IF 00270 END IF 00271 * 00272 * End of SGTTS2 00273 * 00274 END