1        2        3        4        5        6        7        8        9       10       11       12       13       14       15       16       17       18       19       20       21       22       23       24       25       26       27       28       29       30       31       32       33       34       35       36       37       38       39       40       41       42       43       44       45       46       47       48       49       50       51       52       53       54       55       56       57       58       59       60       61       62       63       64       65       66       67       68       69       70       71       72       73       74       75       76       77       78       79       80       81       82       83       84       85       86       87       88       89       90       91       92       93       94       95       96       97       98       99      100      101      102      103      104      105      106      107      108      109      110      111      112      113      114      115      116      117      118      119      120      121      122      123      124      125      126      127      128      129      130      131      132      133      134      135      136      137      138      139      140      141      142      143      144      145      146      147      148      149      150      151      152      153      154      155      156      157      158      159      160      161      162      163      164      165      166      167      168      169      170      171      172      173      174      175      176      177      178      179      180      181      182      183      184      185      186      187 SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,      $INFO ) * * -- LAPACK routine (version 3.2) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGBTRS solves a system of linear equations * A * X = B or A**T * X = B * with a general band matrix A using the LU factorization computed * by DGBTRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A**T* X = B (Transpose) * = 'C': A**T* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by DGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= N, row i of the matrix was * interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.$    LSAME( TRANS, 'C' ) ) THEN          INFO = -1       ELSE IF( N.LT.0 ) THEN          INFO = -2       ELSE IF( KL.LT.0 ) THEN          INFO = -3       ELSE IF( KU.LT.0 ) THEN          INFO = -4       ELSE IF( NRHS.LT.0 ) THEN          INFO = -5       ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN          INFO = -7       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN          INFO = -10       END IF       IF( INFO.NE.0 ) THEN          CALL XERBLA( 'DGBTRS', -INFO )          RETURN       END IF * *     Quick return if possible *       IF( N.EQ.0 .OR. NRHS.EQ.0 )      $RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J )$            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )                CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),      $LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,$                  AB, LDAB, B( 1, I ), 1 )    20    CONTINUE *       ELSE * *        Solve A**T*X = B. *          DO 30 I = 1, NRHS * *           Solve U**T*X = B, overwriting B with X. *             CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,      $LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L**T*X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),$                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )                L = IPIV( J )                IF( L.NE.J )      \$            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )    40       CONTINUE          END IF       END IF       RETURN * *     End of DGBTRS *       END