source: trunk/SOURCES/BLAS/strmv.f @ 22

Last change on this file since 22 was 22, checked in by roche, 9 years ago

Petites adaptations diverses du code pour compilation en gfortran. Ajout d un Makefile flexible a option pour choisir ifort ou gfortran.
File size: 8.6 KB
Line 
1      SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
2*     .. Scalar Arguments ..
3      INTEGER INCX,LDA,N
4      CHARACTER DIAG,TRANS,UPLO
5*     ..
6*     .. Array Arguments ..
7      REAL A(LDA,*),X(*)
8*     ..
9*
10*  Purpose
11*  =======
12*
13*  STRMV  performs one of the matrix-vector operations
14*
15*     x := A*x,   or   x := A**T*x,
16*
17*  where x is an n element vector and  A is an n by n unit, or non-unit,
18*  upper or lower triangular matrix.
19*
20*  Arguments
21*  ==========
22*
23*  UPLO   - CHARACTER*1.
24*           On entry, UPLO specifies whether the matrix is an upper or
25*           lower triangular matrix as follows:
26*
27*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
28*
29*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
30*
31*           Unchanged on exit.
32*
33*  TRANS  - CHARACTER*1.
34*           On entry, TRANS specifies the operation to be performed as
35*           follows:
36*
37*              TRANS = 'N' or 'n'   x := A*x.
38*
39*              TRANS = 'T' or 't'   x := A**T*x.
40*
41*              TRANS = 'C' or 'c'   x := A**T*x.
42*
43*           Unchanged on exit.
44*
45*  DIAG   - CHARACTER*1.
46*           On entry, DIAG specifies whether or not A is unit
47*           triangular as follows:
48*
49*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
50*
51*              DIAG = 'N' or 'n'   A is not assumed to be unit
52*                                  triangular.
53*
54*           Unchanged on exit.
55*
56*  N      - INTEGER.
57*           On entry, N specifies the order of the matrix A.
58*           N must be at least zero.
59*           Unchanged on exit.
60*
61*  A      - REAL             array of DIMENSION ( LDA, n ).
62*           Before entry with  UPLO = 'U' or 'u', the leading n by n
63*           upper triangular part of the array A must contain the upper
64*           triangular matrix and the strictly lower triangular part of
65*           A is not referenced.
66*           Before entry with UPLO = 'L' or 'l', the leading n by n
67*           lower triangular part of the array A must contain the lower
68*           triangular matrix and the strictly upper triangular part of
69*           A is not referenced.
70*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
71*           A are not referenced either, but are assumed to be unity.
72*           Unchanged on exit.
73*
74*  LDA    - INTEGER.
75*           On entry, LDA specifies the first dimension of A as declared
76*           in the calling (sub) program. LDA must be at least
77*           max( 1, n ).
78*           Unchanged on exit.
79*
80*  X      - REAL             array of dimension at least
81*           ( 1 + ( n - 1 )*abs( INCX ) ).
82*           Before entry, the incremented array X must contain the n
83*           element vector x. On exit, X is overwritten with the
84*           tranformed vector x.
85*
86*  INCX   - INTEGER.
87*           On entry, INCX specifies the increment for the elements of
88*           X. INCX must not be zero.
89*           Unchanged on exit.
90*
91*  Further Details
92*  ===============
93*
94*  Level 2 Blas routine.
95*  The vector and matrix arguments are not referenced when N = 0, or M = 0
96*
97*  -- Written on 22-October-1986.
98*     Jack Dongarra, Argonne National Lab.
99*     Jeremy Du Croz, Nag Central Office.
100*     Sven Hammarling, Nag Central Office.
101*     Richard Hanson, Sandia National Labs.
102*
103*  =====================================================================
104*
105*     .. Parameters ..
106      REAL ZERO
107      PARAMETER (ZERO=0.0E+0)
108*     ..
109*     .. Local Scalars ..
110      REAL TEMP
111      INTEGER I,INFO,IX,J,JX,KX
112      LOGICAL NOUNIT
113*     ..
114*     .. External Functions ..
115      LOGICAL LSAME
116      EXTERNAL LSAME
117*     ..
118*     .. External Subroutines ..
119      EXTERNAL XERBLA
120*     ..
121*     .. Intrinsic Functions ..
122      INTRINSIC MAX
123*     ..
124*
125*     Test the input parameters.
126*
127      INFO = 0
128      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
129          INFO = 1
130      ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
131     +         .NOT.LSAME(TRANS,'C')) THEN
132          INFO = 2
133      ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
134          INFO = 3
135      ELSE IF (N.LT.0) THEN
136          INFO = 4
137      ELSE IF (LDA.LT.MAX(1,N)) THEN
138          INFO = 6
139      ELSE IF (INCX.EQ.0) THEN
140          INFO = 8
141      END IF
142      IF (INFO.NE.0) THEN
143          CALL XERBLA('STRMV ',INFO)
144          RETURN
145      END IF
146*
147*     Quick return if possible.
148*
149      IF (N.EQ.0) RETURN
150*
151      NOUNIT = LSAME(DIAG,'N')
152*
153*     Set up the start point in X if the increment is not unity. This
154*     will be  ( N - 1 )*INCX  too small for descending loops.
155*
156      IF (INCX.LE.0) THEN
157          KX = 1 - (N-1)*INCX
158      ELSE IF (INCX.NE.1) THEN
159          KX = 1
160      END IF
161*
162*     Start the operations. In this version the elements of A are
163*     accessed sequentially with one pass through A.
164*
165      IF (LSAME(TRANS,'N')) THEN
166*
167*        Form  x := A*x.
168*
169          IF (LSAME(UPLO,'U')) THEN
170              IF (INCX.EQ.1) THEN
171                  DO 20 J = 1,N
172                      IF (X(J).NE.ZERO) THEN
173                          TEMP = X(J)
174                          DO 10 I = 1,J - 1
175                              X(I) = X(I) + TEMP*A(I,J)
176   10                     CONTINUE
177                          IF (NOUNIT) X(J) = X(J)*A(J,J)
178                      END IF
179   20             CONTINUE
180              ELSE
181                  JX = KX
182                  DO 40 J = 1,N
183                      IF (X(JX).NE.ZERO) THEN
184                          TEMP = X(JX)
185                          IX = KX
186                          DO 30 I = 1,J - 1
187                              X(IX) = X(IX) + TEMP*A(I,J)
188                              IX = IX + INCX
189   30                     CONTINUE
190                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
191                      END IF
192                      JX = JX + INCX
193   40             CONTINUE
194              END IF
195          ELSE
196              IF (INCX.EQ.1) THEN
197                  DO 60 J = N,1,-1
198                      IF (X(J).NE.ZERO) THEN
199                          TEMP = X(J)
200                          DO 50 I = N,J + 1,-1
201                              X(I) = X(I) + TEMP*A(I,J)
202   50                     CONTINUE
203                          IF (NOUNIT) X(J) = X(J)*A(J,J)
204                      END IF
205   60             CONTINUE
206              ELSE
207                  KX = KX + (N-1)*INCX
208                  JX = KX
209                  DO 80 J = N,1,-1
210                      IF (X(JX).NE.ZERO) THEN
211                          TEMP = X(JX)
212                          IX = KX
213                          DO 70 I = N,J + 1,-1
214                              X(IX) = X(IX) + TEMP*A(I,J)
215                              IX = IX - INCX
216   70                     CONTINUE
217                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
218                      END IF
219                      JX = JX - INCX
220   80             CONTINUE
221              END IF
222          END IF
223      ELSE
224*
225*        Form  x := A**T*x.
226*
227          IF (LSAME(UPLO,'U')) THEN
228              IF (INCX.EQ.1) THEN
229                  DO 100 J = N,1,-1
230                      TEMP = X(J)
231                      IF (NOUNIT) TEMP = TEMP*A(J,J)
232                      DO 90 I = J - 1,1,-1
233                          TEMP = TEMP + A(I,J)*X(I)
234   90                 CONTINUE
235                      X(J) = TEMP
236  100             CONTINUE
237              ELSE
238                  JX = KX + (N-1)*INCX
239                  DO 120 J = N,1,-1
240                      TEMP = X(JX)
241                      IX = JX
242                      IF (NOUNIT) TEMP = TEMP*A(J,J)
243                      DO 110 I = J - 1,1,-1
244                          IX = IX - INCX
245                          TEMP = TEMP + A(I,J)*X(IX)
246  110                 CONTINUE
247                      X(JX) = TEMP
248                      JX = JX - INCX
249  120             CONTINUE
250              END IF
251          ELSE
252              IF (INCX.EQ.1) THEN
253                  DO 140 J = 1,N
254                      TEMP = X(J)
255                      IF (NOUNIT) TEMP = TEMP*A(J,J)
256                      DO 130 I = J + 1,N
257                          TEMP = TEMP + A(I,J)*X(I)
258  130                 CONTINUE
259                      X(J) = TEMP
260  140             CONTINUE
261              ELSE
262                  JX = KX
263                  DO 160 J = 1,N
264                      TEMP = X(JX)
265                      IX = JX
266                      IF (NOUNIT) TEMP = TEMP*A(J,J)
267                      DO 150 I = J + 1,N
268                          IX = IX + INCX
269                          TEMP = TEMP + A(I,J)*X(IX)
270  150                 CONTINUE
271                      X(JX) = TEMP
272                      JX = JX + INCX
273  160             CONTINUE
274              END IF
275          END IF
276      END IF
277*
278      RETURN
279*
280*     End of STRMV .
281*
282      END
Note: See TracBrowser for help on using the repository browser.