annotate libcruft/lapack/dptts2.f @ 9665:1dba57e9d08d

use blas_trans_type for xgemm
author Jaroslav Hajek <highegg@gmail.com>
date Sat, 26 Sep 2009 10:41:07 +0200
parents 68db500cb558
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
5164
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
1 SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
2 *
7034
68db500cb558 [project @ 2007-10-16 18:54:19 by jwe]
jwe
parents: 5164
diff changeset
3 * -- LAPACK routine (version 3.1) --
68db500cb558 [project @ 2007-10-16 18:54:19 by jwe]
jwe
parents: 5164
diff changeset
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
68db500cb558 [project @ 2007-10-16 18:54:19 by jwe]
jwe
parents: 5164
diff changeset
5 * November 2006
5164
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
6 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
7 * .. Scalar Arguments ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
8 INTEGER LDB, N, NRHS
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
9 * ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
10 * .. Array Arguments ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
11 DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
12 * ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
13 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
14 * Purpose
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
15 * =======
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
16 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
17 * DPTTS2 solves a tridiagonal system of the form
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
18 * A * X = B
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
19 * using the L*D*L' factorization of A computed by DPTTRF. D is a
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
20 * diagonal matrix specified in the vector D, L is a unit bidiagonal
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
21 * matrix whose subdiagonal is specified in the vector E, and X and B
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
22 * are N by NRHS matrices.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
23 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
24 * Arguments
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
25 * =========
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
26 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
27 * N (input) INTEGER
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
28 * The order of the tridiagonal matrix A. N >= 0.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
29 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
30 * NRHS (input) INTEGER
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
31 * The number of right hand sides, i.e., the number of columns
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
32 * of the matrix B. NRHS >= 0.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
33 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
34 * D (input) DOUBLE PRECISION array, dimension (N)
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
35 * The n diagonal elements of the diagonal matrix D from the
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
36 * L*D*L' factorization of A.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
37 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
38 * E (input) DOUBLE PRECISION array, dimension (N-1)
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
39 * The (n-1) subdiagonal elements of the unit bidiagonal factor
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
40 * L from the L*D*L' factorization of A. E can also be regarded
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
41 * as the superdiagonal of the unit bidiagonal factor U from the
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
42 * factorization A = U'*D*U.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
43 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
44 * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
45 * On entry, the right hand side vectors B for the system of
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
46 * linear equations.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
47 * On exit, the solution vectors, X.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
48 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
49 * LDB (input) INTEGER
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
50 * The leading dimension of the array B. LDB >= max(1,N).
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
51 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
52 * =====================================================================
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
53 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
54 * .. Local Scalars ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
55 INTEGER I, J
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
56 * ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
57 * .. External Subroutines ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
58 EXTERNAL DSCAL
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
59 * ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
60 * .. Executable Statements ..
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
61 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
62 * Quick return if possible
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
63 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
64 IF( N.LE.1 ) THEN
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
65 IF( N.EQ.1 )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
66 $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
67 RETURN
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
68 END IF
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
69 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
70 * Solve A * X = B using the factorization A = L*D*L',
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
71 * overwriting each right hand side vector with its solution.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
72 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
73 DO 30 J = 1, NRHS
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
74 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
75 * Solve L * x = b.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
76 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
77 DO 10 I = 2, N
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
78 B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
79 10 CONTINUE
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
80 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
81 * Solve D * L' * x = b.
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
82 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
83 B( N, J ) = B( N, J ) / D( N )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
84 DO 20 I = N - 1, 1, -1
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
85 B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
86 20 CONTINUE
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
87 30 CONTINUE
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
88 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
89 RETURN
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
90 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
91 * End of DPTTS2
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
92 *
57077d0ddc8e [project @ 2005-02-25 19:55:24 by jwe]
jwe
parents:
diff changeset
93 END