gcc/testsuite/gfortran.dg/pr43796.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-O2 -fcheck=bounds" }
   3
   4     FUNCTION F06FKFN(N,W,INCW,X,INCX)
   5        IMPLICIT NONE
   6        INTEGER, PARAMETER :: WP = KIND(0.0D0)
   7        REAL (KIND=WP)                  :: F06FKFN
   8        REAL (KIND=WP), PARAMETER       :: ONE = 1.0E+0_WP
   9        REAL (KIND=WP), PARAMETER       :: ZERO = 0.0E+0_WP
  10        INTEGER, INTENT (IN)            :: INCW, INCX, N
  11        REAL (KIND=WP), INTENT (IN)     :: W(*), X(*)
  12        REAL (KIND=WP)                  :: ABSYI, NORM, SCALE, SSQ
  13        INTEGER                         :: I, IW, IX
  14        REAL (KIND=WP), EXTERNAL        :: F06BMFN
  15        INTRINSIC                          ABS, SQRT
  16        IF (N<1) THEN
  17           NORM = ZERO
  18        ELSE IF (N==1) THEN
  19           NORM = SQRT(W(1))*ABS(X(1))
  20        ELSE
  21           IF (INCW>0) THEN
  22              IW = 1
  23           ELSE
  24              IW = 1 - (N-1)*INCW
  25           END IF
  26           IF (INCX>0) THEN
  27              IX = 1
  28           ELSE
  29              IX = 1 - (N-1)*INCX
  30           END IF
  31           SCALE = ZERO
  32           SSQ = ONE
  33           DO I = 1, N
  34              IF ((W(IW)/=ZERO) .AND. (X(IX)/=ZERO)) THEN
  35                 ABSYI = SQRT(W(IW))*ABS(X(IX))
  36                 IF (SCALE<ABSYI) THEN
  37                    SSQ = 1 + SSQ*(SCALE/ABSYI)**2
  38                    SCALE = ABSYI
  39                 ELSE
  40                    SSQ = SSQ + (ABSYI/SCALE)**2
  41                 END IF
  42              END IF
  43              IW = IW + INCW
  44              IX = IX + INCX
  45           END DO
  46           NORM = F06BMFN(SCALE,SSQ)
  47        END IF
  48        F06FKFN = NORM
  49        RETURN
  50     END FUNCTION F06FKFN
  51