gnu / gcc / 1f16a020acbea0af26209478990b83b1a1ba3a2b / . / gcc / testsuite / gfortran.dg / pr36206.f

! { 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 |