| ! { dg-do compile } |
| ! { dg-options "-O3" } |
| ! PR fortran/36206 |
| |
| SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) |
| REAL ALPHA |
| INTEGER INCX,N |
| CHARACTER UPLO |
| REAL AP(*),X(*) |
| REAL ZERO |
| PARAMETER (ZERO=0.0E+0) |
| REAL TEMP |
| INTEGER I,INFO,IX,J,JX,K,KK,KX |
| LOGICAL LSAME |
| EXTERNAL LSAME |
| EXTERNAL XERBLA |
| |
| INFO = 0 |
| IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN |
| INFO = 1 |
| ELSE IF (N.LT.0) THEN |
| INFO = 2 |
| ELSE IF (INCX.EQ.0) THEN |
| INFO = 5 |
| END IF |
| IF (INFO.NE.0) THEN |
| CALL XERBLA('SSPR ',INFO) |
| RETURN |
| END IF |
| IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN |
| IF (INCX.LE.0) THEN |
| KX = 1 - (N-1)*INCX |
| ELSE IF (INCX.NE.1) THEN |
| KX = 1 |
| END IF |
| KK = 1 |
| IF (LSAME(UPLO,'U')) THEN |
| IF (INCX.EQ.1) THEN |
| DO 20 J = 1,N |
| IF (X(J).NE.ZERO) THEN |
| TEMP = ALPHA*X(J) |
| K = KK |
| DO 10 I = 1,J |
| AP(K) = AP(K) + X(I)*TEMP |
| K = K + 1 |
| 10 CONTINUE |
| END IF |
| KK = KK + J |
| 20 CONTINUE |
| ELSE |
| JX = KX |
| DO 40 J = 1,N |
| IF (X(JX).NE.ZERO) THEN |
| TEMP = ALPHA*X(JX) |
| IX = KX |
| DO 30 K = KK,KK + J - 1 |
| AP(K) = AP(K) + X(IX)*TEMP |
| IX = IX + INCX |
| 30 CONTINUE |
| END IF |
| JX = JX + INCX |
| KK = KK + J |
| 40 CONTINUE |
| END IF |
| ELSE |
| IF (INCX.EQ.1) THEN |
| DO 60 J = 1,N |
| IF (X(J).NE.ZERO) THEN |
| TEMP = ALPHA*X(J) |
| K = KK |
| DO 50 I = J,N |
| AP(K) = AP(K) + X(I)*TEMP |
| K = K + 1 |
| 50 CONTINUE |
| END IF |
| KK = KK + N - J + 1 |
| 60 CONTINUE |
| ELSE |
| JX = KX |
| DO 80 J = 1,N |
| IF (X(JX).NE.ZERO) THEN |
| TEMP = ALPHA*X(JX) |
| IX = JX |
| DO 70 K = KK,KK + N - J |
| AP(K) = AP(K) + X(IX)*TEMP |
| IX = IX + INCX |
| 70 CONTINUE |
| END IF |
| JX = JX + INCX |
| KK = KK + N - J + 1 |
| 80 CONTINUE |
| END IF |
| END IF |
| RETURN |
| END |
