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 52