Statistiques
| Révision :

root / src / blas / dsyr2.f @ 8

Historique | Voir | Annoter | Télécharger (6,95 ko)

1 1 pfleura2 
      SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
2 1 pfleura2 
*     .. Scalar Arguments ..
3 1 pfleura2 
      DOUBLE PRECISION ALPHA
4 1 pfleura2 
      INTEGER INCX,INCY,LDA,N
5 1 pfleura2 
      CHARACTER UPLO
6 1 pfleura2 
*     ..
7 1 pfleura2 
*     .. Array Arguments ..
8 1 pfleura2 
      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
9 1 pfleura2 
*     ..
10 1 pfleura2 
*
11 1 pfleura2 
*  Purpose
12 1 pfleura2 
*  =======
13 1 pfleura2 
*
14 1 pfleura2 
*  DSYR2  performs the symmetric rank 2 operation
15 1 pfleura2 
*
16 1 pfleura2 
*     A := alpha*x*y' + alpha*y*x' + A,
17 1 pfleura2 
*
18 1 pfleura2 
*  where alpha is a scalar, x and y are n element vectors and A is an n
19 1 pfleura2 
*  by n symmetric matrix.
20 1 pfleura2 
*
21 1 pfleura2 
*  Arguments
22 1 pfleura2 
*  ==========
23 1 pfleura2 
*
24 1 pfleura2 
*  UPLO   - CHARACTER*1.
25 1 pfleura2 
*           On entry, UPLO specifies whether the upper or lower
26 1 pfleura2 
*           triangular part of the array A is to be referenced as
27 1 pfleura2 
*           follows:
28 1 pfleura2 
*
29 1 pfleura2 
*              UPLO = 'U' or 'u'   Only the upper triangular part of A
30 1 pfleura2 
*                                  is to be referenced.
31 1 pfleura2 
*
32 1 pfleura2 
*              UPLO = 'L' or 'l'   Only the lower triangular part of A
33 1 pfleura2 
*                                  is to be referenced.
34 1 pfleura2 
*
35 1 pfleura2 
*           Unchanged on exit.
36 1 pfleura2 
*
37 1 pfleura2 
*  N      - INTEGER.
38 1 pfleura2 
*           On entry, N specifies the order of the matrix A.
39 1 pfleura2 
*           N must be at least zero.
40 1 pfleura2 
*           Unchanged on exit.
41 1 pfleura2 
*
42 1 pfleura2 
*  ALPHA  - DOUBLE PRECISION.
43 1 pfleura2 
*           On entry, ALPHA specifies the scalar alpha.
44 1 pfleura2 
*           Unchanged on exit.
45 1 pfleura2 
*
46 1 pfleura2 
*  X      - DOUBLE PRECISION array of dimension at least
47 1 pfleura2 
*           ( 1 + ( n - 1 )*abs( INCX ) ).
48 1 pfleura2 
*           Before entry, the incremented array X must contain the n
49 1 pfleura2 
*           element vector x.
50 1 pfleura2 
*           Unchanged on exit.
51 1 pfleura2 
*
52 1 pfleura2 
*  INCX   - INTEGER.
53 1 pfleura2 
*           On entry, INCX specifies the increment for the elements of
54 1 pfleura2 
*           X. INCX must not be zero.
55 1 pfleura2 
*           Unchanged on exit.
56 1 pfleura2 
*
57 1 pfleura2 
*  Y      - DOUBLE PRECISION array of dimension at least
58 1 pfleura2 
*           ( 1 + ( n - 1 )*abs( INCY ) ).
59 1 pfleura2 
*           Before entry, the incremented array Y must contain the n
60 1 pfleura2 
*           element vector y.
61 1 pfleura2 
*           Unchanged on exit.
62 1 pfleura2 
*
63 1 pfleura2 
*  INCY   - INTEGER.
64 1 pfleura2 
*           On entry, INCY specifies the increment for the elements of
65 1 pfleura2 
*           Y. INCY must not be zero.
66 1 pfleura2 
*           Unchanged on exit.
67 1 pfleura2 
*
68 1 pfleura2 
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
69 1 pfleura2 
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
70 1 pfleura2 
*           upper triangular part of the array A must contain the upper
71 1 pfleura2 
*           triangular part of the symmetric matrix and the strictly
72 1 pfleura2 
*           lower triangular part of A is not referenced. On exit, the
73 1 pfleura2 
*           upper triangular part of the array A is overwritten by the
74 1 pfleura2 
*           upper triangular part of the updated matrix.
75 1 pfleura2 
*           Before entry with UPLO = 'L' or 'l', the leading n by n
76 1 pfleura2 
*           lower triangular part of the array A must contain the lower
77 1 pfleura2 
*           triangular part of the symmetric matrix and the strictly
78 1 pfleura2 
*           upper triangular part of A is not referenced. On exit, the
79 1 pfleura2 
*           lower triangular part of the array A is overwritten by the
80 1 pfleura2 
*           lower triangular part of the updated matrix.
81 1 pfleura2 
*
82 1 pfleura2 
*  LDA    - INTEGER.
83 1 pfleura2 
*           On entry, LDA specifies the first dimension of A as declared
84 1 pfleura2 
*           in the calling (sub) program. LDA must be at least
85 1 pfleura2 
*           max( 1, n ).
86 1 pfleura2 
*           Unchanged on exit.
87 1 pfleura2 
*
88 1 pfleura2 
*
89 1 pfleura2 
*  Level 2 Blas routine.
90 1 pfleura2 
*
91 1 pfleura2 
*  -- Written on 22-October-1986.
92 1 pfleura2 
*     Jack Dongarra, Argonne National Lab.
93 1 pfleura2 
*     Jeremy Du Croz, Nag Central Office.
94 1 pfleura2 
*     Sven Hammarling, Nag Central Office.
95 1 pfleura2 
*     Richard Hanson, Sandia National Labs.
96 1 pfleura2 
*
97 1 pfleura2 
*
98 1 pfleura2 
*     .. Parameters ..
99 1 pfleura2 
      DOUBLE PRECISION ZERO
100 1 pfleura2 
      PARAMETER (ZERO=0.0D+0)
101 1 pfleura2 
*     ..
102 1 pfleura2 
*     .. Local Scalars ..
103 1 pfleura2 
      DOUBLE PRECISION TEMP1,TEMP2
104 1 pfleura2 
      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
105 1 pfleura2 
*     ..
106 1 pfleura2 
*     .. External Functions ..
107 1 pfleura2 
      LOGICAL LSAME
108 1 pfleura2 
      EXTERNAL LSAME
109 1 pfleura2 
*     ..
110 1 pfleura2 
*     .. External Subroutines ..
111 1 pfleura2 
      EXTERNAL XERBLA
112 1 pfleura2 
*     ..
113 1 pfleura2 
*     .. Intrinsic Functions ..
114 1 pfleura2 
      INTRINSIC MAX
115 1 pfleura2 
*     ..
116 1 pfleura2 
*
117 1 pfleura2 
*     Test the input parameters.
118 1 pfleura2 
*
119 1 pfleura2 
      INFO = 0
120 1 pfleura2 
      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
121 1 pfleura2 
          INFO = 1
122 1 pfleura2 
      ELSE IF (N.LT.0) THEN
123 1 pfleura2 
          INFO = 2
124 1 pfleura2 
      ELSE IF (INCX.EQ.0) THEN
125 1 pfleura2 
          INFO = 5
126 1 pfleura2 
      ELSE IF (INCY.EQ.0) THEN
127 1 pfleura2 
          INFO = 7
128 1 pfleura2 
      ELSE IF (LDA.LT.MAX(1,N)) THEN
129 1 pfleura2 
          INFO = 9
130 1 pfleura2 
      END IF
131 1 pfleura2 
      IF (INFO.NE.0) THEN
132 1 pfleura2 
          CALL XERBLA('DSYR2 ',INFO)
133 1 pfleura2 
          RETURN
134 1 pfleura2 
      END IF
135 1 pfleura2 
*
136 1 pfleura2 
*     Quick return if possible.
137 1 pfleura2 
*
138 1 pfleura2 
      IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
139 1 pfleura2 
*
140 1 pfleura2 
*     Set up the start points in X and Y if the increments are not both
141 1 pfleura2 
*     unity.
142 1 pfleura2 
*
143 1 pfleura2 
      IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
144 1 pfleura2 
          IF (INCX.GT.0) THEN
145 1 pfleura2 
              KX = 1
146 1 pfleura2 
          ELSE
147 1 pfleura2 
              KX = 1 - (N-1)*INCX
148 1 pfleura2 
          END IF
149 1 pfleura2 
          IF (INCY.GT.0) THEN
150 1 pfleura2 
              KY = 1
151 1 pfleura2 
          ELSE
152 1 pfleura2 
              KY = 1 - (N-1)*INCY
153 1 pfleura2 
          END IF
154 1 pfleura2 
          JX = KX
155 1 pfleura2 
          JY = KY
156 1 pfleura2 
      END IF
157 1 pfleura2 
*
158 1 pfleura2 
*     Start the operations. In this version the elements of A are
159 1 pfleura2 
*     accessed sequentially with one pass through the triangular part
160 1 pfleura2 
*     of A.
161 1 pfleura2 
*
162 1 pfleura2 
      IF (LSAME(UPLO,'U')) THEN
163 1 pfleura2 
*
164 1 pfleura2 
*        Form  A  when A is stored in the upper triangle.
165 1 pfleura2 
*
166 1 pfleura2 
          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
167 1 pfleura2 
              DO 20 J = 1,N
168 1 pfleura2 
                  IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
169 1 pfleura2 
                      TEMP1 = ALPHA*Y(J)
170 1 pfleura2 
                      TEMP2 = ALPHA*X(J)
171 1 pfleura2 
                      DO 10 I = 1,J
172 1 pfleura2 
                          A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
173 1 pfleura2 
   10                 CONTINUE
174 1 pfleura2 
                  END IF
175 1 pfleura2 
   20         CONTINUE
176 1 pfleura2 
          ELSE
177 1 pfleura2 
              DO 40 J = 1,N
178 1 pfleura2 
                  IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
179 1 pfleura2 
                      TEMP1 = ALPHA*Y(JY)
180 1 pfleura2 
                      TEMP2 = ALPHA*X(JX)
181 1 pfleura2 
                      IX = KX
182 1 pfleura2 
                      IY = KY
183 1 pfleura2 
                      DO 30 I = 1,J
184 1 pfleura2 
                          A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
185 1 pfleura2 
                          IX = IX + INCX
186 1 pfleura2 
                          IY = IY + INCY
187 1 pfleura2 
   30                 CONTINUE
188 1 pfleura2 
                  END IF
189 1 pfleura2 
                  JX = JX + INCX
190 1 pfleura2 
                  JY = JY + INCY
191 1 pfleura2 
   40         CONTINUE
192 1 pfleura2 
          END IF
193 1 pfleura2 
      ELSE
194 1 pfleura2 
*
195 1 pfleura2 
*        Form  A  when A is stored in the lower triangle.
196 1 pfleura2 
*
197 1 pfleura2 
          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
198 1 pfleura2 
              DO 60 J = 1,N
199 1 pfleura2 
                  IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
200 1 pfleura2 
                      TEMP1 = ALPHA*Y(J)
201 1 pfleura2 
                      TEMP2 = ALPHA*X(J)
202 1 pfleura2 
                      DO 50 I = J,N
203 1 pfleura2 
                          A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
204 1 pfleura2 
   50                 CONTINUE
205 1 pfleura2 
                  END IF
206 1 pfleura2 
   60         CONTINUE
207 1 pfleura2 
          ELSE
208 1 pfleura2 
              DO 80 J = 1,N
209 1 pfleura2 
                  IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
210 1 pfleura2 
                      TEMP1 = ALPHA*Y(JY)
211 1 pfleura2 
                      TEMP2 = ALPHA*X(JX)
212 1 pfleura2 
                      IX = JX
213 1 pfleura2 
                      IY = JY
214 1 pfleura2 
                      DO 70 I = J,N
215 1 pfleura2 
                          A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
216 1 pfleura2 
                          IX = IX + INCX
217 1 pfleura2 
                          IY = IY + INCY
218 1 pfleura2 
   70                 CONTINUE
219 1 pfleura2 
                  END IF
220 1 pfleura2 
                  JX = JX + INCX
221 1 pfleura2 
                  JY = JY + INCY
222 1 pfleura2 
   80         CONTINUE
223 1 pfleura2 
          END IF
224 1 pfleura2 
      END IF
225 1 pfleura2 
*
226 1 pfleura2 
      RETURN
227 1 pfleura2 
*
228 1 pfleura2 
*     End of DSYR2 .
229 1 pfleura2 
*
230 1 pfleura2 
      END