00001 SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) 00002 * .. Scalar Arguments .. 00003 REAL ALPHA 00004 INTEGER INCX,LDA,N 00005 CHARACTER UPLO 00006 * .. 00007 * .. Array Arguments .. 00008 REAL A(LDA,*),X(*) 00009 * .. 00010 * 00011 * Purpose 00012 * ======= 00013 * 00014 * SSYR performs the symmetric rank 1 operation 00015 * 00016 * A := alpha*x*x' + A, 00017 * 00018 * where alpha is a real scalar, x is an n element vector and A is an 00019 * n by n symmetric matrix. 00020 * 00021 * Arguments 00022 * ========== 00023 * 00024 * UPLO - CHARACTER*1. 00025 * On entry, UPLO specifies whether the upper or lower 00026 * triangular part of the array A is to be referenced as 00027 * follows: 00028 * 00029 * UPLO = 'U' or 'u' Only the upper triangular part of A 00030 * is to be referenced. 00031 * 00032 * UPLO = 'L' or 'l' Only the lower triangular part of A 00033 * is to be referenced. 00034 * 00035 * Unchanged on exit. 00036 * 00037 * N - INTEGER. 00038 * On entry, N specifies the order of the matrix A. 00039 * N must be at least zero. 00040 * Unchanged on exit. 00041 * 00042 * ALPHA - REAL . 00043 * On entry, ALPHA specifies the scalar alpha. 00044 * Unchanged on exit. 00045 * 00046 * X - REAL array of dimension at least 00047 * ( 1 + ( n - 1 )*abs( INCX ) ). 00048 * Before entry, the incremented array X must contain the n 00049 * element vector x. 00050 * Unchanged on exit. 00051 * 00052 * INCX - INTEGER. 00053 * On entry, INCX specifies the increment for the elements of 00054 * X. INCX must not be zero. 00055 * Unchanged on exit. 00056 * 00057 * A - REAL array of DIMENSION ( LDA, n ). 00058 * Before entry with UPLO = 'U' or 'u', the leading n by n 00059 * upper triangular part of the array A must contain the upper 00060 * triangular part of the symmetric matrix and the strictly 00061 * lower triangular part of A is not referenced. On exit, the 00062 * upper triangular part of the array A is overwritten by the 00063 * upper triangular part of the updated matrix. 00064 * Before entry with UPLO = 'L' or 'l', the leading n by n 00065 * lower triangular part of the array A must contain the lower 00066 * triangular part of the symmetric matrix and the strictly 00067 * upper triangular part of A is not referenced. On exit, the 00068 * lower triangular part of the array A is overwritten by the 00069 * lower triangular part of the updated matrix. 00070 * 00071 * LDA - INTEGER. 00072 * On entry, LDA specifies the first dimension of A as declared 00073 * in the calling (sub) program. LDA must be at least 00074 * max( 1, n ). 00075 * Unchanged on exit. 00076 * 00077 * Further Details 00078 * =============== 00079 * 00080 * Level 2 Blas routine. 00081 * 00082 * -- Written on 22-October-1986. 00083 * Jack Dongarra, Argonne National Lab. 00084 * Jeremy Du Croz, Nag Central Office. 00085 * Sven Hammarling, Nag Central Office. 00086 * Richard Hanson, Sandia National Labs. 00087 * 00088 * ===================================================================== 00089 * 00090 * .. Parameters .. 00091 REAL ZERO 00092 PARAMETER (ZERO=0.0E+0) 00093 * .. 00094 * .. Local Scalars .. 00095 REAL TEMP 00096 INTEGER I,INFO,IX,J,JX,KX 00097 * .. 00098 * .. External Functions .. 00099 LOGICAL LSAME 00100 EXTERNAL LSAME 00101 * .. 00102 * .. External Subroutines .. 00103 EXTERNAL XERBLA 00104 * .. 00105 * .. Intrinsic Functions .. 00106 INTRINSIC MAX 00107 * .. 00108 * 00109 * Test the input parameters. 00110 * 00111 INFO = 0 00112 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN 00113 INFO = 1 00114 ELSE IF (N.LT.0) THEN 00115 INFO = 2 00116 ELSE IF (INCX.EQ.0) THEN 00117 INFO = 5 00118 ELSE IF (LDA.LT.MAX(1,N)) THEN 00119 INFO = 7 00120 END IF 00121 IF (INFO.NE.0) THEN 00122 CALL XERBLA('SSYR ',INFO) 00123 RETURN 00124 END IF 00125 * 00126 * Quick return if possible. 00127 * 00128 IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN 00129 * 00130 * Set the start point in X if the increment is not unity. 00131 * 00132 IF (INCX.LE.0) THEN 00133 KX = 1 - (N-1)*INCX 00134 ELSE IF (INCX.NE.1) THEN 00135 KX = 1 00136 END IF 00137 * 00138 * Start the operations. In this version the elements of A are 00139 * accessed sequentially with one pass through the triangular part 00140 * of A. 00141 * 00142 IF (LSAME(UPLO,'U')) THEN 00143 * 00144 * Form A when A is stored in upper triangle. 00145 * 00146 IF (INCX.EQ.1) THEN 00147 DO 20 J = 1,N 00148 IF (X(J).NE.ZERO) THEN 00149 TEMP = ALPHA*X(J) 00150 DO 10 I = 1,J 00151 A(I,J) = A(I,J) + X(I)*TEMP 00152 10 CONTINUE 00153 END IF 00154 20 CONTINUE 00155 ELSE 00156 JX = KX 00157 DO 40 J = 1,N 00158 IF (X(JX).NE.ZERO) THEN 00159 TEMP = ALPHA*X(JX) 00160 IX = KX 00161 DO 30 I = 1,J 00162 A(I,J) = A(I,J) + X(IX)*TEMP 00163 IX = IX + INCX 00164 30 CONTINUE 00165 END IF 00166 JX = JX + INCX 00167 40 CONTINUE 00168 END IF 00169 ELSE 00170 * 00171 * Form A when A is stored in lower triangle. 00172 * 00173 IF (INCX.EQ.1) THEN 00174 DO 60 J = 1,N 00175 IF (X(J).NE.ZERO) THEN 00176 TEMP = ALPHA*X(J) 00177 DO 50 I = J,N 00178 A(I,J) = A(I,J) + X(I)*TEMP 00179 50 CONTINUE 00180 END IF 00181 60 CONTINUE 00182 ELSE 00183 JX = KX 00184 DO 80 J = 1,N 00185 IF (X(JX).NE.ZERO) THEN 00186 TEMP = ALPHA*X(JX) 00187 IX = JX 00188 DO 70 I = J,N 00189 A(I,J) = A(I,J) + X(IX)*TEMP 00190 IX = IX + INCX 00191 70 CONTINUE 00192 END IF 00193 JX = JX + INCX 00194 80 CONTINUE 00195 END IF 00196 END IF 00197 * 00198 RETURN 00199 * 00200 * End of SSYR . 00201 * 00202 END
1.7.2