* F08YGF Example Program Text * Mark 21 Release. NAG Copyright 2004. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) INTEGER NMAX PARAMETER (NMAX=8) INTEGER LDQ, LDA, LDB, LDZ, LIWORK, LWORK PARAMETER (LDQ=NMAX,LDA=NMAX,LDB=NMAX,LDZ=NMAX, + LIWORK=(NMAX*NMAX)/2+6,LWORK=NMAX*(NMAX+4)+16) * .. Local Scalars .. DOUBLE PRECISION PL, PR INTEGER I, IFAIL, IJOB, INFO, J, M, N LOGICAL WANTQ, WANTZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), + B(LDB,NMAX), BETA(NMAX), DIF(2), Q(LDQ,NMAX), + WORK(LWORK), Z(LDZ,NMAX) INTEGER IWORK(LIWORK) LOGICAL SELECT(NMAX) * .. External Subroutines .. EXTERNAL DTGSEN, X04CAF * .. Executable Statements .. WRITE (NOUT,*) 'F08YGF Example Program Results' WRITE (NOUT,*) * Skip heading in data file READ (NIN,*) READ (NIN,*) N IF (N.LE.NMAX) THEN * * Read A, B, Q, Z and the logical array SELECT from data file * READ (NIN,*) ((A(I,J),J=1,N),I=1,N) READ (NIN,*) ((B(I,J),J=1,N),I=1,N) READ (NIN,*) ((Q(I,J),J=1,N),I=1,N) READ (NIN,*) ((Z(I,J),J=1,N),I=1,N) * READ (NIN,*) (SELECT(I),I=1,N) * * Set IJOB, WANTQ and WANTZ IJOB = 4 WANTQ = .TRUE. WANTZ = .TRUE. * * Reorder the Schur factors A and B and update the matrices * Q and Z * CALL DTGSEN(IJOB,WANTQ,WANTZ,SELECT,N,A,LDA,B,LDB,ALPHAR, + ALPHAI,BETA,Q,LDQ,Z,LDZ,M,PL,PR,DIF,WORK,LWORK, + IWORK,LIWORK,INFO) IF (INFO.GT.0) THEN WRITE (NOUT,99999) INFO WRITE (NOUT,*) END IF * * Print reordered generalized Schur form * IFAIL = 0 CALL X04CAF('General',' ',N,N,A,LDA,'Reordered Schur matrix A', + IFAIL) * WRITE (NOUT,*) IFAIL = 0 CALL X04CAF('General',' ',N,N,B,LDB,'Reordered Schur matrix B', + IFAIL) * * Print deflating subspaces * WRITE (NOUT,*) IFAIL = 0 CALL X04CAF('General',' ',N,M,Q,LDQ, + 'Basis of left deflating invariant subspace',IFAIL) * WRITE (NOUT,*) IFAIL = 0 CALL X04CAF('General',' ',N,M,Z,LDZ, + 'Basis of right deflating invariant subspace', + IFAIL) * WRITE (NOUT,*) WRITE (NOUT,99998) 'Norm estimate of projection onto', + ' left eigenspace for selected cluster', 1.0D0/PL WRITE (NOUT,*) WRITE (NOUT,99998) 'Norm estimate of projection onto', + ' right eigenspace for selected cluster', 1.0D0/PR WRITE (NOUT,*) WRITE (NOUT,99998) 'F-norm based upper bound on', ' Difu', + DIF(1) WRITE (NOUT,*) WRITE (NOUT,99998) 'F-norm based upper bound on', ' Difl', + DIF(2) ELSE WRITE (NOUT,*) 'NMAX too small' END IF * 99999 FORMAT (' Reordering could not be completed. INFO = ',I3) 99998 FORMAT (1X,2A,/1X,1P,E10.2) END