![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zher.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / blas|
Return to zher.f CVS log | Up to [local] / rpl / lapack / blas |
1.1 bertrand 1: SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA)
2: * .. Scalar Arguments ..
3: DOUBLE PRECISION ALPHA
4: INTEGER INCX,LDA,N
5: CHARACTER UPLO
6: * ..
7: * .. Array Arguments ..
8: DOUBLE COMPLEX A(LDA,*),X(*)
9: * ..
10: *
11: * Purpose
12: * =======
13: *
14: * ZHER performs the hermitian rank 1 operation
15: *
1.7 ! bertrand 16: * A := alpha*x*x**H + A,
1.1 bertrand 17: *
18: * where alpha is a real scalar, x is an n element vector and A is an
19: * n by n hermitian matrix.
20: *
21: * Arguments
22: * ==========
23: *
24: * UPLO - CHARACTER*1.
25: * On entry, UPLO specifies whether the upper or lower
26: * triangular part of the array A is to be referenced as
27: * follows:
28: *
29: * UPLO = 'U' or 'u' Only the upper triangular part of A
30: * is to be referenced.
31: *
32: * UPLO = 'L' or 'l' Only the lower triangular part of A
33: * is to be referenced.
34: *
35: * Unchanged on exit.
36: *
37: * N - INTEGER.
38: * On entry, N specifies the order of the matrix A.
39: * N must be at least zero.
40: * Unchanged on exit.
41: *
42: * ALPHA - DOUBLE PRECISION.
43: * On entry, ALPHA specifies the scalar alpha.
44: * Unchanged on exit.
45: *
46: * X - COMPLEX*16 array of dimension at least
47: * ( 1 + ( n - 1 )*abs( INCX ) ).
48: * Before entry, the incremented array X must contain the n
49: * element vector x.
50: * Unchanged on exit.
51: *
52: * INCX - INTEGER.
53: * On entry, INCX specifies the increment for the elements of
54: * X. INCX must not be zero.
55: * Unchanged on exit.
56: *
57: * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
58: * Before entry with UPLO = 'U' or 'u', the leading n by n
59: * upper triangular part of the array A must contain the upper
60: * triangular part of the hermitian matrix and the strictly
61: * lower triangular part of A is not referenced. On exit, the
62: * upper triangular part of the array A is overwritten by the
63: * upper triangular part of the updated matrix.
64: * Before entry with UPLO = 'L' or 'l', the leading n by n
65: * lower triangular part of the array A must contain the lower
66: * triangular part of the hermitian matrix and the strictly
67: * upper triangular part of A is not referenced. On exit, the
68: * lower triangular part of the array A is overwritten by the
69: * lower triangular part of the updated matrix.
70: * Note that the imaginary parts of the diagonal elements need
71: * not be set, they are assumed to be zero, and on exit they
72: * are set to zero.
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: * Further Details
81: * ===============
82: *
83: * Level 2 Blas routine.
84: *
85: * -- Written on 22-October-1986.
86: * Jack Dongarra, Argonne National Lab.
87: * Jeremy Du Croz, Nag Central Office.
88: * Sven Hammarling, Nag Central Office.
89: * Richard Hanson, Sandia National Labs.
90: *
91: * =====================================================================
92: *
93: * .. Parameters ..
94: DOUBLE COMPLEX ZERO
95: PARAMETER (ZERO= (0.0D+0,0.0D+0))
96: * ..
97: * .. Local Scalars ..
98: DOUBLE COMPLEX TEMP
99: INTEGER I,INFO,IX,J,JX,KX
100: * ..
101: * .. External Functions ..
102: LOGICAL LSAME
103: EXTERNAL LSAME
104: * ..
105: * .. External Subroutines ..
106: EXTERNAL XERBLA
107: * ..
108: * .. Intrinsic Functions ..
109: INTRINSIC DBLE,DCONJG,MAX
110: * ..
111: *
112: * Test the input parameters.
113: *
114: INFO = 0
115: IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
116: INFO = 1
117: ELSE IF (N.LT.0) THEN
118: INFO = 2
119: ELSE IF (INCX.EQ.0) THEN
120: INFO = 5
121: ELSE IF (LDA.LT.MAX(1,N)) THEN
122: INFO = 7
123: END IF
124: IF (INFO.NE.0) THEN
125: CALL XERBLA('ZHER ',INFO)
126: RETURN
127: END IF
128: *
129: * Quick return if possible.
130: *
131: IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN
132: *
133: * Set the start point in X if the increment is not unity.
134: *
135: IF (INCX.LE.0) THEN
136: KX = 1 - (N-1)*INCX
137: ELSE IF (INCX.NE.1) THEN
138: KX = 1
139: END IF
140: *
141: * Start the operations. In this version the elements of A are
142: * accessed sequentially with one pass through the triangular part
143: * of A.
144: *
145: IF (LSAME(UPLO,'U')) THEN
146: *
147: * Form A when A is stored in upper triangle.
148: *
149: IF (INCX.EQ.1) THEN
150: DO 20 J = 1,N
151: IF (X(J).NE.ZERO) THEN
152: TEMP = ALPHA*DCONJG(X(J))
153: DO 10 I = 1,J - 1
154: A(I,J) = A(I,J) + X(I)*TEMP
155: 10 CONTINUE
156: A(J,J) = DBLE(A(J,J)) + DBLE(X(J)*TEMP)
157: ELSE
158: A(J,J) = DBLE(A(J,J))
159: END IF
160: 20 CONTINUE
161: ELSE
162: JX = KX
163: DO 40 J = 1,N
164: IF (X(JX).NE.ZERO) THEN
165: TEMP = ALPHA*DCONJG(X(JX))
166: IX = KX
167: DO 30 I = 1,J - 1
168: A(I,J) = A(I,J) + X(IX)*TEMP
169: IX = IX + INCX
170: 30 CONTINUE
171: A(J,J) = DBLE(A(J,J)) + DBLE(X(JX)*TEMP)
172: ELSE
173: A(J,J) = DBLE(A(J,J))
174: END IF
175: JX = JX + INCX
176: 40 CONTINUE
177: END IF
178: ELSE
179: *
180: * Form A when A is stored in lower triangle.
181: *
182: IF (INCX.EQ.1) THEN
183: DO 60 J = 1,N
184: IF (X(J).NE.ZERO) THEN
185: TEMP = ALPHA*DCONJG(X(J))
186: A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(J))
187: DO 50 I = J + 1,N
188: A(I,J) = A(I,J) + X(I)*TEMP
189: 50 CONTINUE
190: ELSE
191: A(J,J) = DBLE(A(J,J))
192: END IF
193: 60 CONTINUE
194: ELSE
195: JX = KX
196: DO 80 J = 1,N
197: IF (X(JX).NE.ZERO) THEN
198: TEMP = ALPHA*DCONJG(X(JX))
199: A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(JX))
200: IX = JX
201: DO 70 I = J + 1,N
202: IX = IX + INCX
203: A(I,J) = A(I,J) + X(IX)*TEMP
204: 70 CONTINUE
205: ELSE
206: A(J,J) = DBLE(A(J,J))
207: END IF
208: JX = JX + INCX
209: 80 CONTINUE
210: END IF
211: END IF
212: *
213: RETURN
214: *
215: * End of ZHER .
216: *
217: END