* F06QSF Example Program Text * Mark 20 Revised. NAG Copyright 2001. * Mark 20 Revised. To call thread-safe G05 routines. * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) DOUBLE PRECISION RROGUE, ZERO PARAMETER (RROGUE=-1.0D+10,ZERO=0.0D+0) INTEGER LDA, NMAX PARAMETER (LDA=17,NMAX=5) * .. Local Scalars .. DOUBLE PRECISION DIF, TOL INTEGER I, IGEN, J, K1, K2, KK1, KK2, N, NN, ONCER, SID LOGICAL PASS CHARACTER SIDE * .. Local Arrays .. DOUBLE PRECISION A(LDA,LDA), C(LDA), S(LDA), SAVA(LDA,LDA), + SAVS(LDA) INTEGER ENS(5), ISEED(4) * .. External Functions .. DOUBLE PRECISION G05KAF, X02AJF EXTERNAL G05KAF, X02AJF * .. External Subroutines .. EXTERNAL F06QSF, F06QWF, G05KBX * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. Data statements .. DATA ENS/0, 1, 2, 8, 17/ * .. Executable Statements .. WRITE (NOUT,99999) TOL = X02AJF()*100 * * Initialise seed for G05KAF. * CALL G05KBX(IGEN,ISEED) PASS = .TRUE. DO 400 SID = 1, 2 IF (SID.EQ.1) THEN SIDE = 'L' ELSE SIDE = 'R' END IF DO 380 NN = 1, NMAX N = ENS(NN) DO 360 KK1 = 1, NMAX K1 = ENS(KK1) DO 340 KK2 = 1, NMAX K2 = ENS(KK2) DO 320 ONCER = 0, 1 DO 60 I = 1, N A(I,I) = G05KAF(IGEN,ISEED) SAVA(I,I) = A(I,I) IF (I.GE.K1 .AND. I.LT.K2) THEN IF (ONCER.EQ.1) THEN S(I) = ZERO ELSE S(I) = G05KAF(IGEN,ISEED) END IF SAVS(I) = S(I) ELSE S(I) = RROGUE END IF DO 20 J = 1, I - 1 A(I,J) = RROGUE SAVA(I,J) = RROGUE 20 CONTINUE DO 40 J = I + 1, N A(I,J) = G05KAF(IGEN,ISEED) SAVA(I,J) = A(I,J) 40 CONTINUE 60 CONTINUE IF (N.GT.0) S(N) = RROGUE CALL F06QSF(SIDE,N,K1,K2,C,S,A,LDA) * Check whether A has been changed below diagonal by * F06QSF. DO 100 I = 2, N DO 80 J = 1, I - 1 IF (A(I,J).NE.RROGUE) THEN WRITE (NOUT,99998) I, J WRITE (NOUT,99993) 'QSF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 80 CONTINUE 100 CONTINUE * Check whether 'unreferenced' parts of S have * changed. DO 120 I = 1, MIN(K1-1,N) IF (S(I).NE.RROGUE) THEN WRITE (NOUT,99997) I WRITE (NOUT,99993) 'QSF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 120 CONTINUE DO 140 I = MAX(K2+1,1), N IF (S(I).NE.RROGUE) THEN WRITE (NOUT,99997) I WRITE (NOUT,99993) 'QSF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 140 CONTINUE IF (MIN(N,K1).GE.1 .AND. K2.GT.K1 .AND. K2.LE.N) + THEN * Take the Hermitian transpose of P. DO 160 I = K1, K2 - 1 S(I) = -S(I) 160 CONTINUE END IF * CALL F06QWF(SIDE,N,K1,K2,C,S,A,LDA) * * Check whether A has been changed below diagonal by * F06QWF. DO 200 I = 2, N DO 180 J = 1, I - 1 IF (A(I,J).NE.RROGUE) THEN WRITE (NOUT,99998) I, J WRITE (NOUT,99993) 'QWF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 180 CONTINUE 200 CONTINUE DO 220 I = 1, MIN(K1-1,N) IF (S(I).NE.RROGUE) THEN WRITE (NOUT,99997) I WRITE (NOUT,99993) 'QWF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 220 CONTINUE DO 240 I = MAX(K2+1,1), N IF (S(I).NE.RROGUE) THEN WRITE (NOUT,99997) I WRITE (NOUT,99993) 'QWF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99996) PASS = .FALSE. GO TO 420 END IF 240 CONTINUE * The two transformations should cancel each other, * i.e. A and S should end up as they were originally. * Compare with the saved arrays. DO 280 I = 1, N DO 260 J = I, N DIF = ABS(A(I,J)-SAVA(I,J)) IF (DIF.GT.TOL) THEN WRITE (NOUT,99995) I, J WRITE (NOUT,99993) 'QSF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99993) 'QWF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99992) A(I,J), SAVA(I,J) PASS = .FALSE. GO TO 420 END IF 260 CONTINUE 280 CONTINUE DO 300 I = MAX(K1,1), MIN(K2,N) - 1 DIF = ABS(S(I)-SAVS(I)) IF (DIF.GT.TOL) THEN WRITE (NOUT,99994) I WRITE (NOUT,99993) 'QSF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99993) 'QWF', SIDE, N, K1, + K2, LDA WRITE (NOUT,99991) S(I), SAVS(I) PASS = .FALSE. GO TO 420 END IF 300 CONTINUE 320 CONTINUE 340 CONTINUE 360 CONTINUE 380 CONTINUE 400 CONTINUE 420 IF (PASS) THEN WRITE (NOUT,99990) ELSE WRITE (NOUT,99989) END IF STOP * 99999 FORMAT (' F06QSF Example Program Results',/1X) 99998 FORMAT (' Element A(',I3,',',I3,') was altered by the call:') 99997 FORMAT (' Element S(',I3,') was altered by the call:') 99996 FORMAT (' although it should not have been referenced.') 99995 FORMAT (' Element A(',I3,',',I3,') was incorrectly computed by t', + 'he calls:') 99994 FORMAT (' Element S(',I3,') was incorrectly computed by the call', + 's:') 99993 FORMAT (' CALL F06',A,'(''',A,''',',I3,',',I3,',',I3,',C,S,A,',I3, + ')') 99992 FORMAT (' as ',1P,D13.5,' instead of',D13.5,' .') 99991 FORMAT (' as ',1P,D13.5,' instead of',D13.5,' .') 99990 FORMAT (' F06QSF Example Program ends OK') 99989 FORMAT (' F06QSF Example Program ends with ERRORS') END