Statistiques
| Révision :

root / src / lapack / double / dlarf.f @ 10

Historique | Voir | Annoter | Télécharger (4,34 ko)

1 1 pfleura2 
      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
2 1 pfleura2 
      IMPLICIT NONE
3 1 pfleura2 
*
4 1 pfleura2 
*  -- LAPACK auxiliary routine (version 3.2) --
5 1 pfleura2 
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
6 1 pfleura2 
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7 1 pfleura2 
*     November 2006
8 1 pfleura2 
*
9 1 pfleura2 
*     .. Scalar Arguments ..
10 1 pfleura2 
      CHARACTER          SIDE
11 1 pfleura2 
      INTEGER            INCV, LDC, M, N
12 1 pfleura2 
      DOUBLE PRECISION   TAU
13 1 pfleura2 
*     ..
14 1 pfleura2 
*     .. Array Arguments ..
15 1 pfleura2 
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
16 1 pfleura2 
*     ..
17 1 pfleura2 
*
18 1 pfleura2 
*  Purpose
19 1 pfleura2 
*  =======
20 1 pfleura2 
*
21 1 pfleura2 
*  DLARF applies a real elementary reflector H to a real m by n matrix
22 1 pfleura2 
*  C, from either the left or the right. H is represented in the form
23 1 pfleura2 
*
24 1 pfleura2 
*        H = I - tau * v * v'
25 1 pfleura2 
*
26 1 pfleura2 
*  where tau is a real scalar and v is a real vector.
27 1 pfleura2 
*
28 1 pfleura2 
*  If tau = 0, then H is taken to be the unit matrix.
29 1 pfleura2 
*
30 1 pfleura2 
*  Arguments
31 1 pfleura2 
*  =========
32 1 pfleura2 
*
33 1 pfleura2 
*  SIDE    (input) CHARACTER*1
34 1 pfleura2 
*          = 'L': form  H * C
35 1 pfleura2 
*          = 'R': form  C * H
36 1 pfleura2 
*
37 1 pfleura2 
*  M       (input) INTEGER
38 1 pfleura2 
*          The number of rows of the matrix C.
39 1 pfleura2 
*
40 1 pfleura2 
*  N       (input) INTEGER
41 1 pfleura2 
*          The number of columns of the matrix C.
42 1 pfleura2 
*
43 1 pfleura2 
*  V       (input) DOUBLE PRECISION array, dimension
44 1 pfleura2 
*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
45 1 pfleura2 
*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
46 1 pfleura2 
*          The vector v in the representation of H. V is not used if
47 1 pfleura2 
*          TAU = 0.
48 1 pfleura2 
*
49 1 pfleura2 
*  INCV    (input) INTEGER
50 1 pfleura2 
*          The increment between elements of v. INCV <> 0.
51 1 pfleura2 
*
52 1 pfleura2 
*  TAU     (input) DOUBLE PRECISION
53 1 pfleura2 
*          The value tau in the representation of H.
54 1 pfleura2 
*
55 1 pfleura2 
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
56 1 pfleura2 
*          On entry, the m by n matrix C.
57 1 pfleura2 
*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
58 1 pfleura2 
*          or C * H if SIDE = 'R'.
59 1 pfleura2 
*
60 1 pfleura2 
*  LDC     (input) INTEGER
61 1 pfleura2 
*          The leading dimension of the array C. LDC >= max(1,M).
62 1 pfleura2 
*
63 1 pfleura2 
*  WORK    (workspace) DOUBLE PRECISION array, dimension
64 1 pfleura2 
*                         (N) if SIDE = 'L'
65 1 pfleura2 
*                      or (M) if SIDE = 'R'
66 1 pfleura2 
*
67 1 pfleura2 
*  =====================================================================
68 1 pfleura2 
*
69 1 pfleura2 
*     .. Parameters ..
70 1 pfleura2 
      DOUBLE PRECISION   ONE, ZERO
71 1 pfleura2 
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
72 1 pfleura2 
*     ..
73 1 pfleura2 
*     .. Local Scalars ..
74 1 pfleura2 
      LOGICAL            APPLYLEFT
75 1 pfleura2 
      INTEGER            I, LASTV, LASTC
76 1 pfleura2 
*     ..
77 1 pfleura2 
*     .. External Subroutines ..
78 1 pfleura2 
      EXTERNAL           DGEMV, DGER
79 1 pfleura2 
*     ..
80 1 pfleura2 
*     .. External Functions ..
81 1 pfleura2 
      LOGICAL            LSAME
82 1 pfleura2 
      INTEGER            ILADLR, ILADLC
83 1 pfleura2 
      EXTERNAL           LSAME, ILADLR, ILADLC
84 1 pfleura2 
*     ..
85 1 pfleura2 
*     .. Executable Statements ..
86 1 pfleura2 
*
87 1 pfleura2 
      APPLYLEFT = LSAME( SIDE, 'L' )
88 1 pfleura2 
      LASTV = 0
89 1 pfleura2 
      LASTC = 0
90 1 pfleura2 
      IF( TAU.NE.ZERO ) THEN
91 1 pfleura2 
!     Set up variables for scanning V.  LASTV begins pointing to the end
92 1 pfleura2 
!     of V.
93 1 pfleura2 
         IF( APPLYLEFT ) THEN
94 1 pfleura2 
            LASTV = M
95 1 pfleura2 
         ELSE
96 1 pfleura2 
            LASTV = N
97 1 pfleura2 
         END IF
98 1 pfleura2 
         IF( INCV.GT.0 ) THEN
99 1 pfleura2 
            I = 1 + (LASTV-1) * INCV
100 1 pfleura2 
         ELSE
101 1 pfleura2 
            I = 1
102 1 pfleura2 
         END IF
103 1 pfleura2 
!     Look for the last non-zero row in V.
104 1 pfleura2 
         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
105 1 pfleura2 
            LASTV = LASTV - 1
106 1 pfleura2 
            I = I - INCV
107 1 pfleura2 
         END DO
108 1 pfleura2 
         IF( APPLYLEFT ) THEN
109 1 pfleura2 
!     Scan for the last non-zero column in C(1:lastv,:).
110 1 pfleura2 
            LASTC = ILADLC(LASTV, N, C, LDC)
111 1 pfleura2 
         ELSE
112 1 pfleura2 
!     Scan for the last non-zero row in C(:,1:lastv).
113 1 pfleura2 
            LASTC = ILADLR(M, LASTV, C, LDC)
114 1 pfleura2 
         END IF
115 1 pfleura2 
      END IF
116 1 pfleura2 
!     Note that lastc.eq.0 renders the BLAS operations null; no special
117 1 pfleura2 
!     case is needed at this level.
118 1 pfleura2 
      IF( APPLYLEFT ) THEN
119 1 pfleura2 
*
120 1 pfleura2 
*        Form  H * C
121 1 pfleura2 
*
122 1 pfleura2 
         IF( LASTV.GT.0 ) THEN
123 1 pfleura2 
*
124 1 pfleura2 
*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
125 1 pfleura2 
*
126 1 pfleura2 
            CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
127 1 pfleura2 
     $           ZERO, WORK, 1 )
128 1 pfleura2 
*
129 1 pfleura2 
*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
130 1 pfleura2 
*
131 1 pfleura2 
            CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
132 1 pfleura2 
         END IF
133 1 pfleura2 
      ELSE
134 1 pfleura2 
*
135 1 pfleura2 
*        Form  C * H
136 1 pfleura2 
*
137 1 pfleura2 
         IF( LASTV.GT.0 ) THEN
138 1 pfleura2 
*
139 1 pfleura2 
*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
140 1 pfleura2 
*
141 1 pfleura2 
            CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
142 1 pfleura2 
     $           V, INCV, ZERO, WORK, 1 )
143 1 pfleura2 
*
144 1 pfleura2 
*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
145 1 pfleura2 
*
146 1 pfleura2 
            CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
147 1 pfleura2 
         END IF
148 1 pfleura2 
      END IF
149 1 pfleura2 
      RETURN
150 1 pfleura2 
*
151 1 pfleura2 
*     End of DLARF
152 1 pfleura2 
*
153 1 pfleura2 
      END