blob: 7b0b56639dde42e105082b1509dcf130d2ec80fb [file] [log] [blame]
! { 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