* 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, LDS, LDT, LDZ, LIWORK, LWORK PARAMETER (LDQ=NMAX,LDS=NMAX,LDT=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 ALPHAI(NMAX), ALPHAR(NMAX), BETA(NMAX), DIF(2), + Q(LDQ,NMAX), S(LDS,NMAX), T(LDT,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 S, T, Q, Z and the logical array SELECT from data file * READ (NIN,*) ((S(I,J),J=1,N),I=1,N) READ (NIN,*) ((T(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 S and T and update the matrices * Q and Z * CALL DTGSEN(IJOB,WANTQ,WANTZ,SELECT,N,S,LDS,T,LDT,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,S,LDS,'Reordered Schur matrix S', + IFAIL) * WRITE (NOUT,*) IFAIL = 0 CALL X04CAF('General',' ',N,N,T,LDT,'Reordered Schur matrix T', + 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 STOP * 99999 FORMAT (' Reordering could not be completed. INFO = ',I3) 99998 FORMAT (1X,2A,/1X,1P,E10.2) END