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