SRC/sgtsv.f

   1 *> \brief <b> SGTSV computes the solution to system of linear equations A * X = B for GT matrices <b>
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download SGTSV + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgtsv.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgtsv.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgtsv.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       INTEGER            INFO, LDB, N, NRHS
  25 *       ..
  26 *       .. Array Arguments ..
  27 *       REAL               B( LDB, * ), D( * ), DL( * ), DU( * )
  28 *       ..
  29 *
  30 *
  31 *> \par Purpose:
  32 *  =============
  33 *>
  34 *> \verbatim
  35 *>
  36 *> SGTSV  solves the equation
  37 *>
  38 *>    A*X = B,
  39 *>
  40 *> where A is an n by n tridiagonal matrix, by Gaussian elimination with
  41 *> partial pivoting.
  42 *>
  43 *> Note that the equation  A**T*X = B  may be solved by interchanging the
  44 *> order of the arguments DU and DL.
  45 *> \endverbatim
  46 *
  47 *  Arguments:
  48 *  ==========
  49 *
  50 *> \param[in] N
  51 *> \verbatim
  52 *>          N is INTEGER
  53 *>          The order of the matrix A.  N >= 0.
  54 *> \endverbatim
  55 *>
  56 *> \param[in] NRHS
  57 *> \verbatim
  58 *>          NRHS is INTEGER
  59 *>          The number of right hand sides, i.e., the number of columns
  60 *>          of the matrix B.  NRHS >= 0.
  61 *> \endverbatim
  62 *>
  63 *> \param[in,out] DL
  64 *> \verbatim
  65 *>          DL is REAL array, dimension (N-1)
  66 *>          On entry, DL must contain the (n-1) sub-diagonal elements of
  67 *>          A.
  68 *>
  69 *>          On exit, DL is overwritten by the (n-2) elements of the
  70 *>          second super-diagonal of the upper triangular matrix U from
  71 *>          the LU factorization of A, in DL(1), ..., DL(n-2).
  72 *> \endverbatim
  73 *>
  74 *> \param[in,out] D
  75 *> \verbatim
  76 *>          D is REAL array, dimension (N)
  77 *>          On entry, D must contain the diagonal elements of A.
  78 *>
  79 *>          On exit, D is overwritten by the n diagonal elements of U.
  80 *> \endverbatim
  81 *>
  82 *> \param[in,out] DU
  83 *> \verbatim
  84 *>          DU is REAL array, dimension (N-1)
  85 *>          On entry, DU must contain the (n-1) super-diagonal elements
  86 *>          of A.
  87 *>
  88 *>          On exit, DU is overwritten by the (n-1) elements of the first
  89 *>          super-diagonal of U.
  90 *> \endverbatim
  91 *>
  92 *> \param[in,out] B
  93 *> \verbatim
  94 *>          B is REAL array, dimension (LDB,NRHS)
  95 *>          On entry, the N by NRHS matrix of right hand side matrix B.
  96 *>          On exit, if INFO = 0, the N by NRHS solution matrix X.
  97 *> \endverbatim
  98 *>
  99 *> \param[in] LDB
 100 *> \verbatim
 101 *>          LDB is INTEGER
 102 *>          The leading dimension of the array B.  LDB >= max(1,N).
 103 *> \endverbatim
 104 *>
 105 *> \param[out] INFO
 106 *> \verbatim
 107 *>          INFO is INTEGER
 108 *>          = 0: successful exit
 109 *>          < 0: if INFO = -i, the i-th argument had an illegal value
 110 *>          > 0: if INFO = i, U(i,i) is exactly zero, and the solution
 111 *>               has not been computed.  The factorization has not been
 112 *>               completed unless i = N.
 113 *> \endverbatim
 114 *
 115 *  Authors:
 116 *  ========
 117 *
 118 *> \author Univ. of Tennessee
 119 *> \author Univ. of California Berkeley
 120 *> \author Univ. of Colorado Denver
 121 *> \author NAG Ltd.
 122 *
 123 *> \date September 2012
 124 *
 125 *> \ingroup realGTsolve
 126 *
 127 *  =====================================================================
 128       SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
 129 *
 130 *  -- LAPACK driver routine (version 3.4.2) --
 131 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 132 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 133 *     September 2012
 134 *
 135 *     .. Scalar Arguments ..
 136       INTEGER            INFO, LDB, N, NRHS
 137 *     ..
 138 *     .. Array Arguments ..
 139       REAL               B( LDB, * ), D( * ), DL( * ), DU( * )
 140 *     ..
 141 *
 142 *  =====================================================================
 143 *
 144 *     .. Parameters ..
 145       REAL               ZERO
 146       PARAMETER          ( ZERO = 0.0E+0 )
 147 *     ..
 148 *     .. Local Scalars ..
 149       INTEGER            I, J
 150       REAL               FACT, TEMP
 151 *     ..
 152 *     .. Intrinsic Functions ..
 153       INTRINSIC          ABS, MAX
 154 *     ..
 155 *     .. External Subroutines ..
 156       EXTERNAL           XERBLA
 157 *     ..
 158 *     .. Executable Statements ..
 159 *
 160       INFO = 0
 161       IF( N.LT.0 ) THEN
 162          INFO = -1
 163       ELSE IF( NRHS.LT.0 ) THEN
 164          INFO = -2
 165       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
 166          INFO = -7
 167       END IF
 168       IF( INFO.NE.0 ) THEN
 169          CALL XERBLA( 'SGTSV ', -INFO )
 170          RETURN
 171       END IF
 172 *
 173       IF( N.EQ.0 )
 174      $   RETURN
 175 *
 176       IF( NRHS.EQ.1 ) THEN
 177          DO 10 I = 1, N - 2
 178             IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
 179 *
 180 *              No row interchange required
 181 *
 182                IF( D( I ).NE.ZERO ) THEN
 183                   FACT = DL( I ) / D( I )
 184                   D( I+1 ) = D( I+1 ) - FACT*DU( I )
 185                   B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
 186                ELSE
 187                   INFO = I
 188                   RETURN
 189                END IF
 190                DL( I ) = ZERO
 191             ELSE
 192 *
 193 *              Interchange rows I and I+1
 194 *
 195                FACT = D( I ) / DL( I )
 196                D( I ) = DL( I )
 197                TEMP = D( I+1 )
 198                D( I+1 ) = DU( I ) - FACT*TEMP
 199                DL( I ) = DU( I+1 )
 200                DU( I+1 ) = -FACT*DL( I )
 201                DU( I ) = TEMP
 202                TEMP = B( I, 1 )
 203                B( I, 1 ) = B( I+1, 1 )
 204                B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
 205             END IF
 206    10    CONTINUE
 207          IF( N.GT.1 ) THEN
 208             I = N - 1
 209             IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
 210                IF( D( I ).NE.ZERO ) THEN
 211                   FACT = DL( I ) / D( I )
 212                   D( I+1 ) = D( I+1 ) - FACT*DU( I )
 213                   B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
 214                ELSE
 215                   INFO = I
 216                   RETURN
 217                END IF
 218             ELSE
 219                FACT = D( I ) / DL( I )
 220                D( I ) = DL( I )
 221                TEMP = D( I+1 )
 222                D( I+1 ) = DU( I ) - FACT*TEMP
 223                DU( I ) = TEMP
 224                TEMP = B( I, 1 )
 225                B( I, 1 ) = B( I+1, 1 )
 226                B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
 227             END IF
 228          END IF
 229          IF( D( N ).EQ.ZERO ) THEN
 230             INFO = N
 231             RETURN
 232          END IF
 233       ELSE
 234          DO 40 I = 1, N - 2
 235             IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
 236 *
 237 *              No row interchange required
 238 *
 239                IF( D( I ).NE.ZERO ) THEN
 240                   FACT = DL( I ) / D( I )
 241                   D( I+1 ) = D( I+1 ) - FACT*DU( I )
 242                   DO 20 J = 1, NRHS
 243                      B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
 244    20             CONTINUE
 245                ELSE
 246                   INFO = I
 247                   RETURN
 248                END IF
 249                DL( I ) = ZERO
 250             ELSE
 251 *
 252 *              Interchange rows I and I+1
 253 *
 254                FACT = D( I ) / DL( I )
 255                D( I ) = DL( I )
 256                TEMP = D( I+1 )
 257                D( I+1 ) = DU( I ) - FACT*TEMP
 258                DL( I ) = DU( I+1 )
 259                DU( I+1 ) = -FACT*DL( I )
 260                DU( I ) = TEMP
 261                DO 30 J = 1, NRHS
 262                   TEMP = B( I, J )
 263                   B( I, J ) = B( I+1, J )
 264                   B( I+1, J ) = TEMP - FACT*B( I+1, J )
 265    30          CONTINUE
 266             END IF
 267    40    CONTINUE
 268          IF( N.GT.1 ) THEN
 269             I = N - 1
 270             IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
 271                IF( D( I ).NE.ZERO ) THEN
 272                   FACT = DL( I ) / D( I )
 273                   D( I+1 ) = D( I+1 ) - FACT*DU( I )
 274                   DO 50 J = 1, NRHS
 275                      B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
 276    50             CONTINUE
 277                ELSE
 278                   INFO = I
 279                   RETURN
 280                END IF
 281             ELSE
 282                FACT = D( I ) / DL( I )
 283                D( I ) = DL( I )
 284                TEMP = D( I+1 )
 285                D( I+1 ) = DU( I ) - FACT*TEMP
 286                DU( I ) = TEMP
 287                DO 60 J = 1, NRHS
 288                   TEMP = B( I, J )
 289                   B( I, J ) = B( I+1, J )
 290                   B( I+1, J ) = TEMP - FACT*B( I+1, J )
 291    60          CONTINUE
 292             END IF
 293          END IF
 294          IF( D( N ).EQ.ZERO ) THEN
 295             INFO = N
 296             RETURN
 297          END IF
 298       END IF
 299 *
 300 *     Back solve with the matrix U from the factorization.
 301 *
 302       IF( NRHS.LE.2 ) THEN
 303          J = 1
 304    70    CONTINUE
 305          B( N, J ) = B( N, J ) / D( N )
 306          IF( N.GT.1 )
 307      $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
 308          DO 80 I = N - 2, 1, -1
 309             B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
 310      $                  B( I+2, J ) ) / D( I )
 311    80    CONTINUE
 312          IF( J.LT.NRHS ) THEN
 313             J = J + 1
 314             GO TO 70
 315          END IF
 316       ELSE
 317          DO 100 J = 1, NRHS
 318             B( N, J ) = B( N, J ) / D( N )
 319             IF( N.GT.1 )
 320      $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
 321      $                       D( N-1 )
 322             DO 90 I = N - 2, 1, -1
 323                B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
 324      $                     B( I+2, J ) ) / D( I )
 325    90       CONTINUE
 326   100    CONTINUE
 327       END IF
 328 *
 329       RETURN
 330 *
 331 *     End of SGTSV
 332 *
 333       END