* F06QQF Example Program Text * Mark 20 Revised. NAG Copyright 2001. * Mark 20 Revised. To call thread-safe G05 routines. * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) INTEGER LDA, INCMAX, NINCS, NMAX PARAMETER (LDA=18,INCMAX=5,NINCS=3,NMAX=5) DOUBLE PRECISION RROGUE, ZERO PARAMETER (RROGUE=-1.0D+10,ZERO=0.0D+0) * .. Local Scalars .. DOUBLE PRECISION ALPHA, DIF, TOL INTEGER I, IGEN, INC, INCX, J, N, NN LOGICAL PASS * .. Local Arrays .. DOUBLE PRECISION A(LDA,LDA), C(LDA), S(LDA), SAVA(LDA,LDA), + SAVX(LDA*INCMAX), X(LDA*INCMAX) INTEGER ENS(NMAX), INCS(NINCS), ISEED(4) * .. External Functions .. DOUBLE PRECISION G05KAF, X02AJF EXTERNAL G05KAF, X02AJF * .. External Subroutines .. EXTERNAL F06QQF, F06QXF, G05KBX * .. Intrinsic Functions .. INTRINSIC ABS * .. Data statements .. DATA ENS/0, 1, 2, 8, 17/ DATA INCS/1, 3, 5/ * .. Executable Statements .. WRITE (NOUT,99999) TOL = X02AJF()*100 * * Initialise seed for G05KAF. * CALL G05KBX(IGEN,ISEED) PASS = .TRUE. DO 380 NN = 1, NMAX N = ENS(NN) DO 40 I = 1, N DO 20 J = I, N SAVA(I,J) = G05KAF(IGEN,ISEED) IF (I.NE.J) THEN SAVA(J,I) = RROGUE END IF 20 CONTINUE 40 CONTINUE DO 60 I = 1, N + 1 SAVA(I,N+1) = ZERO SAVA(N+1,I) = ZERO 60 CONTINUE DO 360 INC = 1, NINCS INCX = INCS(INC) DO 100 I = 1, (N-1)*INCX + 1, INCX X(I) = G05KAF(IGEN,ISEED) SAVX(I) = X(I) DO 80 J = I + 1, I + INCX - 1 X(J) = RROGUE SAVX(J) = X(J) 80 CONTINUE 100 CONTINUE ALPHA = G05KAF(IGEN,ISEED) * Copy A from SAVA. DO 140 I = 1, N + 1 DO 120 J = 1, N + 1 A(I,J) = SAVA(I,J) 120 CONTINUE 140 CONTINUE * Factorise A into QR. CALL F06QQF(N,ALPHA,X,INCX,A,LDA,C,S) * Check that below diagonal has not been altered. DO 180 I = 1, N DO 160 J = 1, I - 1 IF (A(I,J).NE.RROGUE) THEN WRITE (NOUT,99998) I, J WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 400 END IF 160 CONTINUE 180 CONTINUE * Check that zeros in row and column N+1 are unchanged. DO 200 I = 1, N + 1 IF (A(I,N+1).NE.ZERO) THEN WRITE (NOUT,99998) I, N + 1 WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 400 ELSE IF (A(N+1,I).NE.ZERO) THEN WRITE (NOUT,99998) N + 1, I WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 400 END IF 200 CONTINUE * Check that 'unreferenced' elements of X have not been * altered. DO 240 I = 1, (N-1)*INCX + 1, INCX DO 220 J = I + 1, I + INCX - 1 IF (X(J).NE.RROGUE) THEN WRITE (NOUT,99995) J WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 400 END IF 220 CONTINUE 240 CONTINUE * Set Q = Q'. DO 260 I = 1, N S(I) = -S(I) 260 CONTINUE * Insert zeros below diagonal of A for call to F06QXF. DO 300 I = 1, N DO 280 J = 1, I - 1 A(I,J) = ZERO 280 CONTINUE 300 CONTINUE * Premultiply R by Q. CALL F06QXF('L','B','B',N+1,N,1,N+1,C,S,A,LDA) * Now (A) should be the same as ( SAVA ) . * (ALPHA*X') DO 340 I = 1, N DO 320 J = I, N DIF = ABS(A(I,J)-SAVA(I,J)) IF (DIF.GT.TOL) THEN WRITE (NOUT,99994) I, J WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99993) N + 1, N + 1, 1, N + 1, LDA WRITE (NOUT,99992) A(I,J), SAVA(I,J) PASS = .FALSE. GO TO 400 END IF 320 CONTINUE DIF = ABS(A(N+1,I)-ALPHA*SAVX((I-1)*INCX+1)) IF (DIF.GT.TOL) THEN WRITE (NOUT,99994) N + 1, I WRITE (NOUT,99997) N, ALPHA, INCX, LDA WRITE (NOUT,99993) N + 1, N + 1, 1, N + 1, LDA WRITE (NOUT,99992) A(N+1,I), SAVX((I-1)*INCX+1) PASS = .FALSE. GO TO 400 END IF 340 CONTINUE 360 CONTINUE 380 CONTINUE 400 IF (PASS) THEN WRITE (NOUT,99991) ELSE WRITE (NOUT,99990) END IF STOP * 99999 FORMAT (' F06QQF Example Program Results',/1X) 99998 FORMAT (' Element A(',I3,',',I3,') was altered by the call:') 99997 FORMAT (' CALL F06QQF(',I3,',',1P,D13.5,',X,',I3,',A,',I3,',C,S)') 99996 FORMAT (' although it should not have been referenced.') 99995 FORMAT (' Element X(',I3,') was altered by the call:') 99994 FORMAT (' Element A(',I3,',',I3,') was incorrectly computed by t', + 'he calls:') 99993 FORMAT (' CALL F06QXF(''L'',''B'',''B'',',I3,',',I3,',',I3,',',I3, + ',C,S,A,',I3,')') 99992 FORMAT (' as ',1P,D13.5,' instead of ',D13.5,' .') 99991 FORMAT (' F06QQF Example Program ends OK') 99990 FORMAT (' F06QQF Example Program ends with ERRORS') END