*     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