* F08YUF 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+2,LWORK=NMAX*NMAX) * .. Local Scalars .. DOUBLE PRECISION PL, PR INTEGER I, IFAIL, IJOB, INFO, J, M, N LOGICAL WANTQ, WANTZ * .. Local Arrays .. COMPLEX *16 ALPHA(NMAX), BETA(NMAX), Q(LDQ,NMAX), + S(LDS,NMAX), T(LDT,NMAX), WORK(LWORK), + Z(LDZ,NMAX) DOUBLE PRECISION DIF(2) INTEGER IWORK(LIWORK) LOGICAL SELECT(NMAX) CHARACTER CLABS(1), RLABS(1) * .. External Subroutines .. EXTERNAL X04DBF, ZTGSEN * .. Executable Statements .. WRITE (NOUT,*) 'F08YUF 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 ZTGSEN(IJOB,WANTQ,WANTZ,SELECT,N,S,LDS,T,LDT,ALPHA,BETA,Q, + LDQ,Z,LDZ,M,PL,PR,DIF,WORK,LWORK,IWORK,LIWORK,INFO) IF (INFO.NE.0) THEN WRITE (NOUT,99999) INFO WRITE (NOUT,*) END IF * * Print reordered generalized Schur form * IFAIL = 0 CALL X04DBF('General',' ',N,N,S,LDS,'Bracketed','F7.4', + 'Reordered Schur matrix S','Integer',RLABS, + 'Integer',CLABS,80,0,IFAIL) * WRITE (NOUT,*) IFAIL = 0 CALL X04DBF('General',' ',N,N,T,LDT,'Bracketed','F7.4', + 'Reordered Schur matrix T','Integer',RLABS, + 'Integer',CLABS,80,0,IFAIL) * * Print deflating subspaces * WRITE (NOUT,*) IFAIL = 0 CALL X04DBF('General',' ',N,M,Q,LDQ,'Bracketed','F7.4', + 'Basis of left deflating invariant subspace', + 'Integer',RLABS,'Integer',CLABS,80,0,IFAIL) WRITE (NOUT,*) IFAIL = 0 CALL X04DBF('General',' ',N,M,Z,LDZ,'Bracketed','F7.4', + 'Basis of right deflating invariant subspace', + 'Integer',RLABS,'Integer',CLABS,80,0,IFAIL) * * Print norm estimates and F-norm upper bounds * 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