Mercurial > octave-nkf

comparison libcruft/lapack/cpbtrs.f @ 7789:82be108cc558

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First attempt at single precision tyeps * * * corrections to qrupdate single precision routines * * * prefer demotion to single over promotion to double * * * Add single precision support to log2 function * * * Trivial PROJECT file update * * * Cache optimized hermitian/transpose methods * * * Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author David Bateman <dbateman@free.fr>
date Sun, 27 Apr 2008 22:34:17 +0200
parents
children
comparison
equal deleted inserted replaced
7788:45f5faba05a2 7789:82be108cc558
1 SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
2 *
3 * -- LAPACK routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 CHARACTER UPLO
9 INTEGER INFO, KD, LDAB, LDB, N, NRHS
10 * ..
11 * .. Array Arguments ..
12 COMPLEX AB( LDAB, * ), B( LDB, * )
13 * ..
14 *
15 * Purpose
16 * =======
17 *
18 * CPBTRS solves a system of linear equations A*X = B with a Hermitian
19 * positive definite band matrix A using the Cholesky factorization
20 * A = U**H*U or A = L*L**H computed by CPBTRF.
21 *
22 * Arguments
23 * =========
24 *
25 * UPLO (input) CHARACTER*1
26 * = 'U': Upper triangular factor stored in AB;
27 * = 'L': Lower triangular factor stored in AB.
28 *
29 * N (input) INTEGER
30 * The order of the matrix A. N >= 0.
31 *
32 * KD (input) INTEGER
33 * The number of superdiagonals of the matrix A if UPLO = 'U',
34 * or the number of subdiagonals if UPLO = 'L'. KD >= 0.
35 *
36 * NRHS (input) INTEGER
37 * The number of right hand sides, i.e., the number of columns
38 * of the matrix B. NRHS >= 0.
39 *
40 * AB (input) COMPLEX array, dimension (LDAB,N)
41 * The triangular factor U or L from the Cholesky factorization
42 * A = U**H*U or A = L*L**H of the band matrix A, stored in the
43 * first KD+1 rows of the array. The j-th column of U or L is
44 * stored in the j-th column of the array AB as follows:
45 * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
46 * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
47 *
48 * LDAB (input) INTEGER
49 * The leading dimension of the array AB. LDAB >= KD+1.
50 *
51 * B (input/output) COMPLEX array, dimension (LDB,NRHS)
52 * On entry, the right hand side matrix B.
53 * On exit, the solution matrix X.
54 *
55 * LDB (input) INTEGER
56 * The leading dimension of the array B. LDB >= max(1,N).
57 *
58 * INFO (output) INTEGER
59 * = 0: successful exit
60 * < 0: if INFO = -i, the i-th argument had an illegal value
61 *
62 * =====================================================================
63 *
64 * .. Local Scalars ..
65 LOGICAL UPPER
66 INTEGER J
67 * ..
68 * .. External Functions ..
69 LOGICAL LSAME
70 EXTERNAL LSAME
71 * ..
72 * .. External Subroutines ..
73 EXTERNAL CTBSV, XERBLA
74 * ..
75 * .. Intrinsic Functions ..
76 INTRINSIC MAX
77 * ..
78 * .. Executable Statements ..
79 *
80 * Test the input parameters.
81 *
82 INFO = 0
83 UPPER = LSAME( UPLO, 'U' )
84 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
85 INFO = -1
86 ELSE IF( N.LT.0 ) THEN
87 INFO = -2
88 ELSE IF( KD.LT.0 ) THEN
89 INFO = -3
90 ELSE IF( NRHS.LT.0 ) THEN
91 INFO = -4
92 ELSE IF( LDAB.LT.KD+1 ) THEN
93 INFO = -6
94 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
95 INFO = -8
96 END IF
97 IF( INFO.NE.0 ) THEN
98 CALL XERBLA( 'CPBTRS', -INFO )
99 RETURN
100 END IF
101 *
102 * Quick return if possible
103 *
104 IF( N.EQ.0 .OR. NRHS.EQ.0 )
105 $ RETURN
106 *
107 IF( UPPER ) THEN
108 *
109 * Solve A*X = B where A = U'*U.
110 *
111 DO 10 J = 1, NRHS
112 *
113 * Solve U'*X = B, overwriting B with X.
114 *
115 CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
116 $ KD, AB, LDAB, B( 1, J ), 1 )
117 *
118 * Solve U*X = B, overwriting B with X.
119 *
120 CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
121 $ LDAB, B( 1, J ), 1 )
122 10 CONTINUE
123 ELSE
124 *
125 * Solve A*X = B where A = L*L'.
126 *
127 DO 20 J = 1, NRHS
128 *
129 * Solve L*X = B, overwriting B with X.
130 *
131 CALL CTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
132 $ LDAB, B( 1, J ), 1 )
133 *
134 * Solve L'*X = B, overwriting B with X.
135 *
136 CALL CTBSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
137 $ KD, AB, LDAB, B( 1, J ), 1 )
138 20 CONTINUE
139 END IF
140 *
141 RETURN
142 *
143 * End of CPBTRS
144 *
145 END