* F06QTF 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 ONE, RROGUE, ZERO PARAMETER (ONE=1.0D+0,RROGUE=-1.0D+10,ZERO=0.0D+0) INTEGER LDA, NMAX PARAMETER (LDA=17,NMAX=5) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, IGEN, J, K1, K2, KK1, KK2, N, NN, SID LOGICAL PASS CHARACTER SIDE * .. Local Arrays .. DOUBLE PRECISION A(LDA,LDA), CP(LDA), CQ(LDA), SAVA(LDA,LDA), + SP(LDA), SQ(LDA) INTEGER ENS(NMAX), ISEED(4) * .. External Functions .. DOUBLE PRECISION G05KAF, X02AJF EXTERNAL G05KAF, X02AJF * .. External Subroutines .. EXTERNAL F06QTF, F06QXF, G05KBX * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. 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 240 SID = 1, 2 IF (SID.EQ.1) THEN SIDE = 'L' ELSE SIDE = 'R' END IF DO 220 NN = 1, NMAX N = ENS(NN) DO 200 KK1 = 1, NN K1 = ENS(KK1) DO 180 KK2 = 1, NN K2 = ENS(KK2) * Create a unitary matrix P. DO 20 I = 1, N - 1 CP(I) = G05KAF(IGEN,ISEED) SP(I) = SQRT(ONE-CP(I)*CP(I)) CQ(I) = CP(I) SQ(I) = SP(I) 20 CONTINUE * Generate a random triangular matrix, A, and copy it. DO 60 I = 1, N DO 40 J = I, N A(I,J) = G05KAF(IGEN,ISEED) SAVA(I,J) = A(I,J) IF (I.NE.J) A(J,I) = RROGUE 40 CONTINUE 60 CONTINUE * CALL F06QTF(SIDE,N,K1,K2,CQ,SQ,A,LDA) * * Check that 'unreferenced' elements below diagonal * are unchanged, and replace them by zeros for the * calls to F06QXF below. DO 100 I = 1, N DO 80 J = 1, I - 1 IF (A(I,J).NE.RROGUE) THEN WRITE (NOUT,99997) I, J WRITE (NOUT,99994) SIDE, N, K1, K2, LDA WRITE (NOUT,99998) PASS = .FALSE. GO TO 260 ELSE A(I,J) = ZERO END IF 80 CONTINUE 100 CONTINUE * Take the Hermitian transposes of P and Q. DO 120 I = 1, N - 1 SP(I) = -SP(I) SQ(I) = -SQ(I) 120 CONTINUE IF (SIDE.EQ.'L') THEN * Hit A from the left with P'. CALL F06QXF('L','V','B',N,N,K1,K2,CP,SP,A,LDA) * Hit A from the right with Q. CALL F06QXF('R','V','B',N,N,K1,K2,CQ,SQ,A,LDA) ELSE * Hit A from the left with Q'. CALL F06QXF('L','V','F',N,N,K1,K2,CQ,SQ,A,LDA) * Hit A from the right with P. CALL F06QXF('R','V','F',N,N,K1,K2,CP,SP,A,LDA) END IF * Now A should be as it was originally. * Check that all elements were computed correctly. DO 160 I = 1, N DO 140 J = I, N IF (ABS(A(I,J)-SAVA(I,J)).GT.TOL) THEN WRITE (NOUT,99995) I, J WRITE (NOUT,99994) SIDE, N, K1, K2, LDA WRITE (NOUT,99996) IF (SIDE.EQ.'L') THEN WRITE (NOUT,99993) 'L', 'V', 'B', N, + N, K1, K2, 'CP', 'SP', LDA WRITE (NOUT,99993) 'R', 'V', 'F', N, + N, K1, K2, 'CQ', 'SQ', LDA ELSE WRITE (NOUT,99993) 'L', 'V', 'B', N, + N, K1, K2, 'CQ', 'SQ', LDA WRITE (NOUT,99993) 'R', 'V', 'F', N, + N, K1, K2, 'CP', 'SP', LDA END IF WRITE (NOUT,99992) A(I,J), SAVA(I,J) PASS = .FALSE. GO TO 260 END IF 140 CONTINUE 160 CONTINUE 180 CONTINUE 200 CONTINUE 220 CONTINUE 240 CONTINUE 260 IF (PASS) THEN WRITE (NOUT,99991) ELSE WRITE (NOUT,99990) END IF STOP * 99999 FORMAT (' F06QTF Example Program Results',/1X) 99998 FORMAT (' although it should not have been referenced.') 99997 FORMAT (' Element A(',I3,',',I3,') was altered by the call:') 99996 FORMAT (' P = P''',/' Q = Q''') 99995 FORMAT (' Element A(',I3,',',I3,') was incorrectly computed by t', + 'he sequence:') 99994 FORMAT (' CALL F06QTF(''',A,''',',I3,',',I3,',',I3,',CQ,SQ,A,',I3, + ')') 99993 FORMAT (' CALL F06QXF(''',A,''',''',A,''',''',A,''',',I3,',',I3, + ',',I3,',',I3,',',A,',',A,',A,',I3,')') 99992 FORMAT (' as ',1P,D13.5,' instead of ',D13.5,' .') 99991 FORMAT (' F06QTF Example Program ends OK') 99990 FORMAT (' F06QTF Example Program ends with ERRORS') END