SRC/zgtts2.f

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