From bokg@cs.umu.se Mon Apr 2 11:53:55 1990 Received: from zeus.cs.umu.se by cs.utk.edu with SMTP (5.61++/2.3-UTK) id AA08978; Mon, 2 Apr 90 11:08:25 -0400 Received: from ikaros.cs.umu.se by zeus.cs.umu.se (5.61+IDA/KTH/LTH/89-09-19) id AAzeus05652; Sun, 1 Apr 90 13:00:09 +0200 Received: by ikaros.cs.umu.se (5.61+IDA/KTH/LTH/89-09-19) id AAikaros01486; Sun, 1 Apr 90 12:59:59 +0200 Return-Path: Date: Sun, 1 Apr 90 12:59:59 +0200 From: bokg@cs.umu.se Message-Id: <9004011059.AAikaros01486@ikaros.cs.umu.se> To: dongarra@cs.utk.edu Subject: guptri_for_netlib Status: R #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh readme <<'END_OF_readme' XThis package of routines for computing the generalized Schur decomposition Xof an arbitrary (singular) pencil A-zB consists of the following files Xcontaining F77 subroutines and functions belonging to this package. XThey are: X zblas.f X zbnd.f subroutines bound and evalbd described in software paper X zcmatmlr.f X zguptri.f subroutine guptri described in software paper X zlinpack.f X zlistr.f X zmiscl.f X zqz.f X zrcsvdc.f X zreorder.f subroutine reordr described in software paper X zrzstr.f X XAll these files start with a statement describing the contents of Xthe actual file. X X XEnclosed with these files are also X zgschurm.f example program X kcfin.c1 input file for zgschurm.f for example C1 in software paper X zgschur.c1 output file for example C1 in paper X X XA standard usage of the package is as follows: X X call guptri (...) Compute generalized Schur decomposition of singular A-zB. X call reordr (...) Reorder the eigenvalues in specified order. X call bound (...) Compute error bounds for selected eigenvalues X call evalbd (...) and reducing subspaces. X XThe following papers describe software,algorithms and error bounds Xused in the package: X XJ. Demmel and B. Kagstrom, " The generalized Schur decomposition X of an arbitrary pencil A - zB: robust software with error bounds X and applications", Report UMINF-170.90,Institute of Information X Processing, Univ. of Umea, S-901 87 UMEA, SWEDEN,January 1990 X (submitted to ACM TOMS) X XJ. Demmel and B. Kagstrom, "Accurate Solutions of Ill-posed Problems X in Control Theory", SIAM J. Matrix Anal Appl, Vol 9, 1988, pp 126-145 X XJ. Demmel and B. Kagstrom, "Stable Eigendecompositions of Matrix Pencils", X Linear Algebra Applic., Vol 88/89, 1987, pp 137-186 X XJ. Demmel and B. Kagstrom, "Stably Computing the Kronecker Structure X and Reducing Subspaces of Singular pencils A-zB for Uncertain Data", X in J. Cullum and R. Willoughby (eds), Large Scale Eigenvalue Problems, X North Holland, 1986, pp 283-323 X XB. Kagstrom, "RGSVD - An Algorithm for Computing the Kronecker Structure X and Reducing Subspaces of Singular Matrix Pencils", SIAM J. Sci. Stat. X Comp., Vol 7, 1986, pp 185-211 X XAny comments or questions should be sent to: X X Bo Kagstrom X Institute of Information Processing X University of Umea X S-901 87 Umea, Sweden X email: na.kagstrom@na-net.stanford.edu X or bokg@cs.umu.se X X or X X James Demmel X Courant Institute X New York University X 215 Mercer Street X New York, NY 10012, USA X email: na.demmel@na-net.stanford.edu X XNotices: X1. The main program in file zgschurm.f with input from kcfin.c1 X produced the output on file zgschur.c1 when run on X Sun 3/80 workstation. The output in file zgschur.c1 also X includes some information that is not explained in the software paper. X We refer to the source for more information. X X2. The current version of the package has been developed during a period X of 4-5 years. The current version of the routines does not make use X of level 2 or 3 BLAS. X X3. Before a production code of this package is produced we would like X to obtain and collect as much information from users as possible. X THANK YOU IN ADVANCE! X X X X END_OF_readme if test 3177 -ne `wc -c kcfin.c1 <<'END_OF_kcfin.c1' X 4 5 X(1., 0.) (-2., 0.) (0.,0.) ( 0., 0.) ( 0., 0.) X(1., 0.) (0., 0.) (-1., 0.) (0., 0.) (0., 0.) X(0., 0.) (0., 0.) (0., 0.) (1., 0.) (0., 0.) X(0., 0.) (0., 0.) (0., 0.) (0., 0.) (2., 0.) X(0., 0.) (1., 0.) (0., 0.) (0., 0.) (0., 0.) X(0., 0.) (0., 0.) (1., 0.) (0., 0.) (0., 0.) X(0., 0.) (0., 0.) (0., 0.) (1., 0.) (0., 0.) X(0., 0.) (0., 0.) (0., 0.) (0., 0.) (1., 0.) X11000000000000000100 X10000110 X1.d-8 1000. X1.d-10 X 1 1 3 X1.d-10 1.d-9 1.d-8 1.d-7 1.d-6 X1.d-5 1.d-4 1.d-3 END_OF_kcfin.c1 if test 527 -ne `wc -c zblas.f <<'END_OF_zblas.f' Xc On this file - blas routines: double precision complex Xc zaxpy, zswap, dcabs1, dznrm2, zcopy, zdotc, zdotu, zscal, Xc zrotg, zdrot, drotg Xc X subroutine zaxpy(n,za,zx,incx,zy,incy) Xc Xc constant times a vector plus a vector. Xc jack dongarra, 3/11/78. Xc X double complex zx(1),zy(1),za X double precision dcabs1 X if(n.le.0)return X if (dcabs1(za) .eq. 0.0d0) return X if (incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X zy(iy) = zy(iy) + za*zx(ix) X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X zy(i) = zy(i) + za*zx(i) X 30 continue X return X end X X subroutine zswap (n,zx,incx,zy,incy) Xc Xc interchanges two vectors. Xc jack dongarra, 3/11/78. Xc X double complex zx(1),zy(1),ztemp Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = zx(ix) X zx(ix) = zy(iy) X zy(iy) = ztemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 X 20 do 30 i = 1,n X ztemp = zx(i) X zx(i) = zy(i) X zy(i) = ztemp X 30 continue X return X end X X double precision function dcabs1(z) X double complex z,zz X double precision t(2) X equivalence (zz,t(1)) X zz = z X dcabs1 = dabs(t(1)) + dabs(t(2)) X return X end X X X double precision function dznrm2( n, zx, incx) X logical imag, scale X integer next X double precision cutlo, cuthi, hitest, sum, xmax, absx, zero, one X double complex zx(1) X double precision dreal,dimag X double complex zdumr,zdumi X dreal(zdumr) = zdumr X dimag(zdumi) = (0.0d0,-1.0d0)*zdumi X data zero, one /0.0d0, 1.0d0/ Xc Xc unitary norm of the complex n-vector stored in zx() with storage Xc increment incx . Xc if n .le. 0 return with result = 0. Xc if n .ge. 1 then incx must be .ge. 1 Xc Xc c.l.lawson , 1978 jan 08 Xc Xc four phase method using two built-in constants that are Xc hopefully applicable to all machines. Xc cutlo = maximum of sqrt(u/eps) over all known machines. Xc cuthi = minimum of sqrt(v) over all known machines. Xc where Xc eps = smallest no. such that eps + 1. .gt. 1. Xc u = smallest positive no. (underflow limit) Xc v = largest no. (overflow limit) Xc Xc brief outline of algorithm.. Xc Xc phase 1 scans zero components. Xc move to phase 2 when a component is nonzero and .le. cutlo Xc move to phase 3 when a component is .gt. cutlo Xc move to phase 4 when a component is .ge. cuthi/m Xc where m = n for x() real and m = 2*n for complex. Xc Xc values for cutlo and cuthi.. Xc from the environmental parameters listed in the imsl converter Xc document the limiting values are as follows.. Xc cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are Xc univac and dec at 2**(-103) Xc thus cutlo = 2**(-51) = 4.44089e-16 Xc cuthi, s.p. v = 2**127 for univac, honeywell, and dec. Xc thus cuthi = 2**(63.5) = 1.30438e19 Xc cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. Xc thus cutlo = 2**(-33.5) = 8.23181d-11 Xc cuthi, d.p. same as s.p. cuthi = 1.30438d19 Xc data cutlo, cuthi / 8.232d-11, 1.304d19 / Xc data cutlo, cuthi / 4.441e-16, 1.304e19 / X data cutlo, cuthi / 8.232d-11, 1.304d19 / Xc X if(n .gt. 0) go to 10 X dznrm2 = zero X go to 300 Xc X 10 assign 30 to next X sum = zero X nn = n * incx Xc begin main loop X do 210 i=1,nn,incx X absx = dabs(dreal(zx(i))) X imag = .false. X go to next,(30, 50, 70, 90, 110) X 30 if( absx .gt. cutlo) go to 85 X assign 50 to next X scale = .false. Xc Xc phase 1. sum is zero Xc X 50 if( absx .eq. zero) go to 200 X if( absx .gt. cutlo) go to 85 Xc Xc prepare for phase 2. X assign 70 to next X go to 105 Xc Xc prepare for phase 4. Xc X 100 assign 110 to next X sum = (sum / absx) / absx X 105 scale = .true. X xmax = absx X go to 115 Xc Xc phase 2. sum is small. Xc scale to avoid destructive underflow. Xc X 70 if( absx .gt. cutlo ) go to 75 Xc Xc common code for phases 2 and 4. Xc in phase 4 sum is large. scale to avoid overflow. Xc X 110 if( absx .le. xmax ) go to 115 X sum = one + sum * (xmax / absx)**2 X xmax = absx X go to 200 Xc X 115 sum = sum + (absx/xmax)**2 X go to 200 Xc Xc Xc prepare for phase 3. Xc X 75 sum = (sum * xmax) * xmax Xc X 85 assign 90 to next X scale = .false. Xc Xc for real or d.p. set hitest = cuthi/n Xc for complex set hitest = cuthi/(2*n) Xc X hitest = cuthi/float( n ) Xc Xc phase 3. sum is mid-range. no scaling. Xc X 90 if(absx .ge. hitest) go to 100 X sum = sum + absx**2 X 200 continue Xc control selection of real and imaginary parts. Xc X if(imag) go to 210 X absx = dabs(dimag(zx(i))) X imag = .true. X go to next,( 50, 70, 90, 110 ) Xc X 210 continue Xc Xc end of main loop. Xc compute square root and adjust for scaling. Xc X dznrm2 = dsqrt(sum) X if(scale) dznrm2 = dznrm2 * xmax X 300 continue X return X end X X subroutine zcopy(n,zx,incx,zy,incy) Xc Xc copies a vector, x, to a vector, y. Xc jack dongarra, linpack, 4/11/78. Xc X double complex zx(1),zy(1) X integer i,incx,incy,ix,iy,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X zy(iy) = zx(ix) X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X zy(i) = zx(i) X 30 continue X return X end X X double complex function zdotc(n,zx,incx,zy,incy) Xc Xc forms the dot product of a vector. Xc jack dongarra, 3/11/78. Xc X double complex zx(1),zy(1),ztemp X ztemp = (0.0d0,0.0d0) X zdotc = (0.0d0,0.0d0) X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = ztemp + dconjg(zx(ix))*zy(iy) X ix = ix + incx X iy = iy + incy X 10 continue X zdotc = ztemp X return Xc Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X ztemp = ztemp + dconjg(zx(i))*zy(i) X 30 continue X zdotc = ztemp X return X end X X double complex function zdotu(n,zx,incx,zy,incy) Xc Xc forms the dot product of a vector. Xc jack dongarra, 3/11/78. Xc X double complex zx(1),zy(1),ztemp X ztemp = (0.0d0,0.0d0) X zdotu = (0.0d0,0.0d0) X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = ztemp + zx(ix)*zy(iy) X ix = ix + incx X iy = iy + incy X 10 continue X zdotu = ztemp X return Xc Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X ztemp = ztemp + zx(i)*zy(i) X 30 continue X zdotu = ztemp X return X end X X subroutine zscal(n,za,zx,incx) Xc Xc scales a vector by a constant. Xc jack dongarra, 3/11/78. Xc X double complex za,zx(1) X if(n.le.0)return X if(incx.eq.1)go to 20 Xc Xc code for increments not equal to 1 Xc X ix = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X do 10 i = 1,n X zx(ix) = za*zx(ix) X ix = ix + incx X 10 continue X return Xc Xc code for increments equal to 1 Xc X 20 do 30 i = 1,n X zx(i) = za*zx(i) X 30 continue X return X end X X subroutine zrotg(ca,cb,c,s) X double complex ca,cb,s X double precision c,dcabs1 X double precision norm,scale X double complex alpha X if (dcabs1(ca) .ne. 0.0d0) go to 10 X c = 0.0d0 X s = (1.0d0,0.0d0) X ca = cb X go to 20 X 10 continue X scale = dcabs1(ca) + dcabs1(cb) X norm = scale*dsqrt((dcabs1(ca/dcmplx(scale,0.0d0)))**2 + X * (dcabs1(cb/dcmplx(scale,0.0d0)))**2) X alpha = ca /dcabs1(ca) X c = dcabs1(ca) / norm X s = alpha * dconjg(cb) / norm X ca = alpha * norm X 20 continue X return X end X X subroutine zdrot (n,zx,incx,zy,incy,c,s) Xc Xc applies a plane rotation, where the cos and sin (c and s) are Xc double precision and the vectors zx and zy are double complex. Xc jack dongarra, linpack, 3/11/78. Xc X double complex zx(1),zy(1),ztemp X double precision c,s X integer i,incx,incy,ix,iy,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = c*zx(ix) + s*zy(iy) X zy(iy) = c*zy(iy) - s*zx(ix) X zx(ix) = ztemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X ztemp = c*zx(i) + s*zy(i) X zy(i) = c*zy(i) - s*zx(i) X zx(i) = ztemp X 30 continue X return X end X X subroutine drotg(da,db,c,s) Xc Xc construct givens plane rotation. Xc jack dongarra, linpack, 3/11/78. Xc X double precision da,db,c,s,roe,scale,r,z Xc X roe = db X if( dabs(da) .gt. dabs(db) ) roe = da X scale = dabs(da) + dabs(db) X if( scale .ne. 0.0d0 ) go to 10 X c = 1.0d0 X s = 0.0d0 X r = 0.0d0 X go to 20 X 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) X r = dsign(1.0d0,roe)*r X c = da/r X s = db/r X 20 z = 1.0d0 X if( dabs(da) .gt. dabs(db) ) z = s X if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c X da = r X db = z X return X end Xc Xc*** no more on this file X END_OF_zblas.f if test 11182 -ne `wc -c zbnd.f <<'END_OF_zbnd.f' Xc as of june 22, 1987 this file contains Xc bound, ebdreg, gvec, pbound, blddfl, blddfu, bldrhs, prml, Xc prmlct, svdiv, evalbd, bndwsp Xc X subroutine bound(a,b,ldab,m,n,irstrt,icstrt,dimreg, X + evala,evalb,edlmax,gvcond,pqnorm,ecase, X + sdlmax, difl, difu, qnorm, pnorm, scase, X + work, info) Xc Xc implicit none Xc Xc**** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc Xc**** formal parameter declarations X integer ldab,m,n,irstrt,icstrt,dimreg,info,ecase,scase X complex*16 a(ldab,*), b(ldab,*), evala(*),evalb(*) X complex*16 work(*) X real*8 gvcond(*), edlmax, sdlmax, qnorm, pnorm, pqnorm X real*8 difl, difu Xc Xc******************************************************************** Xc Xc compute error bounds for selected eigenvalues of general pencil Xc and error bounds for left and right reducing subspaces Xc Xc this version requires all selected eigenvalues be simple Xc input pencil a - lambda b must be in guptri form Xc Xc theorems and corollaries referred to below appear in: Xc 'accurate solutions of ill-posed problems in control theory' Xc proc. of the 25th ieee conference on decision and control, Xc athens, greece, december 10-12, 1986, pp 558-563 Xc by j. demmel and b. kagstrom Xc Xc see also: Xc j. demmel and b. kagstrom, 'computing stable eigendecompositions Xc of matrix pencils', linear algebra and its applications, Xc vol 88/89, 1987, pp 139-185 Xc Xc inputs Xc Xc a(ldab,n), b(ldab,n) - complex*16 - input pencil in Xc guptri form Xc Xc lda - integer - leading dimension of a and b Xc Xc m,n - integer - row, column dimensions of a and b Xc Xc irstrt, icstrt - integer - starting row and column of selected Xc part of pencil for which eigenvalue bounds Xc are desired. reducing subspace bounds will be Xc supplied for right reducing subspace spanned Xc by leading icstrt-1 components and for left Xc reducing subspace spanned by leading icstrt-1 Xc components. Xc note: set icstrt=n+1 to make right reducing Xc subspace whole space Xc set irstrt=m+1 to make left reducing Xc subspace whole space Xc Xc dimreg - integer - number of selected eigenvalues; Xc if dimreg.eq.0 only subspace perturbation bounds will be Xc computed Xc (note - one can select a subset of the regular part only; Xc this gives generally different bounds for common eigenvalues Xc from a different selected subset; see paper above for Xc discussion) Xc Xc outputs Xc Xc evala(dimreg), evalb(dimreg) - complex*16 - Xc normalized selected eigenvalues; Xc evala(i)/evalb(i) is i-th eigenvalue and Xc abs(evala(i))**2 + abs(evalb(i))**2 = 1 Xc Xc edlmax - real*8 - maximum frobenius norm of perturbation for Xc which eigenvalue perturbation bounds hold. Xc if no maximum norm then edlmax=-1. Xc Xc gvcond(dimreg) - real*8 - condition numbers; suppose the pencil Xc is perturbed by amount delta .le. edlmax (if edlmax=-1. then Xc delta arbitrary) such that the conditions of theorem 5 or Xc corollary 1 hold (edlmax=-1. implies these conditions always Xc hold). then if c/s is a perturbed eigenvalue such that Xc abs(c)**2 + abs(s)**2 = 1, then for some i Xc abs(c*evalb(i)-s*evala(i)) .le. delta * gvcond(i) Xc Xc pqnorm - real*8 - overall condition number; under same Xc conditions as for gvcond, if areg - lambda breg is regular Xc part of unperturbed pencil in guptri form, then Xc sigma-min(c*breg - s*areg) .le. delta * pqnorm Xc (sigma-min is the smallest singular value) Xc Xc ecase - integer - which of 5 cases for eigenvalue bounds Xc the pencil falls depending on input dimensions; Xc the first four cases are for dimreg.gt.0, in which Xc case the description gives: Xc (part of KCF to above, left of selected part) and Xc (part of KCF to below, right of selected part) Xc ecase=1 - (right singular and/or regular part) and Xc (left singular and/or regular part) Xc ecase=2 - (right singular and/or regular part) and (nothing) Xc ecase=3 - (nothing) and (left singular and/or regular part) Xc ecase=4 - (nothing) and (nothing) Xc ecase=5 - dimreg.eq.0 (no eigenvalue bounds) Xc Xc sdlmax - real*8 - maximum frobenius norm of perturbation for Xc which reducing subspace perturbation bounds hold Xc (if scase=4 (see below) sdlmax=-1. to indicate that Xc this bound does not apply) Xc Xc difl, difu - real*8 - difl and difu functions (used to Xc compute sdlmax, see paper for details) Xc (if scase=4 (see below), both set to 0) Xc Xc qnorm, pnorm, - real*8 - norms of left and right projectors Xc (used in reducing subspace bounds) Xc (if scase=4 (see below), both set to 1) Xc Xc scase - integer - which of 4 cases for reducing subspace Xc bounds the pencil falls depending on input dimensions: Xc scase=1 - both left and right subspaces nontrivial Xc scase=2 - left space trivial (0) and right space nontrivial Xc scase=3 - left space nontrivial and right space trivial Xc (whole space) Xc scase=4 - both spaces trivial (either 0 or whole space) Xc Xc the reducing subspace bounds may be calculated from Xc scase, sdlmax, pnorm and qnorm as follows: Xc let delta be the distance in the frobenius norm from a Xc perturbed pencil with the same structure as a - lambda b Xc to a - lambda b (see the above paper by demmel and Xc kagstrom for more details). if delta.lt.sdlmax then the Xc following bounds apply, where relerr=delta/sdlmax : Xc Xc upper bound on angular perturbation in left reducing subspace Xc if scase=1 (theorem 4, case 1 in paper) Xc atan(relerr/(pnorm-relerr*sqrt(pnorm**2-1))) Xc if scase=2 Xc 0 (since left subspace trivial) Xc if scase=3 Xc atan(relerr/(1-relerr)) Xc if scase=4 Xc 0 (since left subspace trivial) Xc Xc upper bound on angular perturbation in right reducing subspace Xc if scase=1 (theorem 4, case 1 in paper) Xc atan(relerr/(qnorm-relerr*sqrt(qnorm**2-1))) Xc if scase=2 Xc atan(relerr/(1-relerr)) Xc if scase=3 Xc 0 (since right subspace trivial) Xc if scase=4 Xc 0 (since right subspace trivial) Xc Xc lower bound on angular perturbation in left reducing subspace Xc if scase=1 (theorem 4, case 2 in paper) Xc atan(1/(sqrt(2*min(irstrt-1,m-irstrt+1))*pnorm + Xc sqrt(pnorm**2-1))) Xc if scase=2 this bound does not apply Xc if scase=3 this bound does not apply Xc if scase=4 this bound does not apply Xc Xc lower bound on angular perturbation in right reducing subspace Xc if scase=1 (theorem 4, case 2 in paper) Xc atan(1/(sqrt(2*min(icstrt-1,n-icstrt+1))*qnorm + Xc sqrt(qnorm**2-1))) Xc if scase=2 this bound does not apply Xc if scase=3 this bound does not apply Xc if scase=4 this bound does not apply Xc Xc (note: given scase, sdlmax, pnorm, qnorm, m, n, icstrt, irstrt Xc and delta (the frobenius norm of a perturbation), subroutine Xc evalbd will compute the above upper and lower subspace bounds) Xc Xc info - integer - 0 if normal return Xc 1 if svd error in difu calculation in pbound Xc 2 if difu=0 in pbound Xc 3 if svd error in difl calculation in pbound Xc 4 if difl=0 in pbound Xc 5 if multiple eigenvalues Xc 6 if inconsistent input dimensions Xc Xc workspace Xc work(*) - complex*16 - exact amount is complicated function of Xc input dimensions and depends on ecase, and computed Xc as follows: Xc Xc irend=irstrt+dimreg-1; icend=icstrt+dimreg-1; Xc if ecase=1 - m11=irstrt-1; m21=m-m11; n11=icstrt-1; n21=n-n11; Xc m12=irend-irstrt+1; m22=m-irend; Xc n12=icend-icstrt+1; n22=n-icend; Xc workspace = max( (2*n21*m11*(n11*n21+m11*m21+ Xc 2*n21*m11+2)+n11*n21+m11*m21) , Xc (2*((m21*n11+1)*(n11*n21+ Xc m11*m21+1)-1)) , Xc (2*n22*m12*(n12*n22+m12*m22+ Xc 2*n22*m12+2)+n12*n22+m12*m22) , Xc (2*((m22*n12+1)*(n12*n22+ Xc m12*m22+1)-1)) ) Xc if ecase=2 or ecase=5 - Xc m11=irstrt-1; m21=m-m11; n11=icstrt-1; n21=n-n11; Xc workspace = max( (2*n21*m11*(n11*n21+m11*m21+ Xc 2*n21*m11+2)+n11*n21+m11*m21) , Xc (2*((m21*n11+1)*(n11*n21+ Xc m11*m21+1)-1)) ) Xc if ecase=3 - m11=irend; m21=m-m11; n11=icend; n21=n-icend; Xc workspace = max( (2*n21*m11*(n11*n21+m11*m21+ Xc 2*n21*m11+2)+n11*n21+m11*m21) , Xc (2*((m21*n11+1)*(n11*n21+ Xc m11*m21+1)-1)) ) Xc if ecase=4 - workspace = n*n Xc Xc the following simple expression bounds the workspace also, but Xc may occasionally be much too large (especially if ecase=4): Xc workspace .le. 2*m*n* (n*n + m*m + 2*n + m + 2) + n*n + m*m Xc********************************************************************* Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc addresses: Xc jim demmel, courant institute, 251 mercer str, Xc new york, new york 10012, usa Xc electronic address: demmel at nyu.edu or Xc na.demmel at score.stanford.edu Xc bo kagstrom, institute of information processing, Xc university of umea, s-90187 umea, sweden Xc electronic address: bokg at seumdc51.bitnet or Xc na.kagstrom at score.stanford.edu Xc Xc**** bound uses the following functions and subroutines Xc pbound, ebdreg, cmatpr (debug only), gvec, dznrm2 (blas), Xc blddfu, blddfl, bldrhs, prml, prmlct, svdiv, zsvdc (linpack) Xc Xc**** internal variables X integer irend,icend,idummy,i X real*8 rdummy, difu1, difu2, difl1, difl2, pnorm1, pnorm2 X real*8 qnorm1, qnorm2, pdelta1, pdelta2, delta Xc Xc test input dimensions for consistency X info = 0 X if (irstrt.gt.icstrt .or. irstrt.le.0 .or. X + n-icstrt-dimreg.gt.m-irstrt-dimreg .or. X + n-icstrt-dimreg+1.lt.0 .or. dimreg.lt.0) then Xc inconsistent input dimensions X info = 6 X return X endif X icend = icstrt+dimreg-1 X irend = irstrt+dimreg-1 X delta = 0. Xc X if (dimreg.gt.0) then Xc there are eigenvalue bounds to compute Xc Xc ecase 1 - in addition to selected regular part KCF has Xc (right singular part and/or regular part) and Xc (left singular part and/or regular part) X if (icstrt.ne.1 .and. irend.ne.m) then X ecase = 1 X if (irstrt.eq.1) then X scase = 2 X else X scase = 1 X endif Xc see corollary 1 for explanation of bounds X call pbound(a,b,ldab,m,n,irstrt-1,icstrt-1, X + delta,difl1,difu1,qnorm1,pnorm1, pdelta1, X + rdummy,rdummy,rdummy,rdummy,idummy,work,info) X if (info.ne.0) return X call pbound(a(irstrt,icstrt),b(irstrt,icstrt),ldab, X + m-irstrt+1,n-icstrt+1,irend-irstrt+1, X + icend-icstrt+1, X + delta,difl2,difu2,qnorm2,pnorm2,pdelta2, X + rdummy,rdummy,rdummy,rdummy,idummy,work,info) X if (info.ne.0) return X edlmax = min (pdelta1, pdelta2/(sqrt(2.)*qnorm1)) X pqnorm = 2.*pnorm2*qnorm1 Xc X sdlmax = pdelta1 X pnorm = pnorm1 X qnorm = qnorm1 X difl = difl1 X difu = difu1 X endif Xc Xc ecase 2 - in addition to selected regular part KCF has Xc (right singular part and/or regular part) and Xc (nothing) X if (icstrt.ne.1 .and. irend.eq.m) then X ecase=2 X if (irstrt.eq.1) then X scase = 2 X else X scase = 1 X endif Xc see part 1 of theorem 5 for explanation of bounds X call pbound(a,b,ldab,m,n,irstrt-1,icstrt-1,delta,difl1, X + difu1,qnorm1,pnorm1,pdelta1,rdummy,rdummy, X + rdummy,rdummy,idummy,work,info) X if (info.ne.0) return X edlmax= pdelta1 X pqnorm=1. X if (idummy.eq.1) pqnorm=sqrt(2.)*qnorm1 Xc X sdlmax = pdelta1 X pnorm = pnorm1 X qnorm = qnorm1 X difl = difl1 X difu = difu1 X endif Xc Xc ecase 3 - in addition to selected regular part KCF has Xc (nothing) and Xc (left singular part and/or regular part) X if (icstrt.eq.1 .and. irend.ne.m) then X ecase = 3 X scase = 4 Xc see part 2 of theorem 5 for explanation of bounds X call pbound(a,b,ldab,m,n,irend,icend, X + delta,difl2,difu2,qnorm2,pnorm2,pdelta2, X + rdummy,rdummy,rdummy,rdummy,idummy,work,info) X if (info.ne.0) return X edlmax = pdelta2 X pqnorm = 1. X if (idummy.eq.1) pqnorm = sqrt(2.)*pnorm2 X difl = 0. X difu = 0. X pnorm = 1. X qnorm = 1. X sdlmax = -1. X endif Xc Xc ecase 4 - pencil regular and entire spectrum selected X if (icstrt.eq.1 .and. irend.eq.m) then X ecase=4 X edlmax=-1. X pqnorm=1. Xc X scase = 4 X difl = 0. X difu = 0. X pnorm = 1. X qnorm = 1. X sdlmax = -1. X endif Xc X call ebdreg(a,b,ldab,irstrt,icstrt,dimreg, X + gvcond,evala,evalb,work,info) X if (info.ne.0) then X info = 5 X return X endif X if (pqnorm.ne.1.) then X do 1 i=1,dimreg X gvcond(i)=gvcond(i)*pqnorm X1 continue X endif Xc X else Xc dimreg.eq.0, so only compute subspace bounds X ecase = 5 X call pbound(a,b,ldab,m,n,irstrt-1,icstrt-1, X + delta,difl,difu,qnorm,pnorm,sdlmax, X + rdummy,rdummy,rdummy,rdummy,scase,work,info) X endif Xc X if (idbg(20).ne.0) then X write(outunit,100) ldab,m,n,irstrt,icstrt,dimreg,ecase,scase X100 format(' bound - ldab,m,n,irstrt,icstrt,dimreg,ecase,scase=', X + /,8i5) X if (ecase.ne.5) then X write(outunit,101) edlmax,pqnorm X101 format(' edlmax,pqnorm=',2d15.6,/,' gvcond=') X write(outunit,102) (gvcond(i),i=1,dimreg) X102 format(5d15.6) X call cmatpr(work,dimreg,dimreg,dimreg,'gvec') X endif X if (scase.ne.4) write(outunit,103) sdlmax,pnorm,qnorm X103 format(' sdlmax,pnorm,qnorm=',3d15.6) X endif X return X end Xc Xc X subroutine ebdreg(a,b,ldab,irstrt,icstrt,dimreg, X + gvcond,evala,evalb,work,info) Xc implicit none Xc**** formal parameter declarations X integer ldab, dimreg, irstrt, icstrt, info X complex*16 a(ldab,*), b(ldab,*), work(*), evala(*), evalb(*) X real*8 gvcond(*) Xc Xc***************************************************************** Xc Xc compute error bounds for eigenvalues of a regular pencil Xc requires all simple eigenvalues Xc Xc inputs: Xc a(ldab,*), b(ldab,*) - complex*16 - contain pencil Xc irstrt, icstrt - integer - starting row and column locations Xc of pencil within a and b Xc dimreg - integer - dimension of regular pencil Xc Xc outputs: Xc evala(dimreg), evalb(dimreg) - complex*16 - normalized Xc eigenvalues: Xc evala(i)/evalb(i) is i-th eigenvalue and Xc abs(evala(i))**2 + abs(evalb(i))**2 =1 Xc gvcond(dimreg) - real*8 - gvcond(i) is condition number of Xc i-th eigenvalue where if the pencil is perturbed by Xc frobenius norm delta and the perturbed eigenvalue Xc is c/s where Xc abs(c)**2 + abs(s)**2 = 1 then for some i Xc abs(c*evalb(i) - s*evala(i)) .le. delta * gvcond(i) Xc info - integer - returns 0 (normal) if no multiple eigenvalues, Xc else nonzero Xc Xc workspace: Xc work(dimreg**2) - complex*16 - work space Xc Xc*********************************************************************** Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** ebdreg uses the following functions and subroutines: Xc gvec Xc Xc**** internal variables Xc X real*8 scl X integer i Xc Xc compute eigenvectors X call gvec(a( irstrt , icstrt ), X + b( irstrt , icstrt ), ldab, X + dimreg , work, dimreg, gvcond, info) Xc Xc compute normalized eigenpairs X do 555 i=1,dimreg X scl=sqrt(abs(a(irstrt-1+i,icstrt-1+i))**2+ X + abs(b(irstrt-1+i,icstrt-1+i))**2) X evala(i) = a(irstrt-1+i,icstrt-1+i)/scl X evalb(i) = b(irstrt-1+i,icstrt-1+i)/scl X if (info.eq.0) gvcond(i)= dimreg * gvcond(i) / scl X555 continue Xc X return X end Xc Xc X subroutine gvec(a,b,ldab,n,vec,ldvec,gvcond,info) Xc Xc implicit none Xc**** debug space X common /debug2/ idbg(20),outunit X integer idbg,outunit X logical ldebug Xc**** formal parameter declarations X integer ldab, n, ldvec, info X complex*16 a(ldab,*), b(ldab,n), vec(ldvec,*) X real*8 gvcond(*) Xc Xc******************************************************************** Xc Xc compute the left and right eigenvectors of the upper triangular Xc regular pencil a - lambda b Xc compute condition numbers of eigenvalues Xc Xc inputs Xc a(ldab,n),b(ldab,n) - complex*16 - n by n matrices Xc ldab - integer - leading dimension of a, b Xc n - integer - dimension of a, b Xc ldvec - integer - leading dimension of vec Xc Xc idbg(10) - if idbg(10) ne 0, print debug output Xc Xc outputs Xc vec(ldvec,n) - complex*16 - matrix containing eigenvectors Xc vec(1:i,i) contains the right eigenvector of the i-th Xc eigenvalue, normalized so vec(i,i)=1. the other Xc components of the eigenvector are zero Xc vec(i:n,i) contains the left eigenvector of the i-th Xc eigenvalue, normalized so vec(i,i)=1. the other Xc components of the eigenvector are zero Xc gvcond(n) - real*8 - array of condition numbers of eigenvalues. Xc if right eigenvectors scaled by diagonal matrix d Xc to have unit norm, scale left eigenvectors by d**-1. Xc then condition number is norm of left eigenvector. Xc info - integer - 0 if pencil regular without multiple eigenvalues Xc nonzero index of a multiple or 0/0 eigenvalue otherwise X Xc*********************************************************************** Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** gvec uses the following external function: Xc dznrm2 (blas) X real*8 dznrm2 Xc**** internal variables X integer nm1, i, im1, im2, j, jp1, k, ip1, ip2, jm1 X complex*16 alpha, beta, diag, cmul, csum X real*8 ca, cb, dmax, dmin, d Xc X ldebug=(idbg(10).ne.0) X info=0 X nm1=n-1 X if (ldebug) write(outunit,99) X99 format(' entering gvec') X do 1 i=1,n Xc X if (ldebug) write(outunit,100) i X100 format(' i=',i4) X vec(i,i)=1. Xc Xc compute alpha, beta so that zz = beta*a - alpha*b is a Xc singular matrix whose left and right null spaces are the Xc left and right eigenspaces we seek X ca=abs(a(i,i)) X cb=abs(b(i,i)) X dmax=max(ca,cb) X if (ldebug) write(outunit,101) a(i,i),b(i,i),ca,cb,dmax X101 format(' a(i,i)=',2d20.5,/,' b(i,i)=',2d20.5,/,' ca=',d20.5,/, X + ' cb=',d20.5,/,' dmax=',d20.5) X if (dmax.eq.0.0) then Xc singular pencil X info=i X return X endif X dmin=min(ca,cb) X d=dmax*sqrt(1+(dmin/dmax)**2) X alpha = a(i,i)/d X beta = b(i,i)/d X if (ldebug) write(outunit,102) dmin,d,alpha,beta X102 format(' dmin=',d20.5,/,' d=',d20.5,/,' alpha=',2d20.5,/, X + ' beta=',2d20.5) Xc Xc compute right eigenvector X if (i.ne.1) then Xc Xc solve zz(1:i-1,1:i-1) * x = -zz(1:i-1,i) for Xc x = vec(1:i-1,i) X diag=beta*a(i-1,i-1) - alpha*b(i-1,i-1) X im1=i-1 X if (ldebug) write(outunit,103) im1,i,diag X103 format(' i,j,diag=',2i4,2d20.5) X if (abs(diag).eq.0.0) then Xc multiple eigenvalue X info=i-1 X return X endif X vec(i-1,i)=-(beta*a(i-1,i)-alpha*b(i-1,i))/diag X if (i.ne.2) then X im1=i-1 X im2=i-2 X do 2 j=im2,1,-1 X diag=beta*a(j,j)-alpha*b(j,j) X if (ldebug) write(outunit,103) j,i,diag X if (abs(diag).eq.0.0) then Xc multiple eigenvalue X info=j X return X endif X csum=-(beta*a(j,i)-alpha*b(j,i)) X jp1=j+1 X do 3 k=jp1,im1 X cmul=beta*a(j,k)-alpha*b(j,k) X csum=csum-cmul*vec(k,i) X3 continue X vec(j,i)=csum/diag X2 continue X endif X endif Xc Xc compute left eigenvector X if (i.ne.n) then Xc solve xt * zz(i+1:n,i+1:n) = -zz(i,i+1:n) for Xc x = vec(i+1:n,i) X diag=beta*a(i+1,i+1)-alpha*b(i+1,i+1) X ip1=i+1 X if (ldebug) write(outunit,103) i,ip1,diag X if (abs(diag).eq.0.0) then Xc multiple eigenvalue X info=i X return X endif X vec(i+1,i)=-(beta*a(i,i+1)-alpha*b(i,i+1))/diag X if (i.ne.nm1) then X ip1=i+1 X ip2=i+2 X do 4 j=ip2,n X diag=beta*a(j,j)-alpha*b(j,j) X if (ldebug) write(outunit,103) i,j,diag X if (abs(diag).eq.0.0) then Xc multiple eigenvalue X info=i X return X endif X csum=-(beta*a(i,j)-alpha*b(i,j)) X jm1=j-1 X do 5 k=ip1,jm1 X cmul=beta*a(k,j)-alpha*b(k,j) X csum=csum-cmul*vec(k,i) X5 continue X vec(j,i)=csum/diag X4 continue X endif X endif X1 continue Xc Xc compute condition numbers X do 6 i=1,n X gvcond(i)=dznrm2(i,vec(1,i),1)*dznrm2(n-i+1,vec(i,i),1) X6 continue X return X end Xc X subroutine pbound(a,b,ldab,m,n,rowred,colred,delta,difl,difu, X + qnorm,pnorm,pdelta,lbndup,rbndup,lbndlw,rbndlw,scase,work, X + ierr) Xc Xc implicit none Xc Xc**** formal parameter declarations X integer ldab,m,n,rowred,colred,ierr,scase X complex*16 a(ldab,*),b(ldab,*),work(*) X real*8 delta,difl,difu,qnorm,pnorm,pdelta,lbndup,rbndup X real*8 lbndlw, rbndlw Xc Xc******************************************************************* Xc Xc compute perturbation bounds for reducing subspaces of Xc singular pencil a - lambda b Xc assume a - lambda b has been reduced to generalized upper Xc triangular form by guptri Xc need rowred .le. colred and n-colred .le. m-rowred Xc as implied by generalized upper triangular form Xc Xc there are 4 cases, depending on dimension: Xc Xc case 1: 0 .lt. rowred and 0 .lt. n-colred so that Xc both left and right reducing subspaces nontrivial Xc Xc case 2: if rowred=0 and 0 .lt. colred .lt. n then left reducing Xc subspace 0 but right one nontrivial and bounds exist for it Xc Xc case 3: if colred=n and 0 .lt. rowred .lt. m then right reducing Xc subspace is entire space but left one nontrivial with bounds Xc Xc case 4: if ( (rowred=0 and colred=0) or Xc (rowred=0 and colred=n) or Xc (rowred=m and colred=n) ) then Xc both left and right subspaces trivial Xc Xc inputs: Xc Xc a(ldab,n),b(ldab,n) - complex*16 - m by n matrices Xc Xc ldab - integer - leading dimension of a and b Xc Xc m,n - integer - dimensions of a and b Xc Xc rowred,colred - integer - number of rows and columns in Xc (1,1) position of a,b. dimensions of desired left Xc and right reducing subspaces Xc Xc delta - real*8 - distance of perturbed pencil from a - lambda b Xc Xc idbg(9) - integer - if idbg(9) ne 0, print debug output Xc Xc outputs: (described in more detail in Xc 'accurate solutions of ill-posed problems in control theory' Xc 25th conference on decision and control, Xc j. demmel and b. kagstrom Xc Xc difl - real*8 - difl function (in case 4, difl=0) Xc Xc difu - real*8 - difu function (in case 4, difu=0) Xc Xc qnorm - real*8 - right projector norm ( sqrt(r0**2+1) ) Xc (in case 4, qnorm=1.) Xc Xc pnorm - real*8 - left projector norm ( sqrt(l0**2+1) ) Xc (in case 4, prnorm=1.) Xc Xc pdelta - real*8 - radius of ball around a - lambda b within Xc which perturbation bounds hold (in case 4, pdelta=-1. Xc to show pdelta does not apply). if delta.ge.pdelta, Xc the following bounds are set to -1. the following Xc outputs are given in terms of relerr = delta/pdelta Xc Xc lbndup - real*8 - upper bound on angular perturbation in left Xc reducing subspace (case 1 of theorem 4 of above paper) Xc in case 1: Xc lbndup=atan(relerr/(pnorm-relerr*sqrt(pnorm**2-1))) Xc in case 2: Xc lbndup=0 Xc in case 3: Xc lbndup=atan(relerr/(1-relerr)) Xc in case 4: Xc lbndup=0 Xc Xc rbndup - real*8 - upper bound on angular perturbation in right Xc reducing subspace (case 1 of theorem 4) Xc in case 1: Xc rbndup=atan(relerr/(qnorm-relerr*sqrt(qnorm**2-1))) Xc in case 2: Xc rbndup=atan(relerr/(1-relerr)) Xc in case 3: Xc rbndup=0 Xc in case 4: Xc rbndup=0 Xc Xc lbndlw - real*8 - lower bound on angular perturbation in left Xc reducing subspace (case 2 of theorem 4) Xc in case 1: Xc lbndlw=atan(1/(sqrt(2*min(rowred,m-rowred))*pnorm + Xc sqrt(pnorm**2-1))) Xc in case 2: lbndlw=-1 since this bound does not apply Xc in case 3: lbndlw=-1 since this bound does not apply Xc in case 4: lbndlw=-1 since this bound does not apply Xc Xc rbndlw - real*8 - lower bound on angular perturbation in right Xc reducing subspace (case 2 of theorem 4) Xc in case 1: Xc rbndlw=atan(1/(sqrt(2*min(colred,n-colred))*qnorm + Xc sqrt(qnorm**2-1))) Xc in case 2: rbndlw=-1 since this bound does not apply Xc in case 3: rbndlw=-1 since this bound does not apply Xc in case 4: rbndlw=-1 since this bound does not apply Xc Xc scase - integer - 1, 2, 3 or 4 as described above Xc Xc ierr - integer - error flag Xc 0 means no error (normal return) Xc 1 means error in svd of difu Xc 2 means difu = 0 Xc 3 means error in svd of difl Xc 4 means difl = 0 Xc 5 means bad rowred or colred Xc Xc work space Xc work - complex*16 - array of length at least Xc max ( rowdfu*coldfu+coldfu**2+2*coldfu+rowdfu , Xc rowdfl*coldfl+2*coldfl+rowdfl ) Xc where Xc rowdfu=coldfl=colred*(n-colred)+rowred*(m-rowred) Xc coldfu=2*(n-colred)*rowred Xc rowdfl=2*(m-rowred)*colred Xc Xc********************************************************************* Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel, courant institute, 251 mercer str, new york, Xc new york, 10012 Xc electronic address: demmel at nyu.edu Xc bo kagstrom, institute of information processing, Xc university of umea, s-90187 umea, sweden Xc electronic address: bokg at seumdc51.bitnet Xc Xc**** pbound uses the following subroutines and functions Xc dznrm2, blddfu, blddfl, bldrhs, prml, prmlct, svdiv, zsvdc Xc Xc**** internal variables Xc X complex*16 dummy X integer rowdfu,coldfu,sstrt,wstrt,estrt,rowdfl,coldfl,vstrt X integer isub, i, j, info, len X real*8 r0, l0, relerr, dznrm2 Xc X ierr=0 X if ((rowred.gt.colred).or.((n-colred).gt.(m-rowred))) then Xc inconsistent dimensions X ierr = 5 X elseif ((0.lt.rowred) .and. (0.lt.n-colred)) then Xc case 1 X scase = 1 Xc compute difu Xc build transposed difu matrix starting at work(1) Xc rowdfu = number of rows in difut X rowdfu=colred*(n-colred)+rowred*(m-rowred) Xc coldfu = number of columns in difut X coldfu=2*(n-colred)*rowred Xc X call blddfu(work,rowdfu,a,b,ldab,m,n,rowred,colred) Xc Xc setup workspace for svd Xc store left singular vectors u over difu starting at work(1) X sstrt=1+rowdfu*coldfu Xc store singular values starting at work(sstrt) X wstrt=sstrt+coldfu Xc store work array needed for svd starting at work(wstrt) X estrt=wstrt+rowdfu Xc store e array needed for svd starting at work(estrt) X vstrt=estrt+coldfu Xc store right singular vectors v starting at work(vstrt) Xc Xc compute svd X call zsvdc(work(1),rowdfu,rowdfu,coldfu,work(sstrt), X + work(estrt),work(1),rowdfu,work(vstrt),coldfu,work(wstrt), X + 21,info) Xc X if (info.eq.0) goto 10 X ierr=1 X return X10 continue Xc Xc extract difu X difu=dreal(work(sstrt-1+coldfu)) Xc X if (difu.gt.0.) goto 20 X ierr=2 X return X20 continue Xc Xc compute pnorm, qnorm Xc build rhs = (-col a12, -col b12) starting at work(wstrt) X call bldrhs(work(wstrt),a,b,ldab,m,n,rowred,colred) Xc Xc solve underdetermined least squares problem Xc premultiply rhs by v* storing result at work(estrt) X call prmlct(work(vstrt),coldfu,coldfu,coldfu, X + work(wstrt),work(estrt)) Xc Xc premultiply by inverted singular values X call svdiv(work(estrt),coldfu,work(sstrt)) Xc Xc premultiply by u storing result at work(wstrt) X call prml(work,rowdfu,rowdfu,coldfu,work(estrt),work(wstrt)) Xc X len=colred*(n-colred) Xc compute r0 = norm of leading len components X r0=dznrm2(len,work(wstrt),1) Xc Xc compute l0 = norm of remaining components X len=rowred*(m-rowred) X l0=dznrm2(len,work(wstrt+len),1) Xc compute pnorm, qnorm from l0, r0 X pnorm=sqrt(1+l0**2) X qnorm=sqrt(1+r0**2) Xc Xc compute difl Xc build difl matrix starting at work(1) Xc rowdfl = number of rows in difl X rowdfl=2*colred*(m-rowred) Xc coldfl=number of columns in difl X coldfl=rowred*(m-rowred)+colred*(n-colred) X call blddfl(work,rowdfl,a,b,ldab,m,n,rowred,colred) Xc Xc setup workspace for svd Xc do not compute any singular vectors X sstrt=1+rowdfl*coldfl Xc store singular values starting at work(sstrt) X wstrt=sstrt+coldfl Xc store work array needed by svd starting at work(wstrt) X estrt=wstrt+rowdfl Xc store e array needed by svd starting at work(estrt) Xc X call zsvdc(work(1),rowdfl,rowdfl,coldfl,work(sstrt), X + work(estrt),dummy,1,dummy,1,work(wstrt),0,info) Xc X if (info.eq.0) goto 30 X ierr=3 X return X30 continue Xc Xc extract difl X difl=dreal(work(sstrt-1+coldfl)) X if (difl.gt.0.) goto 40 X ierr=4 X return X40 continue Xc compute perturbation bounds X pdelta=min(difl,difu)/(sqrt(pnorm**2+qnorm**2)+ X + 2.*max(pnorm,qnorm)) X relerr=delta/pdelta X lbndup=-1. X rbndup=-1. X lbndlw=-1. X rbndlw=-1. X if (relerr.ge.1.) goto 50 X lbndup=atan(relerr/(pnorm-relerr*sqrt(pnorm**2-1.))) X rbndup=atan(relerr/(qnorm-relerr*sqrt(qnorm**2-1.))) X lbndlw=atan(1./(sqrt(2.*min(rowred,m-rowred))*pnorm+ X + sqrt(pnorm**2-1.))) X rbndlw=atan(1./(sqrt(2.*min(colred,n-colred))*qnorm+ X + sqrt(qnorm**2-1.))) X50 continue X elseif (rowred.eq.0.and.colred.gt.0.and.colred.lt.n) then Xc case 2 X scase = 2 Xc compute difl Xc build difl matrix ( (a**t b**t)**t ) starting at work(1) X isub = 0 X do 100 j=colred+1, n X do 101 i=1, m X isub = isub +1 X work(isub) = a(i,j) X101 continue X do 102 i=1,m X isub = isub +1 X work(isub) = b(i,j) X102 continue X100 continue Xc compute singular values X sstrt=1+isub X estrt=sstrt + n-colred X wstrt=estrt + n-colred X call zsvdc(work,2*m,2*m,n-colred,work(sstrt),work(estrt), X + dummy,1,dummy,1,work(wstrt),0,info) X if (info.ne.0) then X ierr=3 X return X endif Xc extract difl X difl = abs(work(sstrt+n-colred-1)) X difu=difl X if (difl.eq.0.) then X ierr=4 X return X endif X pdelta=difl X relerr=delta/pdelta X pnorm = 1. X qnorm = 1. X lbndlw = -1. X rbndlw = -1. X lbndup = -1. X rbndup = -1. X if (relerr.lt.1.) then X lbndup = 0. X rbndup = atan(relerr/(1.-relerr)) X endif X elseif (colred.eq.n.and.rowred.gt.0.and.rowred.lt.m) then Xc case 3 X scase = 3 Xc compute difu Xc build difu matrix (a,b) starting at work(1) X isub = 0 X do 104 j=1,n X do 105 i=1,rowred X isub = isub +1 X work(isub) = a(i,j) X105 continue X104 continue X do 106 j=1,n X do 107 i=1,rowred X isub = isub +1 X work(isub) = b(i,j) X107 continue X106 continue Xc compute singular values X sstrt=isub+1 X estrt=sstrt+rowred+1 X wstrt=estrt+2*n X call zsvdc(work,rowred,rowred,2*n,work(sstrt),work(estrt), X + dummy,1,dummy,1,work(wstrt),0,info) X if (info.ne.0) then X ierr = 1 X return X endif Xc extract difu X difu=abs(work(sstrt+rowred-1)) X difl = difu X if (difu.eq.0.0) then X ierr = 2 X return X endif X pdelta = difu X relerr = delta/pdelta X pnorm = 1. X qnorm = 1. X lbndup = -1. X rbndup = -1. X lbndlw = -1. X rbndlw = -1. X if ( relerr.lt.1.0) then X rbndup = 0. X lbndup = atan(relerr/(1.-relerr)) X endif X else Xc both left and right subspace trivial X scase = 4 X lbndup = 0. X rbndup = 0. X lbndlw = -1. X rbndlw = -1. X difl = 0. X difu = 0. X pdelta = -1. X pnorm = 1. X qnorm = 1. X endif X return X end Xc Xc X subroutine blddfl(work,wrow,a,b,ldab,m,n,rowred,colred) Xc implicit none Xc**** formal parameter declarations X integer ldab, m, n, rowred, colred, wrow X complex*16 work(wrow,*),a(ldab,*),b(ldab,*) Xc Xc*************************************************************** Xc Xc build difl matrix in work Xc in matlab notation Xc Xc difl matrix = < ; Xc > Xc Xc where a11 = a(1:rowred , 1:colred) Xc a22 = a(rowred+1 : m , colred+1 : n) Xc b11 = b(1:rowred , 1:colred) Xc b22 = b(rowred+1 : m , colred+1 : n) Xc Xc*************************************************************** Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** internal variables X integer wcol,rstrta,rstrtb,cstrt,cnt,i,j X integer row12,col1,col2,mmrwrd,nmclrd Xc Xc nmclrd = number of columns in (1,2), (2,2) blocks of a, b X nmclrd = n-colred Xc mmrwrd = number of rows in (2,1), (2,2) blocks of a, b X mmrwrd = m-rowred Xc row12 = numbers of rows in each subblock of difl matrix X row12 = colred*mmrwrd Xc col1 = number of columns in (1,1), (2,1) blocks of difl X col1 = rowred*mmrwrd Xc col2 = number of columns in (1,2), (2,2) blocks of difl X col2 = colred*nmclrd Xc wcol = total number of columns in difl X wcol = col1+col2 Xc Xc zero out difl X do 10 j=1,wcol X do 11 i=1,wrow X work(i,j)=0. X11 continue X10 continue Xc Xc fill in (1,1), (2,1) blocks of difl X rstrta=0 X rstrtb=row12 X cstrt=0 X do 1 j=1,colred X do 2 i=1,rowred X do 3 cnt=1,mmrwrd X work(cnt+rstrta,cnt+cstrt)=a(i,j) X work(cnt+rstrtb,cnt+cstrt)=b(i,j) X3 continue X cstrt=cstrt+mmrwrd X2 continue X cstrt=0 X rstrta=rstrta+mmrwrd X rstrtb=rstrta+row12 X1 continue Xc Xc fill in (1,2), (2,2) blocks of difl X rstrta=0 X cstrt=col1 X do 4 cnt=1,colred X rstrtb=rstrta+row12 X do 5 j=1,nmclrd X do 6 i=1,mmrwrd X work(rstrta+i,cstrt+j)=-a(i+rowred,j+colred) X work(rstrtb+i,cstrt+j)=-b(i+rowred,j+colred) X6 continue X5 continue X rstrta=rstrta+mmrwrd X cstrt=cstrt+nmclrd X4 continue X return X end Xc Xc X subroutine blddfu(work,wrow,a,b,ldab,m,n,rowred,colred) Xc implicit none Xc**** formal parameter declarations X integer ldab, m, n, rowred, colred, wrow X complex*16 work(wrow,*),a(ldab,*),b(ldab,*) Xc********************************************************************* Xc Xc build conjugate transpose difu matrix in work Xc in matlab notation Xc Xc (difu matrix)' = Xc Xc < < eye(n-colred) .*. a11' , eye(n-colred) .*. b11' >; Xc < -conj(a22) .*. eye(rowred) , -conj(b22) .*. eye(rowred) >> Xc Xc where a11 = a(1:rowred , 1:colred) Xc a22 = a(rowred+1 : m , colred+1 : n) Xc b11 = b(1:rowred , 1:colred) Xc b22 = b(rowred+1 : m , colred+1 : n) Xc Xc********************************************************************* Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** internal variables Xc X integer wcol,cstrta,cstrtb,rstrt,cnt,i,j X integer mmrwrd,nmclrd,rwrdp1,clrdp1 X integer row1, row2, col12 Xc Xc nmclrd = number of columns in (1,2), (2,2) entries of a, b X nmclrd=n-colred Xc col12 = number of columns in each subblock of difuct matrix X col12=rowred*nmclrd Xc mmrwrd = number of rows in (2,1), (2,2) entries of a, b X mmrwrd = m-rowred Xc row1 = number of rows in (1,1), (2,1) sublocks of difu X row1 = colred*nmclrd Xc row2 = number of rows in (1,2), (2,2) subblocks of difu X row2 = rowred*mmrwrd Xc wcol = total number of columns in difu matrix X wcol = 2*col12 Xc initialize difu to zero X do 1 j=1,wcol X do 2 i=1,wrow X work(i,j)=0. X2 continue X1 continue Xc Xc fill in (1,1), (1,2) positions of difu X cstrta=0 X rstrt=0 X do 3 cnt=1,nmclrd X cstrtb=cstrta+col12 X do 4 j=1,colred X do 5 i=1,rowred X work(rstrt+j,cstrta+i)=conjg(a(i,j)) X work(rstrt+j,cstrtb+i)=conjg(b(i,j)) X5 continue X4 continue X cstrta=cstrta+rowred X rstrt=rstrt+colred X3 continue Xc Xc fill in (2,1), (2,2) positions of difuct X rwrdp1=rowred+1 X clrdp1=colred+1 X cstrta=0 X cstrtb=col12 X rstrt=row1 X do 6 j=clrdp1,n X do 7 i=rwrdp1,m X do 8 cnt=1,rowred X work(cnt+rstrt,cnt+cstrta)=-conjg(a(i,j)) X work(cnt+rstrt,cnt+cstrtb)=-conjg(b(i,j)) X8 continue X rstrt=rstrt+rowred X7 continue X rstrt=row1 X cstrta=cstrta+rowred X cstrtb=cstrta+col12 X6 continue X return X end Xc Xc X subroutine bldrhs(work,a,b,ldab,m,n,rowred,colred) Xc implicit none Xc**** formal parameter declarations X integer ldab, m, n, rowred, colred X complex*16 work(*), a(ldab,*), b(ldab,*) Xc Xc********************************************************************* Xc Xc extract a12 = (1,2) block of a and b12 = (1,2) block of b Xc and store columnwise in work=(-col a12, -col b12) Xc Xc********************************************************************* Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** internal variables X integer clrdp1, j, i, loc Xc X clrdp1=colred+1 X loc=0 X do 1 j=clrdp1,n X do 2 i=1,rowred X loc=loc+1 X work(loc)=-a(i,j) X2 continue X1 continue X do 3 j=clrdp1,n X do 4 i=1,rowred X loc=loc+1 X work(loc)=-b(i,j) X4 continue X3 continue X return X end Xc Xc X subroutine prml(u,ldu,m,n,rhs,prod) Xc implicit none X integer ldu, m, n X complex*16 u(ldu,n),rhs(n),prod(m) Xc Xc********************************************************************* Xc compute prod = u * rhs Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc X integer i, j Xc X do 1 j=1,m X prod(j)=rhs(1)*u(j,1) X1 continue X if (n.eq.1) return X do 2 i=2,n X call zaxpy(m,rhs(i),u(1,i),1,prod,1) X2 continue X return X end Xc Xc X subroutine prmlct(u,ldu,m,n,rhs,prod) Xc implicit none X integer ldu, m, n X complex*16 u(ldu,n),rhs(m),prod(n),zdotc Xc Xc********************************************************************* Xc compute prod = (conjugate transpose u) * rhs Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc X integer j Xc X do 1 j=1,n X prod(j)=zdotc(m,u(1,j),1,rhs,1) X1 continue X return X end Xc Xc X subroutine svdiv(z,n,s) Xc implicit none X integer n X complex*16 z(n),s(n) Xc Xc********************************************************************* Xc divide one array by another Xc Xc**** this version dated 16 june 1987 Xc authors: jim demmel and bo kagstrom Xc X integer j Xc X do 1 j=1,n X z(j)=z(j)/s(j) X1 continue X return X end Xc X subroutine evalbd(delta, sdlmax, qnorm, pnorm, scase, X + m, n, irstrt, icstrt, X + lbndup, rbndup, lbndlw, rbndlw) Xc Xc implicit none Xc**** formal parameter declarations Xc X real*8 delta, sdlmax, qnorm, pnorm X real*8 lbndup, rbndup, lbndlw, rbndlw X integer scase, m, n, irstrt, icstrt Xc Xc****************************************************************** Xc Xc evaluate reducing subspace angular perturbation bounds computed Xc by subroutine bound for a perturbation of frobenius Xc norm delta. see documentation to subroutine bound for more details. Xc Xc inputs: Xc Xc sdlmax, qnorm, pnorm and scase are computed by bound. Xc m, n, irstrt and icstrt are dimensions also input to bound Xc in order to compute sdlmax, qnorm, pnorm and scase. Xc Xc outputs: Xc Xc lbndup - real*8 - upper bound on angular perturbation in Xc left reducing subspace Xc (0 if space trivial and -1 if inapplicable) Xc Xc rbndup - real*8 - upper bound on angular perturbation in Xc right reducing subspace Xc (0 if space trivial and -1 if inapplicable) Xc Xc lbndlw - real*8 - lower bound on angular perturbation in Xc left reducing subspace (-1 if inapplicable) Xc Xc rbndlw - real*8 - lower bound on angular perturbation in Xc right reducing subspace (-1 if inapplicable) Xc Xc************************************************************************ Xc Xc**** this version dated 16 june 87 Xc authors: jim demmel and bo kagstrom Xc Xc**** internal variables X real*8 relerr Xc X if (scase .ne. 4) relerr = delta/sdlmax X if (scase.eq.1) then X lbndup = atan(relerr/(pnorm-relerr*sqrt(pnorm**2-1.))) X rbndup = atan(relerr/(qnorm-relerr*sqrt(qnorm**2-1.))) X lbndlw = atan(1./(sqrt(2.*min(irstrt-1,m-irstrt+1))*pnorm + X + sqrt(pnorm**2-1.))) X rbndlw = atan(1./(sqrt(2.*min(icstrt-1,n-icstrt+1))*qnorm + X + sqrt(qnorm**2-1.))) X elseif (scase.eq.2) then X lbndup = 0. X rbndup = atan(relerr/(1.-relerr)) X lbndlw = -1. X rbndlw = -1. X elseif (scase.eq.3) then X lbndup = atan(relerr/(1.-relerr)) X rbndup = 0. X lbndlw = -1. X rbndlw = -1. X elseif (scase.eq.4) then X lbndup = 0. X rbndup = 0. X lbndlw = -1. X rbndlw = -1. X endif X return X end Xc X subroutine bndwsp(m,n,irstrt,icstrt,dimreg,ecase,space,info) Xc Xc implicit none Xc Xc**** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc Xc**** formal parameter declarations X integer m,n,irstrt,icstrt,dimreg,info,ecase,space Xc Xc******************************************************************** Xc Xc compute work space needed by subroutine bound Xc Xc inputs Xc Xc m,n - integer - row, column dimensions of a and b Xc Xc irstrt, icstrt - integer - starting row and column of selected Xc part of pencil for which eigenvalue bounds Xc are desired. reducing subspace bounds will be Xc supplied for right reducing subspace spanned Xc by leading icstrt-1 components and for left Xc reducing subspace spanned by leading icstrt-1 Xc components. Xc note: set icstrt=n+1 to make right reducing Xc subspace whole space Xc set irstrt=m+1 to make left reducing Xc subspace whole space Xc Xc dimreg - integer - number of selected eigenvalues; Xc if dimreg.eq.0 only subspace perturbation bounds will be Xc computed Xc (note - one can select a subset of the regular part only; Xc this gives generally different bounds for common eigenvalues Xc from a different selected subset; see paper above for Xc discussion) Xc Xc outputs Xc Xc ecase - integer - which of 5 cases for eigenvalue bounds Xc the pencil falls depending on input dimensions; Xc the first four cases are for dimreg.gt.0, in which Xc case the description gives: Xc (part of KCF to above, left of selected part) and Xc (part of KCF to below, right of selected part) Xc ecase=1 - (right singular and/or regular part) and Xc (left singular and/or regular part) Xc ecase=2 - (right singular and/or regular part) and (nothing) Xc ecase=3 - (nothing) and (left singular and/or regular part) Xc ecase=4 - (nothing) and (nothing) Xc ecase=5 - dimreg.eq.0 (no eigenvalue bounds) Xc Xc space - integer - amount of workspace (double precision complex Xc words) needed by subroutine bound Xc (the following simple expression bounds the workspace also, but Xc may occasionally be much too large (especially if ecase=4): Xc workspace .le. 2*m*n* (n*n + m*m + 2*n + m + 2) + n*n + m*m) Xc Xc info - integer - 0 if normal return Xc 1 if inconsistent input dimensions Xc Xc************************************************************************* Xc Xc**** this version dated 22 june 1987 Xc authors: jim demmel, courant institute, 251 mercer str, Xc new york, new york, 10012 Xc electronic address: demmel at nyu.edu Xc bo kagstrom, institute of information processing, Xc university of umea, s-90187 umea, sweden Xc electronic address: bokg at seumdc51.bitnet Xc Xc**** internal variables X integer irend,icend,m11,m21,m12,m22,n11,n12,n21,n22 Xc Xc test input dimensions for consistency X info = 0 X icend = icstrt+dimreg-1 X irend = irstrt+dimreg-1 X if (irstrt.gt.icstrt .or. irstrt.le.0 .or. X + n-icstrt-dimreg.gt.m-irstrt-dimreg .or. X + n-icstrt-dimreg+1.lt.0 .or. dimreg.lt.0) then Xc inconsistent input dimensions X info = 1 X else X if (dimreg.gt.0) then Xc there are eigenvalue bounds to compute Xc Xc ecase 1 - in addition to selected regular part KCF has Xc (right singular part and/or regular part) and Xc (left singular part and/or regular part) X if (icstrt.ne.1 .and. irend.ne.m) then X ecase = 1 X endif Xc Xc ecase 2 - in addition to selected regular part KCF has Xc (right singular part and/or regular part) and Xc (nothing) X if (icstrt.ne.1 .and. irend.eq.m) then X ecase=2 X endif Xc Xc ecase 3 - in addition to selected regular part KCF has Xc (nothing) and Xc (left singular part and/or regular part) X if (icstrt.eq.1 .and. irend.ne.m) then X ecase = 3 X endif Xc Xc ecase 4 - pencil regular and entire spectrum selected X if (icstrt.eq.1 .and. irend.eq.m) then X ecase=4 X endif Xc X else Xc dimreg.eq.0, so only compute subspace bounds X ecase = 5 X endif Xc X if (ecase .eq. 1) then X m11=irstrt-1 X m21=m-m11 X n11=icstrt-1 X n21=n-n11 X m12=irend-irstrt+1 X m22=m-irend X n12=icend-icstrt+1 X n22=n-icend X space = max( (2*n21*m11*(n11*n21+m11*m21+ X + 2*n21*m11+2)+n11*n21+m11*m21) , X + (2*((m21*n11+1)*(n11*n21+ X + m11*m21+1)-1)) , X + (2*n22*m12*(n12*n22+m12*m22+ X + 2*n22*m12+2)+n12*n22+m12*m22) , X + (2*((m22*n12+1)*(n12*n22+ X + m12*m22+1)-1)) ) X elseif (ecase .eq. 2 .or. ecase .eq. 5) then X m11=irstrt-1 X m21=m-m11 X n11=icstrt-1 X n21=n-n11 X space = max( (2*n21*m11*(n11*n21+m11*m21+ X + 2*n21*m11+2)+n11*n21+m11*m21) , X + (2*((m21*n11+1)*(n11*n21+ X + m11*m21+1)-1)) ) X elseif (ecase .eq. 3) then X m11=irend X m21=m-m11 X n11=icend X n21=n-icend X space = max( (2*n21*m11*(n11*n21+m11*m21+ X + 2*n21*m11+2)+n11*n21+m11*m21) , X + (2*((m21*n11+1)*(n11*n21+ X + m11*m21+1)-1)) ) X elseif (ecase .eq. 4) then X space = n*n X endif X endif Xc X if (idbg(19).ne.0) then X write(outunit,100) m,n,irstrt,icstrt,dimreg,ecase, X + space,info X100 format(' bndwsp - m,n,irstrt,icstrt,dimreg' X + ',ecase,space,info=',/,8i5) X endif X return X end END_OF_zbnd.f if test 52873 -ne `wc -c zcmatmlr.f <<'END_OF_zcmatmlr.f' X Xc on this file june 7, 1987: cmatml, cmatmr Xc X subroutine cmatml(a,lda,rowa,cola,b,ldb,rowb,c,ldc,work,job) Xc Xc implicit none X integer lda,rowa,cola,ldb,rowb,ldc,job X complex*16 a(lda,lda),b(ldb,ldb),c(ldc,ldc),work(*) X complex*16 zdotu,zdotc Xc Xc*********************************************************************** Xc Xc cmatml performs a complex (left) matrix multiplication b * a, Xc or b' * a (' = transpose ,conjugate) where a is rowa * cola, Xc b is rowb * rowa. the result is stored in c or overwritten in a. Xc note the extra restrictions on dimensions of b when job = 3 or 4. Xc Xc on entry Xc Xc a complex(lda,cola), where lda>=rowa. Xc Xc lda integer Xc lda is the leading dimension of the array a. Xc Xc rowa integer Xc rowa is the number of rows of a, which is also Xc the number of columns of b. Xc cola integer Xc cola is the number of columns of a, which is also Xc the number columns of the resulting matrix. Xc Xc b complex(ldb,rowa), ldb>=rowb. Xc Xc ldb integer Xc ldb is the leading dimension of the array b. Xc Xc rowb integer Xc rowb is the number of rows of the array, which Xc is also the number of rows of the resulting matrix. Xc Xc ldc integer Xc ldc is the leading dimension of the array c Xc Xc work complex(rowa) Xc work is a scratch array. Xc Xc job integer Xc job controls the matrix multiplication, and has Xc the following meaning Xc job=1 a = b * a Xc job=2 c = b * a Xc job=3 a = b' * a Xc job=4 c = b' * a Xc Xc on return Xc Xc c complex(ldc,cola), where ldc>=rowb. Xc c is the matrix product of a and b. if rowa (=colb) Xc = rowb then it is possible to call cmatml with c Xc equals to a, and the result is overwritten in a. Xc Xc********************************************************************* Xc Xc this version dated june 7, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc***** internal variables Xc X integer i,j Xc Xc***** cmatml uses the following functions and subroutines Xc Xc blas zcopy, zdotc, zdotu Xc Xc***** determine what is to be computed via nested if-then -else's Xc X do 20 j = 1, cola X do 10 i = 1, rowb X if (job .eq. 1) then X work(i) = zdotu(rowa,b(i,1),ldb,a(1,j),1) X elseif (job .eq. 2) then X c(i,j) = zdotu(rowa,b(i,1),ldb,a(1,j),1) X elseif (job .eq. 3) then X work(i) = zdotc(rowa,b(1,i),1,a(1,j),1) X else Xc (job .eq. 4) X c(i,j) = zdotc(rowa,b(1,i),1,a(1,j),1) X endif X 10 continue X if (job .eq. 1 .or. job .eq. 3) then X call zcopy(rowa,work,1,a(1,j),1) X endif X 20 continue X return X end X X X subroutine cmatmr(a,lda,rowa,cola,b,ldb,colb,c,ldc,work,job) Xc Xc implicit none X integer lda,rowa,cola,ldb,colb,ldc,job X complex*16 a(lda,lda),b(ldb,ldb),c(ldc,ldc),work(*) X complex*16 zdotu,zdotc Xc Xc*********************************************************************** Xc Xc cmatmr performs a complex (right) matrix multiplication a * b, Xc or a * b' ,(' = transpose ,conjugate), where a is rowa * cola, Xc b is cola * colb. the result is stored in c or overwritten in a. Xc note the extra restrictions in dimension of b when job = 3 or 4. Xc Xc on entry Xc Xc a complex(lda,cola), where lda>=rowa. Xc Xc lda integer Xc lda is the leading dimension of the array a. Xc Xc rowa integer Xc rowa is the number of rows of a, which is also Xc the number of rows in the resulting matrix. Xc cola integer Xc cola is the number of columns of a, which is also Xc the number of rows of b. Xc Xc b complex(ldb,colb), ldb>=cola. Xc Xc ldb integer Xc ldb is the leading dimension of the array b. Xc Xc colb integer Xc colb is the number of columns of b, which is Xc also the number of columns of the resulting matrix Xc Xc ldc integer Xc ldc is the leading dimension of the array c Xc Xc work complex(cola) Xc work is a scratch array. Xc Xc job integer Xc job controls the matrix multiplication, and has Xc the following meaning Xc job=1 a = a * b Xc job=2 c = a * b Xc job=3 a = a * b' Xc job=4 c = a * b' Xc Xc on return Xc Xc c complex(ldc,colb), where ldc>=rowa. Xc c is the matrix product of a and b. if cola(=rowb) Xc = colb then it is possible to call cmatmr with c Xc equals to a, and the result is overwritten in a. Xc Xc********************************************************************* Xc Xc this version dated june 7, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc***** internal variables Xc X integer i,j Xc Xc***** cmatmr uses the following functions and subroutines Xc Xc blas zcopy, zdotc, zdotu Xc Xc***** determine what is to be computed via nested if-then -else's Xc X do 20 i = 1, rowa X do 10 j = 1, colb X if (job .eq. 1) then X work(j) = zdotu(cola,a(i,1),lda,b(1,j),1) X else if (job .eq. 2) then X c(i,j) = zdotu(cola,a(i,1),lda,b(1,j),1) X else if (job .eq. 3) then X work(j) = zdotc(cola,b(j,1),ldb,a(i,1),lda) X else Xc (job .eq. 4) X c(i,j) = zdotc(cola,b(j,1),ldb,a(i,1),lda) X end if X 10 continue X if (job .eq. 1 .or. job .eq. 3) then X call zcopy(cola,work,1,a(i,1),lda) X end if X 20 continue X return X end X END_OF_zcmatmlr.f if test 6590 -ne `wc -c zftest1.f <<'END_OF_zftest1.f' X integer function ftest(alpha,beta) Xc Xc implicit none X complex*16 alpha, beta Xc Xc**** fout checks if the complex root alpha/beta lies outside Xc the unit disc Xcc if (abs(beta) .eq. 0.0 ) then Xcc ftest = 1 Xcc elseif (abs(alpha/beta) .lt. 1.0) then X ftest = -1 Xcc else Xcc ftest = 1 Xcc endif X return X end Xc X integer function ftestp(alpha,beta) Xc Xc implicit none X complex*16 alpha, beta Xc Xc**** fout checks if the complex root alpha/beta lies outside Xc the unit disc Xcc if (abs(beta) .eq. 0.0 ) then Xcc ftestp = 1 Xcc elseif (abs(alpha/beta) .lt. 1.0) then X ftestp = -1 Xcc else Xcc ftestp = 1 Xcc endif X return X end END_OF_zftest1.f if test 752 -ne `wc -c zgschur.c1 <<'END_OF_zgschur.c1' XTestrun identification: April 1, 1990 Example C1 - zgschur X X X lda= 30 m= 4 n= 5 X final version of a input X ---------------------------------------------------------------------- X 0.10000000000000000D+01-0.20000000000000000D+01 0.00000000000000000D+00 X 0.10000000000000000D+01 0.00000000000000000D+00-0.10000000000000000D+01 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 X 0.10000000000000000D+01 0.00000000000000000D+00 X 0.00000000000000000D+00 0.20000000000000000D+01 X X X lda= 30 m= 4 n= 5 X final version of b input X ---------------------------------------------------------------------- X 0.00000000000000000D+00 0.10000000000000000D+01 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.10000000000000000D+01 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 X 0.10000000000000000D+01 0.00000000000000000D+00 X 0.00000000000000000D+00 0.10000000000000000D+01 X X X debug controls - X 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 X 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 X input: epsu= 0.10000D-07 X gap= 0.10000D+04 X epsper = 0.10000D-09 numex = 1 numtst= 1 jobper = 3 X epsbnd = X 0.100D-09 X zero=T X nostat=T X epsper= 0.10000D-09 X norm(a,e)= 0.34641D+01 norm(b,e)= 0.20000D+01 X start guptri X guptri - workspace for rzstr - 4 5 4 5 1 X 6 26 31 61 36 41 86 46 51 56 X X Xguptri - m,n,epsu= 4 5 0.100000D-07 X Xreduction 1 X Xkstr, last= 3 X 1 2 3 X 1 1 1 X 1 1 0 Xaccumulated perturbations in a,b = 0.000000D+00 0.000000D+00 X Xreduction 4, kfirst= 5 X 1 2 3 4 5 X 1 1 1 -1 0 X 1 1 0 -1 0 Xaccumulated perturbations in a,b = 0.000000D+00 0.000000D+00 X X Xfinal kstr= X 1 2 3 4 5 6 7 X 1 1 1 -1 -1 2 -1 X 1 1 0 -1 -1 2 -1 X nsumrz= 3 X rsumrz= 2 X djordz= 0 X nsumli= 0 X rsumli= 0 X djordi= 0 X dimreg= 2 X X Xfinal pstruc= 3 3 3 3 Xfinal struc = X 1 1 1 X rtce= 3 zrce= 3 fnce= 5 ince= 5 X rtre= 2 zrre= 2 fnre= 4 inre= 4 X computed eigenvalues X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X eigenvalues before reordering X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X eigenvalues after reorder and X computed eigenvalues X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X results from guptri and reorder X rtce= 3 zrce= 3 fnce= 5 ince= 5 X rtre= 2 zrre= 2 fnre= 4 inre= 4 Xpstruc = 3 3 3 3 Xstruc = X 1 1 1 Xnsumrz= 3 Xrsumrz= 2 Xdjordz= 0 Xnsumli= 0 Xrsumli= 0 Xdjordi= 0 Xdimreg= 2 Xndim= 0 X Relative perturbation in a= 0.000000D+00 X Relative perturbation in b= 0.000000D+00 X Frobeniusnorm of deleted singular vaules=0.000000D+00 X kstr, step= 7 X 1 1 1 -1 -1 2 -1 X 1 1 0 -1 -1 2 -1 X lda= 30 m= 4 n= 5 X Transformed matrix A X ---------------------------------------------------------------------- X 0.00000000000000000D+00-0.15811388300841895D+01 0.94868329805051310D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.18973665961010271D+01 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X 0.00000000000000000D+00 0.35138622112200610D-15 X 0.00000000000000000D+00 0.37144952276981167D-15 X 0.10000000000000000D+01 0.00000000000000000D+00 X 0.00000000000000000D+00 0.19999999999999998D+01 X X X lda= 30 m= 4 n= 5 X Transformed matrix B X ---------------------------------------------------------------------- X -0.74535599249992979D+00 0.63245553203367566D+00-0.21081851067789167D+00 X 0.00000000000000000D+00-0.31622776601683794D+00-0.94868329805051332D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X 0.00000000000000000D+00-0.10753675309148582D-15 X 0.00000000000000000D+00-0.15259246943748575D-15 X 0.10000000000000000D+01 0.00000000000000000D+00 X 0.00000000000000000D+00 0.99999999999999989D+00 X X X cond(PP)=0.100000D+01 X cond(QQ)=0.100000D+01 X abs(a-acopy)=0.777156D-15 X relative dif.=0.224346D-15 X abs(b-bcopy)=0.416334D-15 X relative dif.=0.208167D-15 X fro(a-pp" * acopy * qq)=0.368219D-15 X relative fro for a-part=0.106296D-15 X fro(b-pp" * bcopy * qq)=0.209550D-15 X relative fro for b-part=0.104775D-15 X colrs= 3 X rowrs= 2 X len= 2 X bndwsp X ecase= 2 X space= 170 X info= 0 X icase= 1 X ecase= 2 X ierr= 0 X delmax= 0.33861D+00 X pdelta= 0.33861D+00 X difl= 0.11561D+01 X difu= 0.13095D+01 X qnorm= 0.10000D+01 X pnorm= 0.10000D+01 X pqnorm= 0.14142D+01 X dsvd= 0.54641D-07 X X results from pbound X difl= 0.11561D+01 X difu= 0.13095D+01 X qnorm= 0.10000D+01 X pnorm= 0.10000D+01 X delta= 0.54641D-07 X pdelta= 0.33861D+00 X lbndup= 0.16137D-06 X rbndup= 0.16137D-06 X lbndlw= 0.46365D+00 X rbndlw= 0.46365D+00 X ierr= 0 X eigenvalue bounds X delmax(capital delta for eigenv)= 0.338615D+00 X eigenvalue= 0.100000000000000D+01 0.000000000000000D+00 X aii= 0.70711D+00 0.00000D+00 bii= 0.70711D+00 0.00000D+00 k= 0.20000D+01 X eigenvalue= 0.200000000000000D+01 0.000000000000000D+00 X aii= 0.89443D+00 0.00000D+00 bii= 0.44721D+00 0.00000D+00 k= 0.12649D+01 X epsbnd= 0.10000D-09 X norm(aper,e)= 0.34641D+01 norm(bper,e)= 0.20000D+01 X start guptri for perturbed pair no. X iper= 1 X itst= 1 X guptri - workspace for rzstr - 4 5 4 5 1 X 6 26 31 61 36 41 86 46 51 56 X X Xguptri - m,n,epsu= 4 5 0.100000D-07 X Xreduction 1 X Xkstr, last= 3 X 1 2 3 X 1 1 1 X 1 1 0 Xaccumulated perturbations in a,b = 0.000000D+00 0.323534D-08 X Xreduction 4, kfirst= 5 X 1 2 3 4 5 X 1 1 1 -1 0 X 1 1 0 -1 0 Xaccumulated perturbations in a,b = 0.000000D+00 0.323534D-08 X X Xfinal kstr= X 1 2 3 4 5 6 7 X 1 1 1 -1 -1 2 -1 X 1 1 0 -1 -1 2 -1 X nsumrz= 3 X rsumrz= 2 X djordz= 0 X nsumli= 0 X rsumli= 0 X djordi= 0 X dimreg= 2 X X Xfinal pstruc= 3 3 3 3 Xfinal struc = X 1 1 1 X rtce= 3 zrce= 3 fnce= 5 ince= 5 X rtre= 2 zrre= 2 fnre= 4 inre= 4 X computed eigenvalues X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X eigenvalues before reordering X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X eigenvalues after reorder and X computed eigenvalues X eigenvalue= 0.10000D+01 0.00000D+00 X eigenvalue= 0.20000D+01 0.00000D+00 X results from guptri and reorder, iper= 1 X rtce= 3 zrce= 3 fnce= 5 ince= 5 X rtre= 2 zrre= 2 fnre= 4 inre= 4 Xpstruc = 3 3 3 3 Xstruc = X 1 1 1 Xnsumrz= 3 Xrsumrz= 2 Xdjordz= 0 Xnsumli= 0 Xrsumli= 0 Xdjordi= 0 Xdimreg= 2 Xndim= 0 X Relative perturbation in a= 0.000000D+00 X Relative perturbation in b= 0.161767D-08 X Frobeniusnorm of deleted singular values=0.323534D-08 X kstr, step= 7 X 1 1 1 -1 -1 2 -1 X 1 1 0 -1 -1 2 -1 X lda= 30 m= 4 n= 5 X Transformed matrix A X ---------------------------------------------------------------------- X 0.00000000000000000D+00 0.15811388300841898D+01 0.94868329800765749D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.18973665960867427D+01 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X -0.23334701776492633D-08 0.35986913438820403D-09 X -0.30001759273521061D-08-0.30392879514122899D-15 X 0.10000000000677638D+01 0.11389717383782053D-15 X 0.00000000000000000D+00 0.20000000000677636D+01 X X X lda= 30 m= 4 n= 5 X Transformed matrix B X ---------------------------------------------------------------------- X -0.74535599255605001D+00-0.63245553197415183D+00-0.21081851065805099D+00 X 0.00000000000000000D+00 0.31622776601683827D+00-0.94868329805051377D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X 0.00000000000000000D+00 0.00000000000000000D+00 0.00000000000000000D+00 X X X 0.66670575164805837D-09-0.14394773176978720D-09 X 0.30001760174657973D-08-0.64776443177036579D-09 X 0.10000000000000002D+01 0.16868641798082849D-15 X 0.00000000000000000D+00 0.10000000000000000D+01 X X X cond(PPper)=0.100000D+01 X cond(QQper)=0.100000D+01 X abs(a-acopy)=0.217928D-14 X relative dif.=0.629104D-15 X abs(b-bcopy)=0.384527D-08 X relative dif.=0.192263D-08 X fro(a-pp" * acopy * qq)=0.850587D-15 X relative fro for a-part=0.245543D-15 X fro(b-pp" * bcopy * qq)=0.323534D-08 X relative fro for b-part=0.161767D-08 X X X perturbation results for iper= 1 itst= 1 epsbnd = 0.10000D-09 X dist =0.324950D-08 X distup =0.547367D-07 X pcolrs = 3 X prowrs = 2 X pdelta =0.338615D+00 X case 1 of theorem holds X rbndlw =0.463648D+00 X lbndlw =0.463648D+00 X rbdupp =0.959645D-08 X lbdupp =0.959645D-08 X thetar=0.216924D-08 X thetal =0.112663D-08 X X Xnew eigenbound test for iper= 1 X compare eigenvalues 1 X unperturbed eigenvalue = 0.100000000000000D+01 0.000000000000000D+00 X perturbed eigenvalue = 0.100000000006776D+01 0.000000000000000D+00 X eigenbound holds with ebnd= 0.45955D-08 edif= 0.47916D-10 X compare eigenvalues 2 X unperturbed eigenvalue = 0.200000000000000D+01 0.000000000000000D+00 X perturbed eigenvalue = 0.200000000006776D+01 0.000000000000000D+00 X eigenbound holds with ebnd= 0.45955D-08 edif= 0.30305D-10 X X Xtest eigenbounds for iper= 1 X compare eigenvalues 1 X unperturbed eigenvalue = 0.100000000000000D+01 0.000000000000000D+00 X perturbed eigenvalue = 0.100000000006776D+01 0.000000000000000D+00 X eigenbound holds with ebnd= 0.64990D-08 edif= 0.33882D-10 X compare eigenvalues 2 X unperturbed eigenvalue = 0.200000000000000D+01 0.000000000000000D+00 X perturbed eigenvalue = 0.200000000006776D+01 0.000000000000000D+00 X eigenbound holds with ebnd= 0.41103D-08 edif= 0.13553D-10 X Summary of statistics: X ===================== X X Number of bad svds and qzs = ninfo = 0 X Number of inapplicable eigenbounds = badeig = 0 X X Distance between pencils on the surface X divided by the true distance between perturbed X and unperturbed input pencils X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 10.722715194391 X average = 10.722715194391 X max = 10.722715194391 X X Distance between pencils on the surface X divided by the size of the perturbation (epsbnd) X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 32.494973305147 X average = 32.494973305147 X max = 32.494973305147 X Reducing subspaces: X Different cases: X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X Case 1: right upper bounds X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 4.4238853094134 X average = 4.4238853094134 X max = 4.4238853094134 X Case 1: left upper bounds X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 8.5178173535157 X average = 8.5178173535157 X max = 8.5178173535157 X Case 2: right lower bounds X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 0. X average = 0. X max = 0. X Case 2: left lower bounds X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 0. X average = 0. X max = 0. X Eigenvalues: number of them= 2 X Different cases (Gerschgorin type bounds): X Eigv. no. 1 X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X Eigv. no. 2 X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X Eigenvalue bounds (upper) X Eigv. no. 1 X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 191.81443960941 X average = 191.81443960941 X max = 191.81443960941 X Eigv. no. 2 X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 303.28426484587 X average = 303.28426484587 X max = 303.28426484587 X Different cases( new bounds from LAA87): X Eigv. no. 1 X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X Eigv. no. 2 X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X Eigenvalue bounds (upper) X Eigv. no. 1 X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 95.907059974105 X average = 95.907059974105 X max = 95.907059974105 X Eigv. no. 2 X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 1 0 0 0 0 0 0 0 0 0 1 100 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X 0 0 0 0 0 0 0 0 0 0 0 0 X X min = 151.64229361397 X average = 151.64229361397 X max = 151.64229361397 XMaximum values of radife, rbdife 2.4554337601543D-16 1.6176676252446D-09 END_OF_zgschur.c1 if test 17039 -ne `wc -c zgschurm.f <<'END_OF_zgschurm.f' Xc On this file March 1990: zgschurm, edist Xc X program zgschurm Xc implicit none Xc**** debug space Xc the common-block declarations assume that the dimension of the Xc input matrix pencil a - lambda b is not larger than 30. Xc the debug space is used for producing debug outputs (optional, Xc see below) Xc X integer abdim, wdim, abdim6 Xc abdim6 = abdim + 6 X parameter ( abdim = 30, wdim = 20000, abdim6 = 36) X common /debug1/ acopy(abdim, abdim),bcopy(abdim, abdim), X * atest(abdim, abdim), btest(abdim, abdim), swap X common /debug2/ idbg(20), outunit X complex*16 acopy, bcopy, atest, btest X integer idbg, outunit X logical swap Xc***** This version of zgschurm computes pairs of reducing Xc subspaces associated with different subspaces of a Xc (generalized) state space system. Further, it collects statistics Xc for random examples Xc Xc Revision: 900323 (this version goes with final versions of Xc guptri and bounds) Xc Xc*+*+*+ Xc The program starts by asking for input and output Xc files (infile and outfile) where Xc infile contains A and B of dimension M by N and Xc debug and control inputs (see below) Xc outfile contains output from the program Xc Then it asks for a textstring identifying the run (.le. 80 chars) Xc*+*+*+ Xc Xc***** debug flags (20i1) Xc idbg(1) ne 0 - turn on debug output for kcfmain Xc idbg(2) ne 0 - turn on debug output for guptri Xc idbg(3) ne 0 - turn on debug output for krnstr Xc idbg(4) ne 0 - turn on debug output for rzstr Xc idbg(5) ne 0 - turn on debug output for listr Xc idbg(6) ne 0 - turn on debug output for rcsvdc Xc idbg(7) ne 0 - turn on debug output for reordr Xc idbg(8) ne 0 - turn on debug output for exchng Xc idbg(9) ne 0 - turn on debug output for pbound (no debug) Xc idbg(10) ne 0 - turn on debug output for gvec Xc+*+ idbg(11) ne 0 - turn on debug output for pertb1 860729 Xc idbg(12) ne 0 - turn on debug output for qz Xc idbg(19) ne 0 - turn on debug output for bndwsp Xc idbg(20) ne 0 - turn on debug output for bound Xc Xc***** control inputs (2i1,i4,i1) Xc izero ne 0 - zero out nonzero singular values during reduction Xc itrpose ne 0 - transpose input matrices a and b Xc job (4th digit) ne 0 - pre, postmultiply a by random nonsingular Xc matrices p, q, called wanta in output Xc job (3rd digit) ne 0 - pre, postmultiple a by random nonsingular Xc matrices p, q, called wantb in output Xc job (2nd digit) ne 0 - add random noise of size machep to a, b, Xc called pertur in output Xc job (1st digit) ne 0 - print block structured input a, b, and Xc final input a,b if different, Xc called prints in output Xc exprin ne 0 - print outs for each example and statistics Xc eq 0 - only print outs of statistics Xc*+*+*+ 860731 Xc epsu (2d10.0) user specified uncertainty in the input Xc A and B (used for deleting small singular Xc values) Xc gap gap between small singular values Xc epsper (d10.0) size of perturbation to A and B on input Xc (only used if job (2nd digit ne 0) Xc numex (3i5) number of values of epsbnd's Xc numtst number of times we shall add noise of Xc size epsbnd(iper) to A and B Xc jobper structure of the perturbations added Xc to A and B Xc epsbnd(numex) (5d10.0) size of perturbation that we add to A and B Xc*+*+*+ Xc Statistics are collected from numex*numtst random examples. Xc Starting from a nongeneric pencil and a rule(epsu,gap) for Xc choosing a particular set of reducing subspaces we add random noise Xc to get perturbed pencils as input for GUPTRI Xc Xc X complex*16 a(abdim,abdim),b(abdim,abdim), X * work(wdim), pp(abdim,abdim), qq(abdim,abdim) X complex*16 zat, zbt, aorig(abdim,abdim), borig(abdim,abdim), X * aprim(abdim,abdim), bprim(abdim,abdim), X * ppper(abdim,abdim), X * qqper(abdim,abdim) X complex*16 aortr(abdim,abdim),bortr(abdim,abdim) X integer rtre, rtce, zrre, zrce, fnre, fnce, inre, ince X integer pstruc(4), struc(abdim), space X integer nsumrz,rsumrz,nsumli,rsumli X integer djordz,djordi,dimreg Xc 06/16/87 X integer rowb, colb, rowe, cole Xc X integer kstr(4,abdim6), step, allreg, krstrt, kcstrt, icase X integer three, ithree, ecase X integer ndim, rindx(abdim6), ftest, colrs, rowrs, pcolrs, prowrs X integer sstrt,estrt,wstrt,ninfo X integer fout, fin, folhp, fcrhp X external fout, fin, folhp, fcrhp, ftest, ftestp X logical zero, ldebug X logical trpose, pbndok, nostat Xc*+*+ demmel, 7/3/86 X logical ebndok Xc*+*+ X complex*16 evala(abdim),evalb(abdim) Xc*+*+ X complex*16 evalap(abdim),evalbp(abdim) Xc*+*+ X real*8 lbndup, lbndlw, gvcond(abdim), anormf, bnormf, X * lbdupp, rbdupp, relerr, rbndup, rbndlw X real*8 scl, epsu, gap X real*8 epsper, epsbnd(20), delmax Xc*+*+*+ 860731 X integer numex, jobper, numtst, iper, itst, exprin X character*80 infile, outfile, ident Xc*** data for statistics /rev 870526 and 870626 X integer statrs(6,12), stateg(3,12,10), stateg1(2,12,10) X integer sdstqt(7,12), sdstqe(7,12) X integer srqtup(6,12), slqtup(6,12) X integer srqtlw(6,12), slqtlw(6,12), segqt(6,12,10) X integer segqt1(6,12,10), badeig X real*8 rqtup, lqtup, rqtlw, lqtlw, egqt Xc Xc variables for min, average and max computations /870526 X real*8 maxrda, maxrdb X real*8 minqt, avrqt, maxqt X real*8 minqe, avrqe, maxqe X real*8 minrup, avrrup, maxrup X real*8 minlup, avrlup, maxlup X real*8 minrlw, avrrlw, maxrlw X real*8 minllw, avrllw, maxllw X real*8 minegq(10), avregq(10), maxegq(10) X real*8 minegq1(10), avregq1(10), maxegq1(10) Xc end of new variables for statistics/ 870526 and 870626 X logical infnt, infntp Xc*+*+*+ X complex*16 dum, dummy X integer i, izero, itrpos, job, lda, ldb, m, n, ldab X integer ldqq, ierr, info, len, k, jjj, ieig, j, ldpp X real*8 cpp, cqq, difa, difb, adife, bdife, anore, bnore X real*8 dsvd, adsvd, bdsvd X real*8 rdifa, rdifb, radife, rbdife, difu, difl X real*8 pqnorm, qnorm, pnorm X real*8 pdelta, dist, dstqt, dstqe, dstpu X real*8 dsvdp, adsvdp, bdsvdp X real*8 distup X real*8 thetal, thetar, ebnd, edif X real*8 cond, cnorm, cdife Xc**** generate a singular matrix pencil Xc Xc data lda/20/, ldb/20/, ldpp/20/, ldqq/20/, ldab/20/ X lda = abdim X ldb = abdim X ldpp = abdim X ldqq = abdim X ldab = abdim Xc Xc*+*+*+ 860731 X write(*,*) 'Give infile and outfile:' X read(*,7034) infile X read(*,7034) outfile X 7034 format(A) Xc X write(*,*) 'Identify this testrun:' X read (*,7034) ident X open(5, file = infile, status = 'old') X outunit = 6 X open(6, file = outfile, status = 'new') X write(6,7035) 'Testrun identification: ',ident X 7035 format(A,A//) Xc*+*+*+ Xc Xc read in matrix dimensions and matrices a and b X read(5,6543) m,n X do 7010 i = 1, m X read(5, *) (a(i,j), j = 1, n) X7010 continue X do 7015 i = 1, m X read(5,*) (b(i,j), j = 1,n) X7015 continue X6543 format(2i5) Xc Xc copy a and b to acopy and bcopy, respectively Xc X call cmcopy(b,ldb,m,n,bcopy) X call cmcopy(a,lda,m,n,acopy) Xc X call cmatpr(a,lda,m,n,'final version of a input') X call cmatpr(b,lda,m,n,'final version of b input') Xc read in debug controls X read(5,1235) (idbg(i),i=1,20) X1235 format(20i1) X write (6,1236) (j,j=1,20), (idbg(j),j=1,20) X1236 format(' debug controls -',/,1x,20i3,/,1x,20i3) Xc*+*+*+ Xc read in job controls X read(5,1234) izero,itrpos,job, exprin X1234 format(2i1,i4,i1) Xc Xc read epsu (relative error in input matrices) and gap Xc (for nullity testing) X read(5, 202) epsu, gap X 202 format(2d10.0) X write(6, 203) 'input: epsu=', epsu, 'gap=', gap X 203 format(t5,a,d15.5) X read (5,204) epsper X 204 format(d10.0) Xc*+*+*+ X read(5,205) numex, numtst, jobper X 205 format(3i5) Xc*+*+*+ X if (numex .gt. 0) read(5,206) ( epsbnd(i), i= 1, numex) X 206 format (5d10.0) Xc X write(6,207) ' epsper =', epsper, ' numex =', numex, X * ' numtst=', numtst, ' jobper =', jobper X 207 format(t5, a, d15.5, 3 (a, i5)) X if (numex .gt. 0) then X write(6,207) ' epsbnd =' X write(6,208) ( epsbnd(i), i= 1, numex) X 208 format(t5, 5d12.3) X endif Xc*+*+*+ start (trpose never used in this code!) X trpose=.false. X if (itrpos.ne.0) trpose=.true. X zero=.false. X if (izero.ne.0) zero=.true. X write(6,201) 'zero=', zero X201 format(t5,a,l1) Xc X nostat = .true. X if (exprin .eq. 0) nostat = .false. X write(6,201) 'nostat=', nostat Xc*+*+*+ end Xc copy a and b to aorig and borig for later perturbing Xc aorig and borig should never be changed!!!!! X call cmcopy(a, ldab, m, n, aorig) X call cmcopy(b, ldab, m, n, borig) X anormf = cnorm(a, ldab, m, n, 0, work) X bnormf = cnorm(b, ldab, m, n, 0, work) Xc X write(6, 350) 'epsper=', epsper X write(6, 350) 'norm(a,e)=', anormf, 'norm(b,e)=', bnormf X 350 format(t5,a,d12.5,tr5,a,d12.5,tr5,d12.5) Xc X 200 format(t5,a,d12.6) X X write(6, 100) 'start guptri' Xc Xc**** 6/16/87 Xc X call guptri(a ,b , ldab, m, n, epsu, gap, zero, X * pp, ldpp, qq, ldqq, adsvd, bdsvd, X * rtre, rtce, zrre, zrce, fnre, fnce, inre, ince, X * pstruc, struc, work, kstr, info) Xc Xc*** 6/18/87 X if (info .ne. 0) then X write (6,2000) 'after first guptri, info=', info X endif X dsvd = sqrt ( (anormf*adsvd)**2 + (bnormf*bdsvd)**2 ) Xc Xc**** 6/16/87 Xc compute step by searching through kstr X three = 0 X do 61687 ithree = 1, 20 X if ( three .eq. 3) go to 61688 X if( kstr(1, ithree) .eq. -1) then X three = three + 1 X endif X61687 continue Xc X if ( three .lt. 3) then X write(*,*) 'ERROR in kstr (computing step in driver)' X stop X endif Xc X61688 continue X step = ithree - 1 Xc*** end of computing step Xc Xc**** 6/15/87 Xc compute ome structure infortmation (not parameters to guptri any more) X nsumrz = zrce X rsumrz = zrre X nsumli = n - fnce X rsumli = m - fnre X djordz = zrre - rtre X djordi = inre - fnre X dimreg = fnre - zrre X ndim = 0 Xc Xc*+*+ added 06/16/87 Xc**** reorder the eigenvalues according to the user specified Xc integer function ftest Xc set debug flag for guptri so we can compare with old version of Xc driver X ldebug = idbg(2) X allreg = dimreg + djordz + djordi X rowb = rsumrz - djordz + 1 X colb = nsumrz - djordz + 1 X rowe = rowb + allreg - 1 X cole = colb + allreg - 1 X if (ldebug) then X write(outunit, 2005) 'eigenvalues before reordering' X do 70 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X 2005 format(t5,a,4d15.5) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 70 continue X endif X if (allreg .ge. 1) then X call reordr(a, b, ldab, m, n, rowb, colb, rowe, cole, X * ftest, ndim, rindx, pp, ldpp, qq, ldqq) Xc X if (idbg(2) .gt. 1) then X call cmatpr(qq,ldqq,n,n,'qq after reordr') X call cmatpr(pp,ldpp,m,m,'pp after reordr') X endif X endif Xc X if (ldebug) then X write(outunit, 2005) 'eigenvalues after reorder and' X write(outunit, 2005) 'computed eigenvalues' X do 75 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 75 continue X endif Xc Xc+*+ end add reorder* Xc save transformed original a and b in aprim, bprim,aortr,bortr Xc X call cmcopy(a, ldab, m, n, aprim) X call cmcopy(b, ldab, m, n, bprim) Xc X call cmcopy(a, ldab, m, n, aortr) X call cmcopy(b, ldab, m, n, bortr) Xc Xc compute aprim = pp * aprim * qq**H and Xc bprim = pp * bprim * qq**H X call cmatml(aprim,ldab,m,n,pp,ldpp,m,aprim,ldab,work,1) X call cmatmr(aprim,ldab,m,n,qq,ldqq,n,aprim,ldab,work,3) X call cmatml(bprim,ldab,m,n,pp,ldpp,m,bprim,ldab,work,1) X call cmatmr(bprim,ldab,m,n,qq,ldqq,n,bprim,ldab,work,3) X if (idbg(1) .ge. 2) then X call cmatpr(aprim,ldab,m,n,'final aprim') X call cmatpr(bprim,ldab,m,n,'final bprim') X endif X write(6, 100) 'results from guptri and reorder' X 100 format (t5, a, i4) Xc Xc**** 6/15/87 X write(6,7357) 'rtce=',rtce,'zrce=',zrce,'fnce=',fnce, X + 'ince=',ince,'rtre=',rtre,'zrre=',zrre, X + 'fnre=',fnre,'inre=',inre X write (6,7355) (pstruc(j),j=1,4) X if (pstruc(4).gt.0) write (6,7356)(struc(j),j=1,pstruc(4)) X 7355 format('pstruc = ',4i4,/,'struc =') X 7356 format(15i4) X 7357 format(4(3x,a,i4),/,4(3x,a,i4)) X write (6,123) nsumrz,rsumrz,djordz,nsumli,rsumli,djordi, X * dimreg, ndim X 123 format('nsumrz=',i5,/,'rsumrz=',i5,/,'djordz=',i5,/, X * 'nsumli=',i5,/,'rsumli=',i5,/,'djordi=',i5,/, X * 'dimreg=',i5,/,'ndim= ',i5) X write(6,200) 'Relative perturbation in a= ', adsvd X write(6,200) 'Relative perturbation in b= ', bdsvd X write(6,200) 'Frobeniusnorm of deleted singular vaules=', X * dsvd X write(6, 100) 'kstr, step=',step X do 10 i = 1, 2 X write(6, 300) (kstr(i,j), j = 1, step) X 10 continue X 300 format(t5, 20i3) X if(idbg(1).ge.1)call cmatpr(a,lda,m,n,'Transformed matrix A') X if(idbg(1).ge.1)call cmatpr(b,ldb,m,n,'Transformed matrix B') X if (idbg(1).ge.2) call cmatpr(pp, ldpp, m, m, 'PP') X if (idbg(1).ge.2) call cmatpr(qq, ldqq, n, n, 'QQ') X cpp=cond(pp,ldpp,m,m,work) X write(6, 105) 'cond(PP)=', cpp X 105 format(t5, a, d12.6) X cqq=cond(qq,ldqq,n,n,work) X write(6, 105) 'cond(QQ)=', cqq Xc X call cmcopy(acopy, ldab, m, n, atest) X call cmcopy(bcopy, ldab, m, n, btest) X call cmatml(atest,lda,m,n,pp,ldpp,m,atest,lda,work,3) X call cmatmr(atest,lda,m,n,qq,ldqq,n,atest,lda,work,1) X if(idbg(1).ge.2) call cmatpr(atest,lda,m,n,'pp'' * a * qq') X call cmatml(btest,ldb,m,n,pp,ldpp,m,btest,ldb,work,3) X call cmatmr(btest,ldb,m,n,qq,ldqq,n,btest,ldb,work,1) X if(idbg(1).ge.2) call cmatpr(btest,ldb,m,n,'pp'' * b * qq') X difa=0 X difb=0 X do 20 i=1,m X do 30 j=1,n X difa = difa+abs(a(i,j)-atest(i,j)) X difb = difb+abs(b(i,j)-btest(i,j)) X 30 continue X 20 continue Xc X adife = cdife(a,atest,ldab,m,n) X bdife = cdife(b,btest,ldab,m,n) X anore = cnorm(a,ldab,m,n,0,work) X bnore = cnorm(b,ldab,m,n,0,work) Xc X rdifa = difa X if (anore .gt. 0.) rdifa = difa / anore X rdifb = difb X if (bnore .gt. 0.) rdifb = difb / bnore X radife = adife X if (anore .gt. 0.) radife = adife / anore X rbdife = bdife X if (bnore .gt. 0.) rbdife = bdife / bnore X maxrda = radife X maxrdb = rbdife Xc X write(6,105) 'abs(a-acopy)=',difa,'relative dif.=',rdifa X write(6,105) 'abs(b-bcopy)=',difb,'relative dif.=',rdifb X write(6,105) 'fro(a-pp" * acopy * qq)=', adife X write (6,105) 'relative fro for a-part=', radife X write (6,105) 'fro(b-pp" * bcopy * qq)=', bdife X write (6,105) 'relative fro for b-part=', rbdife Xc Xc**** compute error bounds for reducing subspaces Xc containing right singular part and eigenvalues Xc specified by ftest Xc Xc skip if right or left reducing subspace is zero or full dimensional Xc colrs = dimension of right reducing subspace Xc rowrs = dimension of left reducing subspace Xc allreg = dimension of the whole regular part 06/16/87 X colrs = nsumrz - djordz + ndim X rowrs = rsumrz - djordz + ndim X len = allreg - ndim Xc X write(6, 2000) 'colrs=', colrs, 'rowrs=', rowrs, 'len=', len X 2000 format(t5,a,i5) Xc Xc**** 6/22/87, compute workspace, stop if insufficient X call bndwsp(m,n,rowrs+1,colrs+1,len,ecase,space,info) X write(6,2000) ' bndwsp' X write(6,2000) 'ecase=',ecase,'space=',space,'info=',info X if (info.eq.1 .or. space.gt.wdim) stop Xc Xc**** 6/21/87 stop if no tests desired X if (numtst .eq. 0) stop Xc Xc deleted singular values cannot be less than epsu*(norma+normb) X dsvd = max(dsvd, epsu*( anormf + bnormf )) Xc Xc*** 06/16/87 new version of bounds Xc compute difl, difu, qnorm,pnorm, etc and eigenvalue bounds X call bound(a, b, ldab, m ,n, rowrs+1, colrs+1, len, X * evala, evalb, delmax, gvcond, pqnorm, ecase, X * pdelta, difl, difu, qnorm, pnorm, icase, X * work, ierr) Xc X write(6, 2000) ' icase= ', icase, ' ecase= ', ecase, X + ' ierr= ', ierr X write(6,203) 'delmax=',delmax,'pdelta=',pdelta,'difl=',difl, X + 'difu=',difu,'qnorm=',qnorm,'pnorm=',pnorm, X + 'pqnorm=',pqnorm,'dsvd=',dsvd Xc Xc*** 6/18/87 bounds for trivial spaces handled by bound, icase Xc pbndok = colrs .gt. 0 .and. rowrs .lt. m X pbndok = .true. Xc X if (pbndok) then Xc**** evaluate space - bounds X call evalbd( dsvd, pdelta, qnorm, pnorm, icase, m, n, X * rowrs+1, colrs+1, lbndup, rbndup, lbndlw, rbndlw) Xc X write(6,106) difl,difu,qnorm,pnorm,dsvd,pdelta,lbndup,rbndup, X + lbndlw,rbndlw,ierr X106 format(/,' results from pbound',/,' difl= ',d20.5, X + /,' difu= ',d20.5,/,' qnorm= ',d20.5,/,' pnorm= ',d20.5, X + /,' delta= ',d20.5, X + /,' pdelta=',d20.5,/,' lbndup=',d20.5,/,' rbndup=',d20.5, X + /,' lbndlw=',d20.5,/,' rbndlw=',d20.5,/,' ierr= ',i3) X endif Xc Xc**** compute error bounds for remaining eigenvalues Xc only if there are any (allreg.gt.ndim) and Xc no left (Kronecker) indices Xc ( rsumli .eq. nsumli ) Xc note: the case with no right (Kronecker) indices Xc and a regular part can be handled by transposing the Xc output from guptri (!!??) Xc note: includes perturbation theory for regular pencils Xc ( rsumli .eq. nsumli .and. rsumrz .eq. nsumrz) Xc Xc allreg = dimreg + djordz + djordi Xc len = allreg - ndim Xc*+*+ Xc ebndok = allreg .gt. ndim .and. rsumli .eq.nsumli X ebndok = len .gt. 0 Xc**** changed by demmel, 6/30/86 X if ( ebndok ) then Xc X krstrt = rsumrz - djordz + ndim + 1 X kcstrt = nsumrz - djordz + ndim + 1 X info = ierr X if (info .eq. 0) then Xc no multiple eigenvalues X write(6, 184) 'eigenvalue bounds' X 184 format(t5,a,2d23.15) X write(6, 105) 'delmax(capital delta for eigenv)= ', X * delmax X do 183 i = 1, len Xc X zat= evala(i) X zbt = evalb(i) X if (abs(zbt) .eq. 0.) then X write(6, 184) 'infinite eigenvalue' X else X write(6,184) 'eigenvalue= ', zat / zbt X endif X write(6,108) zat, zbt, gvcond(i) X 108 format(' aii=',2d13.5,' bii=',2d13.5,' k=',d13.5) X 183 continue X else Xc there are multiple eigenvalues X write(6,184) 'multiple eigenvalues' Xc 061387 changed X ebndok = .false. X do 185 i=1,len X zat=evala(i) X zbt=evalb(i) X if (abs(zbt).eq.0.) then X write(6,184) 'infinite eigenvalue' X else X write(6,184) 'eigenvalue=',zat/zbt X endif X185 continue X endif Xc X endif Xc for doing perturbation theory for eigenvalues Xc Xc***** compute GUPTRI forms for perturbed pencils Xc Xc prepare for statistics X do 8020 i = 1, 12 X do 8010 j = 1, 7 X sdstqt(j,i) = 0 X sdstqe(j,i) = 0 X 8010 continue X do 8012 j = 1, 3 X do 8011 k = 1, 10 X stateg(j,i,k) = 0 X if ( j .le. 2) stateg1(j,i,k) = 0 X 8011 continue X 8012 continue X do 8015 j = 1, 6 X statrs(j,i) = 0 X srqtup(j,i) = 0 X slqtup(j,i) = 0 X srqtlw(j,i) = 0 X slqtlw(j,i) = 0 X do 8013 k = 1, 10 X segqt(j,i,k) = 0 X segqt1(j,i,k) = 0 X 8013 continue X 8015 continue X 8020 continue Xc write(6,*) 'statrs before 7000' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) Xc X badeig = 0 X ninfo = 0 X if ( numex. gt. 0 .and. numtst .gt. 0) then X do 7000 iper = 1, numex Xc X do 6900 itst = 1, numtst Xc perturb a and b ( copies in acopy, and bcopy) Xc*+*+*+ start change 860729 X call pertb1( aorig, borig, a, b, ldab, m, n, epsbnd(iper), X * work,jobper,nostat) Xc*+*+*+ end X anormf = cnorm(a, ldab, m, n, 0, work) X bnormf = cnorm(b, ldab, m, n, 0, work) Xc**** compute the Kronecker structure Xc X X if (nostat) then X write(6, 100) 'start guptri for perturbed pair no.' X write(6, 100) 'iper= ', iper, 'itst= ', itst X endif Xc Xc**** 6/16/87 X call guptri(a ,b , ldab, m, n, epsu, gap, zero, X * ppper, ldpp, qqper, ldqq, X * adsvdp, bdsvdp, X * rtre, rtce, zrre, zrce, fnre, fnce, inre, ince, X * pstruc, struc, work, kstr, info) Xc Xc**** 6/18/87 Xc if (info.ne.0) write(6,2000) 'after guptri, info=',info X if (info.ne.0) then X ninfo = ninfo +1 X write(6,2000) 'after guptri, info=',info Xc goto next perturbed pair X goto 6900 X endif X dsvdp = sqrt ( (anormf*adsvdp)**2 + (bnormf*bdsvdp)**2 ) Xc Xc Xc**** 6/16/87 Xc compute step by searching through kstr X three = 0 X do 61689 ithree = 1, 20 X if ( three .eq. 3) go to 61690 X if( kstr(1, ithree) .eq. -1) then X three = three + 1 X endif X61689 continue Xc X if ( three .lt. 3) then X write(*,*) 'ERROR in kstr (computing step in driver)' X stop X endif Xc X61690 continue X step = ithree - 1 Xc*** end of computing step Xc Xc Xc**** 6/15/87 Xc compute these (not parameters to guptri any more) X nsumrz = zrce X rsumrz = zrre X nsumli = n - fnce X rsumli = m - fnre X djordz = zrre - rtre X djordi = inre - fnre X dimreg = fnre - zrre X ndim = 0 Xc Xc*+*+ added 06/16/87 Xc**** reorder the eigenvalues according to the user specified Xc integer function ftest Xc X allreg = dimreg + djordz + djordi X rowb = rsumrz - djordz + 1 X colb = nsumrz - djordz + 1 X rowe = rowb + allreg - 1 X cole = colb + allreg - 1 X if (ldebug) then X write(outunit, 2005) 'eigenvalues before reordering' X do 770 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 770 continue X endif X if (allreg .ge. 1) then X call reordr(a, b, ldab, m, n, rowb, colb, rowe, cole, X * ftest, ndim, rindx, ppper, ldpp, qqper, ldqq) Xc X if (idbg(2) .gt. 1) then X call cmatpr(qqper,ldqq,n,n,'qqper after reordr') X call cmatpr(ppper,ldpp,m,m,'ppper after reordr') X endif X endif Xc X if (ldebug) then X write(outunit, 2005) 'eigenvalues after reorder and' X write(outunit, 2005) 'computed eigenvalues' X do 775 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 775 continue X endif Xc Xc+*+ end add reorder* Xc X if (nostat) then X write(6, 100) 'results from guptri and reorder, iper= ', X * iper Xc Xc**** 6/15/87 X write(6,7357) 'rtce=',rtce,'zrce=',zrce,'fnce=',fnce, X + 'ince=',ince,'rtre=',rtre,'zrre=',zrre, X + 'fnre=',fnre,'inre=',inre X write (6,7355) (pstruc(j),j=1,4) X if (pstruc(4).gt.0) write (6,7356)(struc(j),j=1,pstruc(4)) Xc X write (6,123) nsumrz,rsumrz,djordz,nsumli,rsumli,djordi, X * dimreg, ndim X write(6,200) 'Relative perturbation in a= ', adsvdp X write(6,200) 'Relative perturbation in b= ', bdsvdp X write(6,200) 'Frobeniusnorm of deleted singular values=', X * dsvdp X write(6, 100) 'kstr, step=',step X do 710 i = 1, 2 X write(6, 300) (kstr(i,j), j = 1, step) X 710 continue X if (idbg(1).ge.1) X * call cmatpr(a,lda,m,n,'Transformed matrix A') X if (idbg(1).ge.1) X * call cmatpr(b,ldb,m,n,'Transformed matrix B') X if(idbg(1).ge.2) call cmatpr(ppper, ldpp, m, m, 'PPper') X if(idbg(1).ge.2) call cmatpr(qqper, ldqq, n, n, 'QQper') X cpp=cond(ppper,ldpp,m,m,work) X write(6, 105) 'cond(PPper)=', cpp X cqq=cond(qqper,ldqq,n,n,work) X write(6, 105) 'cond(QQper)=', cqq X endif Xc X call cmcopy(acopy, ldab, m, n, atest) X call cmcopy(bcopy, ldab, m, n, btest) X call cmatml(atest,lda,m,n,ppper,ldpp,m,atest,lda,work,3) X call cmatmr(atest,lda,m,n,qqper,ldqq,n,atest,lda,work,1) X if (idbg(1).ge.2) X * call cmatpr(atest,lda,m,n,'ppper'' * aper * qqper') X call cmatml(btest,ldb,m,n,ppper,ldpp,m,btest,ldb,work,3) X call cmatmr(btest,ldb,m,n,qqper,ldqq,n,btest,ldb,work,1) X if (idbg(1).ge.2) X * call cmatpr(btest,ldb,m,n,'pperp'' * bper * qqper') X difa=0 X difb=0 X do 720 i=1,m X do 730 j=1,n X difa=difa+abs(a(i,j)-atest(i,j)) X difb=difb+abs(b(i,j)-btest(i,j)) X 730 continue X 720 continue Xc X adife = cdife(a,atest,ldab,m,n) X bdife = cdife(b,btest,ldab,m,n) X anore = cnorm(a,ldab,m,n,0,work) X bnore = cnorm(b,ldab,m,n,0,work) Xc X rdifa = difa X radife = adife X if (anore .gt. 0.) then X rdifa = difa / anore X radife = adife / anore X endif X rbdife = bdife X rdifb = difb X if (bnore .gt. 0.) then X rbdife = bdife / bnore X rdifb = difb / bnore X endif Xc Xc collect maximum values of radife, rbdife X maxrda = max(maxrda, radife) X maxrdb = max(maxrdb, rbdife) Xc X if (nostat) then X write(6,105)'abs(a-acopy)=',difa,'relative dif.=',rdifa X write(6,105)'abs(b-bcopy)=',difb,'relative dif.=',rdifb X write(6,105)'fro(a-pp" * acopy * qq)=', adife X write (6,105)'relative fro for a-part=', radife X write (6,105) 'fro(b-pp" * bcopy * qq)=', bdife X write (6,105) 'relative fro for b-part=', rbdife X endif Xc Xc Xc compute the dimensions of perturbed reducing subspaces X pcolrs = nsumrz - djordz + ndim X prowrs = rsumrz - djordz + ndim Xc Xc*+*+ Xc save eigenvalues for later use X do 223 jjj=pcolrs+1,n X evalap(jjj-pcolrs)=a(jjj-pcolrs+prowrs,jjj) X evalbp(jjj-pcolrs)=b(jjj-pcolrs+prowrs,jjj) X223 continue Xc compute the distance between the matrix pairs on Xc the (nongeneric) surface Xc Xc compute a = ppper * a * qqper**H and Xc b = ppper * b * qqper**H X call cmatml(a,ldab,m,n,ppper,ldpp,m,a,ldab,work,1) X call cmatmr(a,ldab,m,n,qqper,ldqq,n,a,ldab,work,3) X call cmatml(b,ldab,m,n,ppper,ldpp,m,b,ldab,work,1) X call cmatmr(b,ldab,m,n,qqper,ldqq,n,b,ldab,work,3) X if (idbg(1) .ge. 2) then X call cmatpr(a,ldab,m,n,'final aprimprim') X call cmatpr(b,ldab,m,n,'final bprimprim') X endif Xc Xc compute dist = distance between pencils on manifold X dist = sqrt( cdife(aprim, a, ldab, m, n) ** 2 + X * cdife(bprim, b, ldab, m, n) ** 2 ) X dstqt = dist/epsbnd(iper) Xc870526 seps1 = 1.0 / sqrt(epsbnd(iper)) Xc seps2 = 1.0 / (epsbnd(iper) ** 0.75) X if (dstqt .le. 1.0) then X sdstqt(1,iper) = sdstqt(1,iper) + 1 X elseif (dstqt .le. 10.0) then X sdstqt(2,iper) = sdstqt(2,iper) + 1 X elseif (dstqt .le. 100.0) then X sdstqt(3,iper) = sdstqt(3,iper) + 1 X elseif (dstqt .le. 1000.0) then X sdstqt(4,iper) = sdstqt(4,iper) + 1 X elseif (dstqt .le. 10000.0) then X sdstqt(5,iper) = sdstqt(5,iper) + 1 X elseif (dstqt .le. 100000.0) then X sdstqt(6,iper) = sdstqt(6,iper) + 1 X else X sdstqt(7,iper) = sdstqt(7,iper) + 1 X endif Xc X if (iper .eq. 1 .and. itst .eq. 1 ) then X minqt = dstqt X avrqt = dstqt X maxqt = dstqt X else X minqt = min(minqt,dstqt) X avrqt = avrqt + dstqt X maxqt = max(maxqt,dstqt) X endif Xc Xc compute the true distance between perturbed and unperturbed Xc input pencils X dstpu = sqrt( cdife(acopy, aorig, ldab, m, n)**2 X * + cdife(bcopy, borig, ldab, m, n)**2 ) X if (dstpu.eq.0.) dstpu = 1. X dstqe = dist / dstpu X if (dstqe .le. 1.0) then X sdstqe(1,iper) = sdstqe(1,iper) + 1 X elseif (dstqe .le. 10.0) then X sdstqe(2,iper) = sdstqe(2,iper) + 1 X elseif (dstqe .le. 100.0) then X sdstqe(3,iper) = sdstqe(3,iper) + 1 X elseif (dstqe .le. 1000.0) then X sdstqe(4,iper) = sdstqe(4,iper) + 1 X elseif (dstqe .le. 10000.0) then X sdstqe(5,iper) = sdstqe(5,iper) + 1 X elseif (dstqe .le. 100000.0) then X sdstqe(6,iper) = sdstqe(6,iper) + 1 X else X sdstqe(7,iper) = sdstqe(7,iper) + 1 X endif Xc X if (iper .eq. 1 .and. itst .eq. 1 ) then X minqe = dstqe X avrqe = dstqe X maxqe = dstqe X else X minqe = min(minqe,dstqe) X avrqe = avrqe + dstqe X maxqe = max(maxqe,dstqe) X endif Xc Xcc compute distup = upper bound on dist from triangle ineq X distup = sqrt(dsvd**2 + dsvdp**2 + X + m*n*epsbnd(iper)**2/72.) X if (nostat) then X write(6, 789) 'perturbation results for iper= ',iper, X + ' itst= ', itst,' epsbnd =',epsbnd(iper) X789 format(//,t5,a,i3,a,i3,a,d15.5) X write(6, 105) 'dist =', dist, 'distup =',distup X write(6, 100) 'pcolrs =', pcolrs, 'prowrs =', prowrs X endif Xc**** compute angles between reducing subspaces of unperturbed Xc and perturbed pencils Xc X if (pcolrs .eq. colrs .and. prowrs .eq. rowrs .and. pbndok) X * then Xc Xc the perturbed reducing subspaces of same (nontrivial) Xc dimensions as unperturbed reducing subspaces X if (nostat) write(6,105) 'pdelta =', pdelta Xc*+*+ X if (dist .ge. pdelta .and. pdelta .ne. -1.) then Xc Xc perturbation theory does not work X if (nostat) then X write(6, 207) 'perturbation theory does not work ' X endif X statrs(1,iper) = statrs(1,iper) + 1 Xc write(6,*) 'Row 1' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) X else Xc compute new upper bounds on angles Xc X relerr = dist / pdelta X if (icase .eq. 1 ) then X lbdupp = atan( relerr/( pnorm - relerr * X * sqrt( pnorm**2 - 1.0))) X rbdupp = atan( relerr/( qnorm - relerr * X * sqrt( qnorm**2 - 1.0))) Xc Xc multiply pp(1:m,rowrs+1:m)**h * ppper(1:m, 1:rowrs) Xc giving a m-rowrs by rowrs matrix in work X call cmatml( ppper, ldpp, m, rowrs, pp(1, rowrs+1), X * ldpp , m-rowrs, work(1), ldpp, dum, 4) Xc Xc compute angle between left reducing subspaces X thetal = asin( cnorm(work,ldpp, m-rowrs, rowrs, 2, X * work(ldpp*ldpp+1))) Xc Xc multiply qq(1:n,colrs+1:n)**h * qqper(1:n, 1:colrs) Xc giving a n-colrs by colrs matrix in work X call cmatml( qqper, ldqq, n, colrs, qq(1, colrs+1), X * ldqq , n-colrs, work(1), ldqq, dum, 4) Xc Xc compute angle between right reducing subspaces X thetar = asin( cnorm(work,ldqq, n-colrs, colrs, 2, X * work(ldqq*ldqq+1))) Xc X elseif ( icase .eq. 2) then X lbdupp = 0. X thetal = 0. X rbdupp = atan( relerr/(1.-relerr)) Xc multiply qq(1:n,colrs+1:n)**h * qqper(1:n, 1:colrs) Xc giving a n-colrs by colrs matrix in work X call cmatml( qqper, ldqq, n, colrs, qq(1, colrs+1), X * ldqq , n-colrs, work(1), ldqq, dum, 4) Xc Xc compute angle between right reducing subspaces X thetar = asin( cnorm(work,ldqq, n-colrs, colrs, 2, X * work(ldqq*ldqq+1))) Xc X elseif (icase .eq. 3) then X rbdupp = 0. X thetar = 0. X lbdupp = atan ( relerr/(1.-relerr)) Xc multiply pp(1:m,rowrs+1:m)**h * ppper(1:m, 1:rowrs) Xc giving a m-rowrs by rowrs matrix in work X call cmatml( ppper, ldpp, m, rowrs, pp(1, rowrs+1), X * ldpp , m-rowrs, work(1), ldpp, dum, 4) Xc Xc compute angle between left reducing subspaces X thetal = asin( cnorm(work,ldpp, m-rowrs, rowrs, 2, X * work(ldpp*ldpp+1))) Xc Xc*** 6/18/87 fix, add icase=4 X elseif (icase .eq. 4) then X rbdupp = 0. X lbdupp = 0. X thetar = 0. X thetal = 0. X endif Xc Xc test perturbation theorem X if ( rbdupp .ge. thetar .and. lbdupp .ge. thetal) X * then Xc case 1 of theorem holds X if (nostat) then X write(6,207) 'case 1 of theorem holds' X endif X statrs(2,iper) = statrs(2,iper) + 1 Xc write(6,*) 'Row 2' Xc write(6,9500) ((statrs(i,j), j+1,11), 1=1,6) X rqtup = 1. X if ( thetar .ne. 0.) rqtup = rbdupp / thetar X lqtup = 1. X if ( thetal .ne. 0.) lqtup = lbdupp / thetal X if (1 . le. rqtup .and. rqtup .le. 10.0) then X srqtup(1,iper) = srqtup(1,iper) + 1 X elseif (rqtup .le. 100.0) then X srqtup(2,iper) = srqtup(2,iper) + 1 X elseif (rqtup .le. 1000.0) then X srqtup(3,iper) = srqtup(3,iper) + 1 X elseif (rqtup .le. 10000.0) then X srqtup(4,iper) = srqtup(4,iper) + 1 X elseif (rqtup .le. 100000.0) then X srqtup(5,iper) = srqtup(5,iper) + 1 X else X srqtup(6,iper) = srqtup(6,iper) + 1 X endif Xc X if( iper .eq. 1 .and. itst .eq. 1 ) then X minrup = rqtup X avrrup = rqtup X maxrup = rqtup X else X minrup = min(minrup, rqtup) X avrrup = avrrup + rqtup X maxrup = max(maxrup, rqtup) X endif Xc Xc X if (1 .le. lqtup .and. lqtup .le. 10.0) then X slqtup(1,iper) = slqtup(1,iper) + 1 X elseif (lqtup .le. 100.0) then X slqtup(2,iper) = slqtup(2,iper) + 1 X elseif (lqtup .le. 1000.0) then X slqtup(3,iper) = slqtup(3,iper) + 1 X elseif (lqtup .le. 10000.0) then X slqtup(4,iper) = slqtup(4,iper) + 1 X elseif (lqtup .le. 100000.0) then X slqtup(5,iper) = slqtup(5,iper) + 1 X else X slqtup(6,iper) = slqtup(6,iper) + 1 X endif Xc X if( iper .eq. 1 .and. itst .eq. 1 ) then X minlup = lqtup X avrlup = lqtup X maxlup = lqtup X else X minlup = min(minlup, lqtup) X avrlup = avrlup + lqtup X maxlup = max(maxlup, lqtup) X endif Xc**** 6/19/87 X elseif ((rbndlw .le. thetar .and. rbndlw.ne.-1.) X + .or. (lbndlw .le. thetal .and. lbndlw.ne.-1.)) X + then Xc case 2 of theorem holds X if (nostat) then X write(6,207)'case 2 of theorem holds' X endif X statrs(3,iper) = statrs(3,iper) + 1 Xc write(6,*) 'Row 3' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) X rqtlw = thetar / rbndlw X lqtlw = thetal / lbndlw X if (1 .le. rqtlw .and. rqtlw .le. 10.0) then X srqtlw(1,iper) = srqtlw(1,iper) + 1 X elseif (rqtlw .le. 100.0) then X srqtlw(2,iper) = srqtlw(2,iper) + 1 X elseif (rqtlw .le. 1000.0) then X srqtlw(3,iper) = srqtlw(3,iper) + 1 X elseif (rqtlw .le. 10000.0) then X srqtlw(4,iper) = srqtlw(4,iper) + 1 X elseif (rqtlw .le. 100000.0) then X srqtlw(5,iper) = srqtlw(5,iper) + 1 X else X srqtlw(6,iper) = srqtlw(6,iper) + 1 X endif Xc X if ( iper .eq. 1 .and. itst .eq. 1 ) then X minrlw = rqtlw X avrrlw = rqtlw X maxrlw = rqtlw X else X minrlw = min(minrlw, rqtlw) X avrrlw = avrrlw + rqtlw X maxrlw = max(maxrlw, rqtlw) X endif Xc X if (1 .le. lqtlw .and. lqtlw .le. 10.0) then X slqtlw(1,iper) = slqtlw(1,iper) + 1 X elseif (lqtlw .le. 100.0) then X slqtlw(2,iper) = slqtlw(2,iper) + 1 X elseif (lqtlw .le. 1000.0) then X slqtlw(3,iper) = slqtlw(3,iper) + 1 X elseif (lqtlw .le. 10000.0) then X slqtlw(4,iper) = slqtlw(4,iper) + 1 X elseif (lqtlw .le. 100000.0) then X slqtlw(5,iper) = slqtlw(5,iper) + 1 X else X slqtlw(6,iper) = slqtlw(6,iper) + 1 X endif Xc X if ( iper .eq. 1 .and. itst .eq. 1 ) then X minllw = lqtlw X avrllw = lqtlw X maxllw = lqtlw X else X minllw = min(minllw, lqtlw) X avrllw = avrrlw + lqtlw X maxllw = max(maxllw, lqtlw) X endif Xc X else Xc theorem false !!!!!!!!! ? X if (nostat) then X write(6, 207) ' theorem false !!??' X endif X statrs(4,iper) = statrs(4,iper) + 1 Xc write(6,*) 'Row 4' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) X endif X if (nostat) then X write(6,105) 'rbndlw =', rbndlw X write(6,105) 'lbndlw =', lbndlw X write(6,105) 'rbdupp =', rbdupp X write(6,105) 'lbdupp =', lbdupp X write(6, 105) 'thetar=', thetar X write(6,105) 'thetal =', thetal X endif Xc close perturbation theory applies X endif X else Xc*** this case now taken case of above Xc if (pcolrs .eq. n .and. prowrs .eq. m) then Xc if (nostat) then Xc write(6,*) ' Reducing subspaces span the', Xc * ' full space (completely controllable)' Xc endif Xc statrs(5,iper) = statrs(5,iper) + 1 Xc write(6,*) 'Row 5' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) Xc else X if (nostat) then X write(6,*) ' Different sizes of perturbed and', X * ' unperturbed reducing subspaces', X * ' colrs, rowrs = ', colrs, rowrs, X * ' pcolrs, prowrs= ', pcolrs, prowrs X endif X statrs(6,iper) = statrs(6,iper) + 1 Xc write(6,*) 'Row 6' Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) Xc endif Xc close perturbation theory X endif Xc Xc**** 6/25/87 new eigenvalue perturbation theory for multiple Xc eigenvalues X if (len.gt.0 .and. pcolrs.eq.colrs .and. prowrs.eq.rowrs X + .and. len .eq. dimreg+djordz+djordi-ndim) then X write(6,225) 'new eigenbound test for iper=', iper Xc Xc the same ebnd for all eigenvalues (see IEEE CDC paper) X ebnd = dist * pqnorm X sstrt = abdim**2 +1 X estrt = sstrt + abdim +1 X wstrt = estrt + abdim +1 X if (idbg(1).gt.1) write(6,*) 'sstrt,estrt,wstrt,len=', X + sstrt,estrt,wstrt,len X do 226 ieig = 1,len X zat = evalap(ieig) X zbt = evalbp(ieig) X scl=sqrt(abs(zat)**2 + abs(zbt)**2) X zat = zat/scl X zbt = zbt/scl X write(6,100) 'compare eigenvalues ',ieig X if (abs(evalb(ieig)).eq.0.0) then X write(6,184) 'unperturbed eigenvalue = infinity' X else X write(6,184) 'unperturbed eigenvalue = ', X + evala(ieig)/evalb(ieig) X endif X if (abs(zbt).eq.0.0) then X write(6,184) ' perturbed eigenvalue = infinity' X else X write(6,184) ' perturbed eigenvalue = ', X + zat/zbt X endif Xc compute smallest singular value of zat*breg-zbt*areg, Xc where areg - lambda breg is selected regular part of Xc unperturbed pencil X call edist(work,abdim,len,aortr(prowrs+1,pcolrs+1),abdim, X + bortr(prowrs+1,pcolrs+1),abdim,zat,zbt) X if (idbg(1).gt.1) then X call cmatpr(work,abdim,len,len,'input to svd') X call cmatpr(aortr(prowrs+1,pcolrs+1),abdim,len,len, X + 'regular part of original a') X call cmatpr(bortr(prowrs+1,pcolrs+1),abdim,len,len, X + 'regular part of original b') X endif X call zsvdc(work,abdim,len,len,work(sstrt),work(estrt), X + dummy,abdim,dummy,abdim,work(wstrt),0,info) X if (info .ne. 0) then Xc svd did not converge X write(6,*) 'nonconvergent svd of edist - info,ieig =', X + info,ieig X call cmatpr(work(sstrt),1,1,len,'singular values') X call cmatpr(work(estrt),1,1,len, X + 'superdiagonals, should be 0') X else X if (idbg(1).gt.1) then X write(6,*) 'zat=',zat X write(6,*) 'zbt=',zbt X call cmatpr(work(sstrt),1,1,len,'singular values') X call cmatpr(work(estrt),1,1,len, X + 'superdiagonals, should be 0') X endif X edif = real(work(sstrt+len-1)) Xc**** 06/26/87 collects statistics for new eigenvalue bounds Xc X if (ebnd .ge. edif) then X write(6,224) 'eigenbound holds with ebnd=',ebnd, X + ' edif=',edif X stateg1(1,iper,ieig) = stateg1(1,iper,ieig) + 1 X if ( edif .ne. 0.0 ) then X egqt = ebnd / edif X else Xc 06/27/87 Xc in theory the eigenvalues can be perturbed by dist Xc egqt = ebnd / dist = pqnorm X egqt = pqnorm X endif X if ( 1.0 .le. egqt .and. egqt .le. 10.0) then X segqt1(1,iper,ieig) = segqt1(1,iper,ieig) + 1 X elseif (egqt .le. 100.0) then X segqt1(2,iper,ieig) = segqt1(2,iper,ieig) + 1 X elseif (egqt .le. 1000.0) then X segqt1(3,iper,ieig) = segqt1(3,iper,ieig) + 1 X elseif (egqt .le. 10000.0) then X segqt1(4,iper,ieig) = segqt1(4,iper,ieig) + 1 X elseif (egqt .le. 100000.0) then X segqt1(5,iper,ieig) = segqt1(5,iper,ieig) + 1 X else X segqt1(6,iper,ieig) = segqt1(6,iper,ieig) + 1 X endif Xc X if( iper .eq. 1 .and. itst .eq. 1 ) then X minegq1(ieig) = egqt X avregq1(ieig) = egqt X maxegq1(ieig) = egqt X else X minegq1(ieig) = min(minegq1(ieig), egqt) X avregq1(ieig) = avregq1(ieig) + egqt X maxegq1(ieig) = max(maxegq1(ieig), egqt) X endif Xc X else X write(6,224) 'eigenbound false with ebnd=',ebnd, X + ' edif=',edif X stateg1(2,iper,ieig) = stateg1(2,iper,ieig) + 1 X endif Xc end of perturbation theory for eigenvalue no. ieig X endif Xc treat the next eigenvalue X 226 continue Xc end of new perturbation theory for all eigenvalues X endif Xc**** end of revision for statistics 06/26/87 Xc*+*+ Xc perturbation theory for eigenvalues Xc test eigenvalue bounds if Xc we computed them for the unperturbed pencil (ebndok) and Xc the perturbed reducing subspaces are of the same dimension Xc as the unperturbed ones Xc (pcolrs.eq.colrs.and.prowrs.eq.rowrs) and Xc the perturbed pencil has no right Kronecker indices Xc (nsumli .eq. rsumli) Xc assume the eigenvalues are in the right order for comparison Xc if (ebndok .and. pcolrs.eq.colrs .and. prowrs.eq.rowrs Xc + .and. nsumli.eq.rsumli) then Xc if number of eigenvalues outside reducing subspace both .gt. 0 Xc and the same for perturbed and unperturbed pencils X if ( dist .gt. delmax .and. delmax .ge. 0) then X badeig = badeig + 1 X write(6,105) 'eigenvalue theory does not apply' Xc NOTE: this will screw up the statistics as it is now!! X endif X if (ebndok .and. pcolrs.eq.colrs .and. prowrs.eq.rowrs X + .and. len .eq. dimreg+djordz+djordi-ndim) then X if (nostat) then X write(6,225) 'test eigenbounds for iper= ',iper X225 format(//,a,i3) X endif X do 222 ieig=1,len X zat = evalap(ieig) X zbt = evalbp(ieig) X scl=sqrt(abs(zat)**2 + abs(zbt)**2) X zat = zat/scl X zbt = zbt/scl X ebnd = dist * gvcond(ieig) X edif = abs(zat*evalb(ieig)-zbt*evala(ieig)) X if (nostat) then X write(6,100) 'compare eigenvalues ',ieig X if (abs(evalb(ieig)).eq.0.0) then X write(6,184) 'unperturbed eigenvalue = infinity' X else X write(6,184) 'unperturbed eigenvalue = ', X + evala(ieig)/evalb(ieig) X endif X if (abs(zbt).eq.0.0) then X write(6,184) ' perturbed eigenvalue = infinity' X else X write(6,184) ' perturbed eigenvalue = ', X + zat/zbt X endif Xc close if (nostat) X endif Xc X infnt = .false. X if (abs(evalb(ieig)) .eq. 0.0) infnt = .true. X infntp = .false. X if( abs(zbt) .eq. 0.0) infntp = .true. Xc 06/18/87 perturbation theory works fine with simple Xc infinite eigenvalues too Xc if (ebnd.ge.edif .and. (.not. infnt) .and. Xc * (.not. infntp)) then Xc X if (ebnd .ge. edif) then X if (nostat) then X write(6,224) 'eigenbound holds with ebnd=',ebnd, X + ' edif=',edif X224 format(t5,a,d15.5,a,d15.5) X endif X stateg(1,iper,ieig) = stateg(1,iper,ieig) + 1 X if ( edif .ne. 0.0 ) then X egqt = ebnd / edif X else Xc 06/27/87 same reason as for new bounds (see above) X egqt = gvcond(ieig) X endif X if ( 1.0 .le. egqt .and. egqt .le. 10.0) then X segqt(1,iper,ieig) = segqt(1,iper,ieig) + 1 X elseif (egqt .le. 100.0) then X segqt(2,iper,ieig) = segqt(2,iper,ieig) + 1 X elseif (egqt .le. 1000.0) then X segqt(3,iper,ieig) = segqt(3,iper,ieig) + 1 X elseif (egqt .le. 10000.0) then X segqt(4,iper,ieig) = segqt(4,iper,ieig) + 1 X elseif (egqt .le. 100000.0) then X segqt(5,iper,ieig) = segqt(5,iper,ieig) + 1 X else X segqt(6,iper,ieig) = segqt(6,iper,ieig) + 1 X endif Xc X if( iper .eq. 1 .and. itst .eq. 1 ) then X minegq(ieig) = egqt X avregq(ieig) = egqt X maxegq(ieig) = egqt X else X minegq(ieig) = min(minegq(ieig), egqt) X avregq(ieig) = avregq(ieig) + egqt X maxegq(ieig) = max(maxegq(ieig), egqt) X endif Xc X else X if (nostat) then X write(6,224) 'eigenbound false with ebnd=',ebnd, X + ' edif=',edif X endif X stateg(2,iper,ieig) = stateg(2,iper,ieig) + 1 X endif X222 continue X else Xc no perturbation theory for eigenvalues Xc we have no theory for len eigenvalues, 6/13/87 X stateg(3,iper,1) = stateg(3,iper,1) + len X endif Xc*+*+ Xc next itst (1,.. ,numtst) X 6900 continue Xc*+*+ next iper (1,..., numper) Xc collect statistics X do 6910 j = 1, 3 X do 6909 k = 1, 10 X stateg(j,11,k) = stateg(j,11,k) + stateg(j,iper,k) X if ( j .le. 2) then X stateg1(j,11,k) = stateg1(j,11,k) + stateg1(j,iper,k) X endif X 6909 continue X 6910 continue X do 6920 j = 1, 7 X sdstqe(j,11) = sdstqe(j,11) + sdstqe(j,iper) X sdstqt(j,11) = sdstqt(j,11) + sdstqt(j,iper) X 6920 continue X do 6930 j = 1, 6 X statrs(j,11) = statrs(j,11) + statrs(j,iper) X srqtup(j,11) = srqtup(j,11) + srqtup(j,iper) X slqtup(j,11) = slqtup(j,11) + slqtup(j,iper) X srqtlw(j,11) = srqtlw(j,11) + srqtlw(j,iper) X srqtlw(j,11) = srqtlw(j,11) + srqtlw(j,iper) X do 6925 k = 1, 10 X segqt(j,11,k) = segqt(j,11,k) + segqt(j,iper,k) X segqt1(j,11,k) = segqt1(j,11,k) + segqt1(j,iper,k) X 6925 continue X 6930 continue Xc Xc write(6,*) 'statrs for iper =', iper Xc write(6,9500) ((statrs(i,j), j=1,11), i=1,6) X 7000 continue Xc Xc compute procentages X do 7910 j = 1, 3 X do 7909 k = 1, 10 X stateg(j,12,k) = nint( 100. * X * float(stateg(j,11,k))/(numex * numtst)) X if ( j .le. 2) then X stateg1(j,12,k) = nint( 100. * X * float(stateg1(j,11,k))/(numex * numtst)) X endif X 7909 continue X 7910 continue X do 7920 j = 1, 7 X sdstqe(j,12) = nint( 100. * X * float(sdstqe(j,11))/(numex*numtst)) X sdstqt(j,12) = nint( 100. * X * float(sdstqt(j,11))/(numex*numtst)) X 7920 continue Xc X do 7930 j = 1, 6 X statrs(j,12) = nint( 100. * X * float(statrs(j,11))/(numex*numtst)) X if (statrs(2,11) .gt. 0) then X srqtup(j,12) = nint( 100. * X * float(srqtup(j,11))/ statrs(2,11)) X slqtup(j,12) = nint( 100. * X * float(slqtup(j,11)) / statrs(2,11)) X endif X if (statrs(3,11) .gt. 0) then X srqtlw(j,12) = nint( 100. * X * float(srqtlw(j,11)) / statrs(3,11)) X srqtlw(j,12) = nint( 100. * X * float(srqtlw(j,11)) / statrs(3,11)) X endif X do 7925 k = 1, 10 X if (stateg(1,11,k) .gt. 0)segqt(j,12,k) = nint(100.* X * float(segqt(j,11,k))/stateg(1,11,k)) X if (stateg1(1,11,k) .gt. 0)segqt1(j,12,k) = nint(100.* X * float(segqt1(j,11,k))/stateg1(1,11,k)) X 7925 continue X 7930 continue Xcc Xc print statistics Xc X write(6,*) ' Summary of statistics:' X write(6,*) ' =====================' X write(6,*) X write(6,*) ' Number of bad svds and qzs = ninfo = ', ninfo X write(6,*) ' Number of inapplicable eigenbounds = badeig = ' X * , badeig X write(6,*) X write(6,*) ' Distance between pencils on the surface' X write(6,*) ' divided by the true distance between perturbed' X write(6,*) ' and unperturbed input pencils' X write(6,9500) ((sdstqe(i,j), j= 1,12), i = 1,7) X write(6,*) ' min = ', minqe X write(6,*) ' average = ', avrqe/(numex * numtst) X write(6,*) ' max = ', maxqe Xc X write(6,*) X write(6,*) ' Distance between pencils on the surface' X write(6,*) ' divided by the size of the perturbation (epsbnd)' X write(6,9500) ((sdstqt(i,j), j= 1,12), i = 1,7) X write(6,*) ' min = ', minqt X write(6,*) ' average = ', avrqt/(numex * numtst) X write(6,*) ' max = ', maxqt Xc X write(6,*) ' Reducing subspaces:' X write(6,*) ' Different cases:' X write(6,9500) ((statrs(i,j), j = 1,12), i = 1,6) X 9500 format (t5,12i4/) Xc X write(6,*) ' Case 1: right upper bounds' X if (statrs(2,11) .gt. 0) then X avrrup = avrrup / statrs(2,11) X avrlup = avrlup / statrs(2,11) X endif X write(6,9500) ((srqtup(i,j), j = 1,12), i = 1,6) X write(6,*) ' min = ', minrup X write(6,*) ' average = ', avrrup X write(6,*) ' max = ', maxrup Xc X write(6,*) ' Case 1: left upper bounds' X write(6,9500) ((slqtup(i,j), j = 1,12), i = 1,6) X write(6,*) ' min = ', minlup X write(6,*) ' average = ', avrlup X write(6,*) ' max = ', maxlup Xc X write(6,*) ' Case 2: right lower bounds' X if (statrs(3,11) .gt. 0) then X avrrlw = avrrlw / statrs(3,11) X avrllw = avrllw / statrs(3,11) X endif X write(6,9500) ((srqtlw(i,j), j= 1,12), i = 1,6) X write(6,*) ' min = ', minrlw X write(6,*) ' average = ', avrrlw X write(6,*) ' max = ', maxrlw Xc X write(6,*) ' Case 2: left lower bounds' X write(6,9500) ((slqtlw(i,j), j= 1,12), i = 1,6) X write(6,*) ' min = ', minllw X write(6,*) ' average = ', avrllw X write(6,*) ' max = ', maxllw Xc X write(6,*) ' Eigenvalues:',' number of them=', len X if (len .gt. 0) then X write(6,*) ' Different cases (Gerschgorin type bounds):' X do 9110 k = 1, len X write(6,9505) ' Eigv. no. ', k X 9505 format(a,i3) X write(6,9500) ((stateg(i,j,k), j = 1,12), i = 1,3) X 9110 continue X write(6,*) ' Eigenvalue bounds (upper)' X do 9115 k = 1, len X write(6,9505) ' Eigv. no. ', k X write(6,9500)((segqt(i,j,k), j=1,12), i = 1,6) X write(6,*) ' min = ', minegq(k) X if (stateg(1,11,k) .gt. 0) then X avregq(k) = avregq(k) / stateg(1,11,k) X endif X write(6,*) ' average = ', avregq(k) X write(6,*) ' max = ', maxegq(k) X 9115 continue Xc Xc print outs for new statistics X write(6,*) ' Different cases( new bounds from LAA87):' X do 9210 k = 1, len X write(6,9505) ' Eigv. no. ', k X write(6,9500) ((stateg1(i,j,k), j = 1,12), i = 1,2) X 9210 continue X write(6,*) ' Eigenvalue bounds (upper)' X do 9215 k = 1, len X write(6,9505) ' Eigv. no. ', k X write(6,9500)((segqt1(i,j,k), j=1,12), i = 1,6) X write(6,*) ' min = ', minegq1(k) X if (stateg1(1,11,k) .gt. 0) then X avregq1(k) = avregq1(k) / stateg1(1,11,k) X endif X write(6,*) ' average = ', avregq1(k) X write(6,*) ' max = ', maxegq1(k) X9215 continue Xc end of prints for new statistics 06/26/87 X endif Xc X write(6,*) 'Maximum values of radife, rbdife', maxrda, maxrdb Xc end of statistics X endif X end Xc X subroutine edist(work, ldw, len, a, lda, b, ldb, c, s) Xc implicit none X integer ldw, lda, ldb, len X complex*16 work(ldw,len), a(lda,len), b(ldb,len), c,s Xc X integer i,j Xc Xc compute work = c*b - s*a Xc X do 1 i=1,len X do 2 j=1,len X work(i,j) = c*b(i,j) - s*a(i,j) X 2 continue X 1 continue X return X end END_OF_zgschurm.f if test 59481 -ne `wc -c zguptri.f <<'END_OF_zguptri.f' Xc On this file June 13, 1987: Xc guptri, upddel, cident, krnstr, norme Xc X subroutine guptri(a, b, ldab, m, n, epsu, gap, zero, X * pp, ldpp, qq, ldqq, X * adelta, bdelta, rtre, rtce, zrre, zrce, X * fnre, fnce, inre, ince, pstruc, struc, X * work, kstr, info) Xc Xc implicit none Xc**** debug space Xc the common-block declarations assume that the dimension of the Xc input matrix pencil a - lambda b is not larger than abdim. Xc the debug space is used for producing debug outputs (optional, Xc see below) Xc X integer abdim X parameter (abdim = 30) X common /debug1/ acopy(abdim,abdim),bcopy(abdim,abdim), X * atest(abdim,abdim),btest(abdim,abdim),swap X common /debug2/ idbg(20),outunit X complex*16 acopy,bcopy,atest,btest X logical swap X integer idbg, outunit Xc Xc**** formal parameter declarations X integer ldab, ldpp, ldqq, m, n X complex*16 a(ldab,*), b(ldab,*), pp(ldpp,*), qq(ldqq,*) X real*8 epsu, gap, adelta, bdelta X integer rtre, rtce, zrre, zrce, fnre, fnce, inre, ince X integer pstruc(4), struc(*), info X logical zero Xc Xc**** work space X integer kstr(4,*) X complex*16 work(*) Xc Xc*********************************************************************** Xc Xc guptri reduces the pencil a - lambda b to generalized upper Xc triangular (guptri) form via unitary equivalence transformations. Xc the guptri reduction is based on an improved version of the Xc rgqzd algortihm (a unitary version of the rgsvd algorithm). Xc for details see the papers: Xc b.kagstrom, rgsvd - an algorithm for computing the kronecker Xc structure and reducing subspaces of singular a - lambda b Xc pencils, siam j.sci.stat.comput., vol. 7, 1986, pp 185-211 Xc Xc j.demmel and b.kagstrom, stably computing the kronecker Xc structure and reducing subspaces of singular pencils Xc a - lambda b for uncertain data, in large scale eigenvalue Xc problems (cullum, willoughby eds), north holland, 1986 Xc pp 283-323. Xc Xc debug switch for guptri is idbg(2) Xc - if idbg(2) ne 0, print debug output, else no output Xc Xc on entry Xc Xc a(ldab,*) complex*16, input matrix a of order m by n Xc Xc b(ldab,*) complex*16, input matrix b of order m by n Xc Xc ldab integer, leading dimension of a and b Xc Xc m integer, current row dimension of a and b Xc Xc n integer, current column dimension of a and b Xc Xc epsu real*8, relative uncertainty in data Xc (should be at least about macheps). used by Xc subroutine rcsvdc to make rank decisions Xc Xc gap real*8, should be at least 1 and nominally Xc 1000. used by subroutine rcsvdc to make rank Xc decisions by searching for adjacent singular Xc values whose ratio exceeds gap Xc Xc zero logical, if true, zero out small singular values Xc so returned pencil really has structure described Xc in pstruc and struc (see below), else returned Xc pencil is a true equivalence transformation of Xc input pencil (no singular values are deleted) Xc Xc ldpp integer, leading dimension of pp Xc Xc ldqq integer, leading dimension of qq Xc Xc on exit Xc Xc pp(ldpp,*) complex*16, left unitary transformation matrix pp Xc of order m by m such that Xc pp**h * (a - lambda b) * qq is in guptri form Xc (described below) Xc Xc qq(ldqq,*) complex*16, right unitary transformation matrix qq Xc of order m by m such that Xc pp**h * (a - lambda b) * qq is in guptri form Xc Xc a(ldab,*) transformed matrix a (pp**H * a * qq) in Xc guptri form Xc Xc b(ldab,*) transformed matrix b (pp**H * b * qq) in Xc guptri form Xc Xc guptri (generalized upper triangular) form is described as Xc follows: on output Xc Xc ( art * * * * ) ( brt * * * * ) Xc ( 0 azr * * * ) ( 0 bzr * * * ) Xc a = ( 0 0 afn * * ), b = ( 0 0 bfn * * ) Xc ( 0 0 0 ain * ) ( 0 0 0 bin * ) Xc ( 0 0 0 0 alt ) ( 0 0 0 0 blt ) Xc Xc the diagonal blocks describe the kronecker canonical form Xc (kcf) of the pencil a - lambda b as follows: Xc Xc art - lambda brt has all right singular structure Xc azr - lambda bzr has all jordan structure for 0 eigenvalue Xc afn - lambda bfn has all jordan structure for finite Xc nonzero eigenvalues Xc ain - lambda bin has all jordan structure for infinite Xc eigenvalue Xc alt - lambda blt has all left singular structure Xc Xc any subset of these blocks may not appear in a - lambda b. Xc the dimensions of these blocks are given by the following Xc integer output parameters: Xc Xc rtre, rtce - last row and column of art, brt blocks Xc (if both are zero, no right singular Xc structure) Xc (if rtre.eq.0 and rtce.gt.0 then only l(0) Xc blocks in kcf) Xc Xc zrre, zrce - last row and column of azr, bzr blocks Xc (if zrre.eq.rtre and zrce.eq.rtce then no Xc 0 eigenvalue) Xc Xc fnre, fnce - last row and column of afn, bfn blocks Xc (if fnre.eq.zrre and fnce.eq.zrce then no Xc finite nonzero eigenvalues) Xc Xc inre, ince - last row and column of ain, bin blocks Xc (if inre.eq.fnre and ince.eq.fnce then no Xc infinite eigenvalues) Xc Xc notes: m, n are last row and column of alt, blt blocks. Xc if inre.eq.m and ince.eq.n then no left singular Xc structure. Xc if inre.lt.m and ince.eq.n then only l(0)**t blocks Xc in kcf. Xc ince-rtce = inre-rtre = dimension of regular part. Xc ince-fnce = inre-fnre = multiplicity of infinite Xc eigenvalue. Xc fnce-zrce = fnre-zrce = total multiplicity of finite Xc nonzero eigenvalues Xc zrce-rtce = zrre-rtre = multiplicity of 0 eigenvalue Xc Xc the block structure of all the blocks (except afn and bfn) Xc are described by the integer output parameters: Xc Xc pstruc(4) integer, see below Xc struc(*) integer, see below Xc Xc (for more details about the block structure of (art,brt) Xc and (azr,bzr) see the output from routine rzstr. for Xc more details about the block structure of (ain,bin) Xc and (alt,blt) see the output from routine listr.) Xc Xc struc(1 : pstruc(1)) describes the structure of art, brt Xc (if pstruc(1).eq.0 then art and brt are not present). Xc art and brt are both block upper triangular. Xc the number of column blocks are pstruc(1) of Xc dimensions struc(1) ... struc(pstruc(1)). Xc the number of row blocks are pstruc(1)-1 of Xc dimensions struc(2) ... struc(pstruc(1)). Xc if pstruc(1).eq.1 then art and brt are Xc '0 by struc(1)' representing struc(1) zero columns Xc (l(0) blocks in the kcf). Xc the number of l(j) blocks in the kcf is given by Xc struc(j+1) - struc(j+2) for Xc j.le.pstruc(1)-2 and struc(pstruc(1)) for Xc j.eq.pstruc(1)-1. Xc Xc struc(pstruc(1)+1 : pstruc(2)) describes the structure Xc of azr, bzr (if pstruc(2).eq.pstruc(1) then azr and Xc bzr are not present). Xc azr and bzr are both block upper triangular with Xc pstruc(2)-pstruc(1) column and row blocks of Xc dimensions struc(pstruc(1)+1) ... struc(pstruc(2)). Xc the number of j by j jordan blocks for the zero Xc eigenvalue in the kcf is given by Xc struc(pstruc(1)+j)-struc(pstruc(1)+j+1) for Xc j.le.pstruc(2)-pstruc(1)-1, and struc(pstruc(2)) Xc for j.eq.pstruc(2)-pstruc(1) Xc Xc afn and bfn are both upper triangular. the finite nonzero Xc eigenvalues of a - lambda b are given by the ratios Xc afn(i,i)/bfn(i,i) of the diagonal entries of afn Xc and bfn. Xc Xc struc(pstruc(2)+1 : pstruc(3)) describes the structure Xc of ain, bin (if pstruc(3).eq.pstruc(2) then ain and Xc bin are not present). Xc ain and bin are both block upper triangular with Xc pstruc(3)-pstruc(2) column and row blocks of Xc dimensions struc(pstruc(2)+1) ... struc(pstruc(3)). Xc the number of j by j jordan blocks for the infinite Xc eigenvalue in the kcf is given by Xc struc(pstruc(2)+j)-struc(pstruc(2)+j+1) for Xc j.le.pstruc(3)-pstruc(2)-1, and struc(pstruc(3)) Xc for j.eq.pstruc(3)-pstruc(2) Xc Xc struc(pstruc(3)+1 : pstruc(1)) describes the structure Xc of alt, blt (if pstruc(3).eq.pstruc(4) Xc then alt and blt are not present). Xc alt and blt are both block upper triangular. Xc the number of row blocks are pstruc(4)-pstruc(3) Xc of dimensions struc(pstruc(3)+1) ... struc(pstruc(4)). Xc the number of column blocks are pstruc(4)-pstruc(3)-1 Xc of dimensions struc(pstruc(3)+2) ... struc(pstruc(4)). Xc if pstruc(4).eq.pstruc(3)+1 then alt and blt are Xc 'struc(pstruc(4)) by 0' representing struc(pstruc(4)) Xc zero rows (l(0)**t blocks in the kcf). Xc the number of l(j)**t blocks in the kcf is given by Xc struc(pstruc(3)+j+1) - struc(pstruc(3)+j+2) for Xc j.le.pstruc(4)-pstruc(3)-2, and struc(pstruc(4)) for Xc j.eq.pstruc(4)-pstruc(3)-1. Xc Xc Xc adelta real*8, relative distance from input matrix a Xc to output a (if zero true). Xc should be no larger than about epsu Xc (otherwise pencil has ill-conditioned structure) Xc Xc bdelta real*8, relative distance from input matrix b Xc to output b (if zero true). Xc should be no larger than about epsu Xc (otherwise pencil has ill-conditioned structure) Xc Xc info - 0 if normal return Xc 1 if svd failed to converge somewhere Xc 2 if qz failed to converge Xc 3 if failed index error Xc (should never occur. if it does contact either Xc author below) Xc (if more detailed debug info needed, turn on appropriate Xc idbg flags) Xc Xc Xc***** work space Xc Xc work(*) complex*16 - 2*(max(m,n)*max(m,n)) + m*n + Xc min(m,n)*min(m,n) + 6*max(m,n) + Xc min(m,n) + 1 locations Xc Xc kstr(4,*) - integer - 4*max(m,n) + 24 locations Xc Xc*********************************************************************** Xc Xc**** this version dated june 16, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc addresses: Xc jim demmel, courant institute, new york university, Xc 215 mercer str., new york, ny 10012, usa Xc ( phone int: country code 01 -(212)998 3391) Xc ( email: demmel at nyu.edu or Xc na.demmel at score.stanford.edu ) Xc Xc bo kagstrom, institute of information processing, Xc university of umea, s-901 87 umea, sweden Xc (phone int - country code 46 - 90165419) Xc (email: bokg at seumdc51.bitnet or Xc na.kagstrom at score.stanford.edu ) Xc Xc**** guptri uses the following functions and subroutines Xc Xc kcfpack - cident, cmatml, cmatmr, cmatpr, krnstr, listr Xc norme, rzstr, updel, zqz Xc X real*8 norme Xc Xc***** internal variables Xc X logical ldebug, first X integer mnmin, mnmax, stwork, stx, stsx, stex, stq X integer starow, stbrow, stw, stqrax, sty, stqty X integer rzcase, rowb, colb, rowe, cole X integer i, j, nsingr, lastm1, kfirst, last X integer nstep, licase, nsingl X integer ierr, nlast, nsqrd, mtimn, msqrd, strtph, strtq X integer stck X integer nsumrz, rsumrz, nsumli, rsumli, djordz, djordi, dimreg X integer njordz, njordi X real*8 addlta, bddlta, epsua, epsub, anorme, bnorme X complex*16 dummy Xc Xc set debug flag X ldebug= (idbg(2).ne.0) Xc Xc**** initialize pp and qq to identity matrices X call cident(pp,ldpp,m) X call cident(qq,ldqq,n) Xc Xc** accumulate total perturbation in adelta, bdelta X adelta = 0. X bdelta = 0. Xc** compute norms and thresholds X anorme = norme(a, ldab, m, n) X bnorme = norme(b, ldab, m, n) X epsua = anorme * epsu X epsub = bnorme * epsu Xc***** allocate workspace X mnmin = min0(m,n) X mnmax = max0(m,n) X nsqrd = n * n X mtimn = m * n X stwork = 1 X stx = stwork + mnmax X stsx = stx + mtimn X stex = stsx + mnmin + 1 Xc**** 6/18/87 fix Xc stq = stex + mnmax Xc starow = stq + nsqrd X starow = stex + mnmax Xc X stbrow = starow + mnmax Xc**** 6/18/87 fix Xc stw = stbrow + mnmax Xc stqrax = stw + nsqrd X stqrax = stbrow + mnmax Xc X sty = stqrax + mnmax X stqty = sty + mnmax Xc**** 6/18/87 X stq = stqty + mnmax X stw = stq + nsqrd Xc X if (ldebug) then X write(outunit,1642) m,n,mnmin,mnmax,stwork, X * stx,stsx,stex,stq,starow,stbrow,stw,stqrax,sty,stqty X1642 format(' guptri - workspace for rzstr -', 5i5,/,1x,10i5) X endif Xc Xc**** reduction 1: Xc find and put the Jordan structure of the zero eigenvalue Xc and the right singular structure in upper left corner Xc of (a,b) Xc X if (ldebug) write(outunit,100) m,n,epsu X100 format(//'guptri - m,n,epsu=',2i3,d13.6,//,'reduction 1') X first = .true. X swap = .false. X call rzstr('cind', a, b, ldab, m, n, 1, m, 1, n, X * first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr, 1, last, addlta, X * bddlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info.ne.0) return Xc**** 6/18/87 X if (info.ne.0) then X if (ldebug) write(outunit,1030) 'after reduction 1, info=', X + info X return X endif X if (ldebug) then X write(outunit,102) last X102 format(/'kstr, last=',i3) X write(outunit,103) (j,j=1,last) X write(outunit,103) (kstr(1,j),j=1,last) X write(outunit,103) (kstr(2,j),j=1,last) X103 format(20i4) X endif Xc Xc** update total perturbation X call upddel(adelta, addlta) X call upddel(bdelta, bddlta) X if (ldebug) write(outunit,101) adelta,bdelta X101 format('accumulated perturbations in a,b = ',2d15.6) Xc Xc** convert computed null space dimensions into kronecker indices X call krnstr(m, n, kstr, 1, last, nsumrz, rsumrz, rzcase, X * nsingr, njordz, djordz) Xc Xc check for error condition X if (rzcase .eq. 7) then Xc*** 6/18/87 X if (ldebug) write(outunit,1030) X + 'after first krnstr, rzcase=',rzcase X info = 3 X return X endif Xc Xc**** reductions 2 and 3: Xc if there are both right singular blocks and jordan blocks Xc corresponding to the zero eigenvalue, reduce again to Xc separate them Xc Xc***** 6/15/87 X if (nsingr.eq.0 .and. djordz.eq.0) then Xc no right singular or zero structure X pstruc(1) = 0 X pstruc(2) = 0 X elseif (nsingr.gt.0 .and. djordz.eq.0) then Xc right structure but no zero structure X do 7352 j = 1, last X struc(j) = kstr(1,j) X 7352 continue X pstruc(1) = last X pstruc(2) = last X elseif (nsingr.eq.0 .and. djordz.gt.0) then Xc no right structure but zero structure X do 7353 j = 1, last-1 X struc(j) = kstr(1,j) X 7353 continue X pstruc(1) = 0 X pstruc(2) = last-1 Xc**** 6/15/87 Xc elseif (nsingr.gt.0 .and. njordz.gt.0) then X elseif (nsingr.gt.0 .and. djordz.gt.0) then Xc Xc**** reduction 2: Xc separate the right and zero structures Xc reduce first rsumrz rows, nsumrz columns, swapping roles Xc of a,b. insist on computing same right singular structure Xc as in reduction 1 Xc X lastm1=last-1 X nlast=last X kstr(3,last)=kstr(1,last) X kstr(4,last)=kstr(2,last) X if (kstr(3,last) .eq.0) nlast=nlast-1 X if (last.gt.1) then X do 2 j=lastm1,1,-1 X kstr(4,j)=kstr(3,j+1) X kstr(3,j)=kstr(4,j)+kstr(1,j)-kstr(2,j) X if (kstr(3,j) .eq. 0) nlast=nlast-1 X2 continue X end if Xc Xc**** 6/15/87 X pstruc(1) = nlast X do 7354 j = 1, nlast X struc(j) = kstr(3,j) X 7354 continue Xc X if (ldebug) then X write(outunit,104) rsumrz,nsumrz X104 format(/'reduction 2, rsumrz,nsumrz=',2i4/'newkst') X write(outunit,103) (j,j=1,nlast) X write(outunit,103) (kstr(3,j),j=1,nlast) X write(outunit,103) (kstr(4,j),j=1,nlast) X endif X first = .false. X swap = .true. X call rzstr('rind', b, a, ldab, m, n, 1, rsumrz, 1, nsumrz, X * first, zero, epsub, epsua, gap, X * pp, ldpp, qq, ldqq, kstr(3,1), 1, nlast, bddlta, X * addlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info.ne.0) return Xc**** 6/18/87 X if (info .ne. 0) then X if (ldebug) write(outunit,1030) X + 'after reduction 2, info=',info X return X endif Xc Xc** update total perturbation X call upddel(adelta,addlta) X call upddel(bdelta,bddlta) X if (ldebug) write(outunit,101) adelta,bdelta Xc Xc**** reduction 3: Xc recompute the block structure of the zero eigenvalue. Xc insist on computing the same jordan structure as in Xc reduction 1 Xc X if (djordz.gt.1) then X kstr(3,last)=0 X kstr(4,last)=0 X nlast=last-1 X if (last.gt.1) then X do 4 j=lastm1,1,-1 X kstr(4,j)=kstr(3,j+1)+kstr(2,j)-kstr(1,j+1) X kstr(3,j)=kstr(4,j) X if (kstr(3,j) .eq. 0) nlast=nlast-1 X4 continue X end if Xc Xc***** 6/15/87 X pstruc(2) = pstruc(1) + nlast X do 7355 j = 1, nlast X struc(pstruc(1)+j) = kstr(3,j) X 7355 continue Xc X rowb=rsumrz-djordz+1 X colb=nsumrz-djordz+1 X if (ldebug) then X write(outunit,105) rowb,colb X105 format(/'reduction 3, rowb,colb=',2i4/'newkst') X write(outunit,103) (j,j=1,nlast) X write(outunit,103) (kstr(3,j),j=1,nlast) X write(outunit,103) (kstr(4,j),j=1,nlast) X endif X first = .false. X swap = .false. Xc**** 6/18/87 bug fix, 'nlast' used to be 'last' X call rzstr('rind', a, b, ldab, m, n, rowb, rsumrz, colb, X * nsumrz, first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr(3,1), 1, nlast, addlta, X * bddlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info.ne.0) return Xc**** 6/18/87 X if (info .ne. 0 ) then X if (ldebug) write(outunit,1030) X + 'after reduction 3, info=', info X return X endif Xc Xc** update total perturbation X call upddel(adelta,addlta) X call upddel(bdelta,bddlta) X if (ldebug) write(outunit,101) adelta,bdelta X else Xc** only a single zero eigenvalue, zero out the a-part Xc X if (zero) a(rsumrz,nsumrz) = 0. Xc Xc***** 6/15/87 X pstruc(2) = pstruc(1) + 1 X struc(pstruc(2)) = 1 Xc X end if Xc Xc*** end of reductions 2 and 3 X end if Xc Xc** if reduction complete, clean up kstr Xc X if (rzcase.ne.1 .and. rzcase.ne.4) then X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 Xc X nsumli=0 X rsumli=0 Xc*+ X djordi = 0 X dimreg = 0 Xc Xc***** 6/15/87 X pstruc(3) = pstruc(2) X pstruc(4) = pstruc(3) Xc Xc+* Xc if there is a common row nullspace, update kstr X if (rzcase.eq.5 .or. rzcase.eq.6) then X last=last+1 Xc X kstr(1,last)=m-rsumrz X kstr(2,last)=0 Xc*+ X nsumli=m-rsumrz X rsumli=0 Xc Xc**** 6/15/87 X pstruc(4) = pstruc(3) + 1 X struc(pstruc(4)) = nsumli Xc Xc+* X end if X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 X else Xc Xc if no right or zero structure, fix kstr X if (last.eq.1 .and. kstr(1,1).eq.0) last=0 Xc put -1s at end of right, zero part of kstr X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 Xc Xc**** reduce the rest of the pencil Xc Xc** allocate workspace for listr Xc X msqrd = m*m Xc**** 6/18/87 Xc starow = stq + msqrd Xc stqrax = stw + msqrd X stw = stq + msqrd Xc Xc Xc**** reduction 4: Xc find and put the jordan structure of the infinite Xc eigenvalue and the left singular structure in Xc lower right corner of (a,b) Xc X kfirst=last+1 X if (ldebug) write(outunit,107) kfirst X107 format(/'reduction 4, kfirst=',i4) X rowb = rsumrz + 1 X colb = nsumrz + 1 X first = .false. X swap = .false. X call listr('cind', a, b, ldab, m, n, rowb, m, colb, n, X * first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr, kfirst, nstep, addlta, X * bddlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info.ne.0) return Xc**** 6/18/87 X if (info .ne. 0) then X if (ldebug) write(outunit,1030) X + 'after reduction 4, info=',info X return X endif Xc X last=nstep+kfirst-1 X if (ldebug) then X write(outunit,103) (j,j=1,last) X write(outunit,103) (kstr(1,j),j=1,last) X write(outunit,103) (kstr(2,j),j=1,last) X endif Xc Xc** update total perturbation X call upddel(adelta, addlta) X call upddel(bdelta, bddlta) X if (ldebug) write(outunit,101) adelta,bdelta Xc Xc** convert computed null space dimensions into kronecker indices X call krnstr(n-nsumrz, m-rsumrz, kstr, kfirst, last, X * nsumli, rsumli, licase, nsingl, njordi, djordi) Xc X if (licase.eq.5 .or. licase.eq.6 .or. licase.eq.7) then Xc error condition - this should not happen because it would Xc mean there was right singular structure in this part X if (ldebug) write(outunit,108) licase X108 format(//'error condition, licase=',i4) X info = 3 X return X end if Xc Xc**** reductions 5 and 6: Xc if there are both left singular blocks and jordan blocks Xc corresponding to the infinite eigenvalue, reduce again Xc to separate them Xc Xc***** 6/15/87 X if (nsingl.eq.0 .and. djordi.eq.0) then Xc no left or infinity structure X pstruc(3) = pstruc(2) X pstruc(4) = pstruc(3) X elseif (nsingl.gt.0 .and. djordi.eq.0) then Xc left but no infinity structure X pstruc(3) = pstruc(2) X do 7356 j = kfirst, last X struc(pstruc(3)+j-kfirst+1) = kstr(1,j) X 7356 continue X pstruc(4) = pstruc(3) + last-kfirst+1 X elseif (nsingl.eq.0 .and. djordi.gt.0) then Xc no left but infinity structure X do 7357 j = kfirst, last-1 X struc(pstruc(2)+j-kfirst+1) = kstr(1,j) X 7357 continue X pstruc(3) = pstruc(2)+last-kfirst X pstruc(4) = pstruc(3) X elseif (nsingl.gt.0 .and. djordi.gt.0) then Xc Xc**** reduction 5: Xc separate the left and infinite structures. Xc reduce last rsumli columns and nsumli rows, swapping Xc roles of a,b. insist on computing same left singular Xc structure as in reduction 4 Xc X lastm1=last-1 X kstr(3,last)=kstr(1,last) X kstr(4,last)=kstr(2,last) X nlast=last X if (kstr(3,last) .eq. 0) nlast=nlast-1 X if (last.gt.kfirst) then X do 6 j=lastm1,kfirst,-1 X kstr(4,j)=kstr(3,j+1) X kstr(3,j)=kstr(4,j)+kstr(1,j)-kstr(2,j) X if (kstr(3,j) .eq. 0) nlast=nlast-1 X6 continue X end if Xc Xc***** 6/15/87 Xc temporarily put left structure in struc before infinity X pstruc(3) = pstruc(2) + nlast-kfirst+1 X do 7358 j = kfirst, nlast X struc(pstruc(2)+j-kfirst+1) = kstr(3,j) X 7358 continue Xc X rowb = m-nsumli+1 X colb = n-rsumli+1 X if (ldebug) then X write(outunit,109) rowb,colb X109 format(/'reduction 5, rowb,colb=',2i4/'newkst') X write(outunit,103) (j,j=1,nlast) X write(outunit,103) (kstr(3,j),j=1,nlast) X write(outunit,103) (kstr(4,j),j=1,nlast) X endif X nstep = nlast-kfirst+1 X first = .false. X swap = .true. X call listr('rind', b, a, ldab, m, n, rowb, m, colb, n, X * first, zero, epsub, epsua, gap, X * pp, ldpp, qq, ldqq, kstr(3,1), kfirst, X * nstep, bddlta, addlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info .ne. 0) return Xc**** 6/18/87 X if (info .ne. 0 ) then X if (ldebug) write(outunit,1030) X + 'after reduction 5, info=',info X return X endif Xc Xc** update total perturbation X call upddel(adelta, addlta) X call upddel(bdelta, bddlta) X if (ldebug) write(outunit,101) adelta,bdelta Xc Xc**** reduction 6: Xc recompute the block structure of the infinite eigenvalue. Xc insist on computing the same jordan structure as Xc in reduction 4. Xc X if (djordi.gt.1) then X kstr(3,last)=0 X kstr(4,last)=0 X nlast=last-1 X if (last.gt.kfirst) then X do 8 j=lastm1,kfirst,-1 Xc*+ Xc kstr(4,j)=kstr(3,j+1)+kstr(2,j)-kstr(1,j) X kstr(4,j)=kstr(3,j+1)+kstr(2,j)-kstr(1,j+1) Xc X kstr(3,j)=kstr(4,j) X if (kstr(3,j) .eq. 0) nlast=nlast-1 X8 continue X end if Xc Xc***** 6/15/87 Xc move left structure right nlast-kfirst+1 places X do 7359 j = pstruc(3),pstruc(2)+1,-1 X struc(j+nlast-kfirst+1) = struc(j) X 7359 continue X pstruc(4) = pstruc(3) + nlast - kfirst +1 X pstruc(3) = pstruc(2) + nlast - kfirst +1 X do 7360 j = kfirst, nlast X struc(j+pstruc(2)-kfirst+1) = kstr(3,j) X 7360 continue Xc X rowb = m-nsumli+1 X rowe = rowb+djordi-1 X colb = n-rsumli+1 X cole = colb+djordi-1 X if (ldebug) then X write(outunit,111) rowb,colb,rowe,cole X111 format(/'reduction 6, rowb,colb,rowe,cole=', X + 4i4/'newkst') X write(outunit,103) (j,j=1,nlast) X write(outunit,103) (kstr(3,j),j=1,nlast) X write(outunit,103) (kstr(4,j),j=1,nlast) X endif X nstep = nlast-kfirst+1 X first = .false. X swap = .false. X call listr('rind', a, b, ldab, m, n, rowb, rowe, colb, X * cole, first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr(3,1), kfirst, X * nstep, addlta, bddlta, X * work(stwork), work(stx), work(stsx), work(stex), X * work(stq), work(starow), work(stbrow), work(stw), X * work(stqrax), work(sty), work(stqty), info) Xc if (info .ne. 0) return Xc**** 6/18/87 X if (info .ne. 0) then X if (ldebug) write (outunit,1030) X + 'after reduction 6, info=',info X return X endif Xc Xc** update total perturbation X call upddel(adelta,addlta) X call upddel(bdelta,bddlta) X if (ldebug) write(outunit,101) adelta,bdelta Xc X else Xc** only single infinite eigenvalue, zero out the b-part X if (zero) b(m-nsumli+1, n-rsumli+1) = 0. Xc Xc***** 6/15/87 Xc move struc left one place X do 7361 j = pstruc(3),pstruc(2)+1,-1 X struc(j+1) = struc(j) X 7361 continue X pstruc(4) = pstruc(3) +1 X pstruc(3) = pstruc(2) +1 X struc(pstruc(3)) = 1 Xc X end if Xc Xc*** end of reductions 5 and 6 X end if Xc Xc*** change adelta and bdelta to relative perturbations X if (anorme .ne. 0.) adelta = adelta / anorme Xc otherwise both anorme and adelta are 0. X if (bnorme .ne. 0.) bdelta = bdelta / bnorme Xc otherwise both bnorme and bdelta are 0. Xc Xc*** clean up kstr Xc if there are no left or infinite indices, shorten kstr X if (kfirst.eq.last .and. kstr(1,last).eq.0) last=last-1 Xc X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 Xc if there is a regular part with nonzero, noninfinite entries, Xc update kstr X dimreg=0 X if (licase.eq.1 .or. licase.eq.4) then Xc Xc*+ X last=last+1 Xc X kstr(1,last)=m-rsumrz-nsumli X kstr(2,last)=n-nsumrz-rsumli X dimreg=kstr(1,last) X end if X last=last+1 X kstr(1,last)=-1 X kstr(2,last)=-1 Xc X end if Xc Xc**** 6/15/87 Xc compute output indices X rtre = rsumrz - djordz X rtce = nsumrz - djordz X zrre = rsumrz X zrce = nsumrz X fnre = zrre + dimreg X fnce = zrce + dimreg X inre = fnre + djordi X ince = fnce + djordi Xc X if (ldebug) then X write(outunit,112) X112 format(//'final kstr=') X write(outunit,103) (j,j=1,last) X write(outunit,103) (kstr(1,j),j=1,last) X write(outunit,103) (kstr(2,j),j=1,last) X write(outunit, 1030) 'nsumrz= ',nsumrz, 'rsumrz=',rsumrz, X * 'djordz=', djordz,'nsumli= ', nsumli, 'rsumli=',rsumli, X * 'djordi=', djordi, 'dimreg=', dimreg X 1030 format(t5,a,i5) Xc Xc**** 6/15/87 X write(outunit,1031) (pstruc(j),j=1,4) X 1031 format(//'final pstruc= ',4i4,/,'final struc =') X if (pstruc(4).gt.0) write(outunit,1032) X + (struc(j),j=1,pstruc(4)) X 1032 format(15i4) X write(outunit,1033) 'rtce=',rtce,'zrce=',zrce,'fnce=',fnce, X + 'ince=',ince,'rtre=',rtre,'zrre=',zrre, X + 'fnre=',fnre,'inre=',inre X 1033 format(4(3x,a,i4),/,4(3x,a,i4)) Xc X endif Xc Xc**** reduction 7: Xc reduce remaining regular part (corresponding to Xc the nonzero and finite eigenvalues) to upper Xc triangular form by using the qz algorithm Xc X if (dimreg .gt. 1) then Xc rowb = first row of remaining regular part Xc colb = first column of remaining regular part Xc X rowb = rsumrz + 1 X colb = nsumrz +1 Xc Xc**** reduce the pencil a(rowb:rowb+dimreg-1,colb:colb+dimreg-1) Xc - lambda b(rowb:rowb+dimreg-1,colb:colb+dimreg-1) Xc to upper triangular form with the qz algorithm Xc Xc** allocate workspace for transformation matrices phtemp and qtemp X strtq = 1 X strtph = strtq + dimreg * dimreg X stck = strtph + dimreg * dimreg X call zqz(a, b, ldab, dimreg, rowb, colb, work(strtq), X * dimreg, work(strtph), dimreg, ierr, work(stck)) X if (ierr .ne. 0) then Xc**** 6/18/87 X if (ldebug) write (outunit,1030) 'after qz, ierr=',ierr X info = 2 X return X endif Xc** update rows 1 to rowb-1 above the remaining regular part Xc in columns colb to colb+dimreg-1 Xc by postmultiplying with qtemp (dimreg*dimreg) Xc X call cmatmr( a( 1, colb), ldab, rowb-1, dimreg, X * work(strtq), dimreg, dimreg, dummy, 1, X * work(stck), 1) X call cmatmr( b( 1, colb), ldab, rowb-1, dimreg, X * work(strtq), dimreg, dimreg, dummy, 1, X * work(stck), 1) Xc Xc** update (rows 1 to n in) columns colb to colb+dimreg-1 Xc of qq by postmultiplying with qtemp Xc X call cmatmr( qq( 1, colb), ldab, n, dimreg, X * work(strtq), dimreg, dimreg, dummy, 1, X * work(stck), 1) Xc Xc** update columns colb+dimreg to n to the right of the remaining Xc regular part in rows rowb to rowb+dimreg-1 Xc by premultiplying by phtemp (dimreg*dimreg) Xc X call cmatml( a( rowb, colb+dimreg), ldab, dimreg, X * n-colb-dimreg+1, work(strtph), X * dimreg, dimreg, dummy, 1, work(stck), 1) Xc X call cmatml( b( rowb, colb+dimreg), ldab, dimreg, X * n-colb-dimreg+1, work(strtph), X * dimreg, dimreg, dummy, 1, work(stck), 1) Xc Xc** update (rows 1 to m in) columns rowb to rowb+dimreg-1 Xc of pp by postmultiplying with phtemp**h Xc X call cmatmr( pp( 1, rowb), ldpp, m, dimreg, X * work(strtph), dimreg, dimreg, dummy, 1, X * work(stck), 3) X endif Xc X if (idbg(2) .gt. 1) then X call cmatpr(qq,ldqq,n,n,'qq at exit from guptri') X call cmatpr(pp,ldpp,m,m,'pp at exit from guptri') X endif Xc Xc X if (ldebug) then X write(outunit, 2005) 'computed eigenvalues' X 2005 format( t5, a, 4d15.5) Xc**** 6/19/87 X rowb = rtre+1 X rowe = inre X colb = rtce+1 X cole = ince Xc X do 75 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 75 continue X endif Xc Xc*** end of reduction 7 X return X end Xc**** last line of guptri Xc X subroutine upddel(total,xinc) Xc implicit none Xc Xc**** formal parameter declarations X real*8 total, xinc Xc Xc**** accumulate root sum of squares in total with increment xinc Xc assume both arguments nonnegative Xc Xc**** this version dated june 16, 1987 Xc authors: jim demmel and bo kagstrom Xc X if (total.gt.xinc) then X total = total * sqrt(1.0 + (xinc/total)**2) X elseif (total.lt.xinc) then X total = xinc * sqrt(1.0 + (total/xinc)**2) X else X total = total * sqrt(2.0) X endif X return X end Xc X subroutine cident(c,ldc,n) Xc implicit none Xc Xc**** formal parameter declarations X integer ldc, n X complex*16 c(ldc,n) Xc Xc**** set c = n by n indentity matrix Xc Xc**** this version dated june 16, 1987 Xc Xc**** internal variables X integer i, j Xc X do 1 j=1,n X do 2 i=1,n X c(i,j)=0 X2 continue X c(j,j)=1 X1 continue X return X end Xc X subroutine krnstr(m,n,kstr,kfirst,last,nisum,risum,case, X * nmsing,nmjord,dmjord) Xc implicit none Xc Xc**** debug space X common /debug2/ idbg(20),outunit X integer idbg, outunit Xc Xc**** formal parameter declarations X integer m,n, kstr(4,*), kfirst, last, nisum, risum X integer case, nmsing, nmjord, dmjord Xc Xc**** interpret null space dimensions as kronecker indices Xc there are 7 cases (for details see the code below) Xc Xc**** this version dated june 16, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** internal variables X integer j, lastm1, ni, ri, nnew, rnew X logical ldebug Xc Xc set debug flag X ldebug= (idbg(3).ne.0) Xc**** Xc in cases 2,3,6 below, adjoin column to kstr so Xc kstr(2,last)=0 in all cases X if (kstr(1,last).eq.0) kstr(2,last)=0 X nisum=0 X risum=0 X if (last.ge.kfirst) then X do 1 j=kfirst,last X nisum=nisum+kstr(1,j) X risum=risum+kstr(2,j) X1 continue X end if X nnew=n-nisum X rnew=m-risum Xc X ni=kstr(1,last) X ri=kstr(2,last) X if (ldebug) write(outunit,100) n,m,kfirst,last,nisum,risum, X * nnew,rnew,ni,ri X100 format(//'entering krnstr',/ X * 'n,m,kfirst,last,nisum,risum,nnew,rnew,ni,ri=',10i3) X if (ldebug) write(outunit,101) (j,j=1,last) X101 format('kstr='/20i4) X if (ldebug) write(outunit,102) (kstr(1,j),j=1,last) X if (ldebug) write(outunit,102) (kstr(2,j),j=1,last) X102 format(20i4) Xc X if (ni.eq.0 .and. nnew.gt.0 .and. rnew.gt.0) then Xc**** case 1 Xc rest of pencil begins at (risum+1,nisum+1) X case=1 X else if (ri.gt.0 .and. nnew.eq.0 .and. rnew.eq.0) then Xc**** case 2 Xc entire pencil reduced; no indices or eigenvalues of other type X case=2 X last=last+1 X kstr(1,last)=0 X kstr(2,last)=0 X ni=0 X ri=0 X else if (ri.gt.0 .and. nnew.gt.0 .and. rnew.eq.0) then Xc**** case 3 Xc entire pencil reduced; no indices or eigenvalues of other type X case=3 X last=last+1 X kstr(1,last)=nnew X kstr(2,last)=0 X ni=nnew X ri=0 X nisum=nisum+nnew X nnew=0 X else if (ni.gt.0 .and. ri.eq.0 .and. rnew.gt.0 .and. nnew.gt.0) X * then Xc**** case 4 Xc rest of pencil begins at (risum+1,nisum+1) X case=4 X else if (ni.gt.0 .and. ri.eq.0 .and. nnew.eq.0 .and. rnew.gt.0) X * then Xc**** case 5 Xc entire pencil reduced; last rnew rows are 0 Xc (i.e. there are rnew zero indices of other type) X case=5 X else if (ni.gt.0 .and. ri.gt.0 .and. nnew.eq.0 .and. rnew.gt.0) X * then Xc**** case 6 Xc entire pencil reduced; last rnew rows are 0 Xc (i.e. there are rnew zero indices of other kind) X case=6 X last=last+1 X kstr(1,last)=0 X kstr(2,last)=0 X ni=0 X ri=0 X else Xc**** cannot happen, error state, print error message X if (ldebug) write(outunit,105) X105 format(//'error condition') X case=7 X end if Xc X if (ldebug) then X write(outunit,107) case,n,m,kfirst,last,nisum,risum,nnew, X + rnew,ni,ri X107 format(/' case,n,m,kfirst,last,nisum,risum,nnew,rnew,ni,ri=', X + /,11i4) X write(outunit,101) (j,j=1,last) X write(outunit,102) (kstr(1,j),j=1,last) X write(outunit,102) (kstr(2,j),j=1,last) X endif Xc compute number of singular blocks X nmsing=nisum-risum Xc Xc compute number of jordan blocks X nmjord=-nmsing+kstr(1,kfirst) Xc Xc compute dimension of jordan blocks X dmjord=0 X if (last.gt.kfirst) then X lastm1=last-1 X do 3 j=kfirst,lastm1 X dmjord=dmjord+(j-kfirst+1)*(kstr(2,j)-kstr(1,j+1)) X3 continue X end if X if (ldebug) then X write(outunit,106) case,nmsing,nmjord,dmjord X106 format(/'case,nmsing,nmjord,dmjord=',4i4) X write(outunit,101) (j,j=1,last) X write(outunit,102) (kstr(1,j),j=1,last) X write(outunit,102) (kstr(2,j),j=1,last) X endif Xc X return X end Xc X real*8 function norme(a, ldab, m, n) Xc implicit none Xc**** formal parameter declarations X integer ldab, m, n X complex*16 a(ldab,*) Xc**** compute frobenius norm of matrix a Xc X real*8 sum X integer i, j Xc X sum = 0. X do 1 i = 1, m X do 2 j = 1, n X sum = sum + dreal(a(i,j))**2 + dimag(a(i,j))**2 X2 continue X1 continue X norme = sqrt(sum) X return X end END_OF_zguptri.f if test 42915 -ne `wc -c zlinpack.f <<'END_OF_zlinpack.f' Xc In this file June 7, 1987:Linpack routines - zsvdc, zqrdc, zqrsl Xc X subroutine zsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) X integer ldx,n,p,ldu,ldv,job,info X complex*16 x(ldx,p),s(p),e(p),u(ldu,n),v(ldv,p),work(n) Xc Xc Xc zsvdc is a subroutine to reduce a complex*16 nxp matrix x by Xc unitary transformations u and v to diagonal form. the Xc diagonal elements s(i) are the singular values of x. the Xc columns of u are the corresponding left singular vectors, Xc and the columns of v the right singular vectors. Xc Xc on entry Xc Xc x complex*16(ldx,p), where ldx.ge.n. Xc x contains the matrix whose singular value Xc decomposition is to be computed. x is Xc destroyed by zsvdc. Xc Xc ldx integer. Xc ldx is the leading dimension of the array x. Xc Xc n integer. Xc n is the number of columns of the matrix x. Xc Xc p integer. Xc p is the number of rows of the matrix x. Xc Xc ldu integer. Xc ldu is the leading dimension of the array u Xc (see below). Xc Xc ldv integer. Xc ldv is the leading dimension of the array v Xc (see below). Xc Xc work complex*16(n). Xc work is a scratch array. Xc Xc job integer. Xc job controls the computation of the singular Xc vectors. it has the decimal expansion ab Xc with the following meaning Xc Xc a.eq.0 do not compute the left singular Xc vectors. Xc a.eq.1 return the n left singular vectors Xc in u. Xc a.ge.2 returns the first min(n,p) Xc left singular vectors in u. Xc b.eq.0 do not compute the right singular Xc vectors. Xc b.eq.1 return the right singular vectors Xc in v. Xc Xc on return Xc Xc s complex*16(mm), where mm=min(n+1,p). Xc the first min(n,p) entries of s contain the Xc singular values of x arranged in descending Xc order of magnitude. Xc Xc e complex*16(p). Xc e ordinarily contains zeros. however see the Xc discussion of info for exceptions. Xc Xc u complex*16(ldu,k), where ldu.ge.n. if joba.eq.1 Xc then k.eq.n, if joba.ge.2 then Xc Xc k.eq.min(n,p). Xc u contains the matrix of right singular vectors. Xc u is not referenced if joba.eq.0. if n.le.p Xc or if joba.gt.2, then u may be identified with x Xc in the subroutine call. Xc Xc v complex*16(ldv,p), where ldv.ge.p. Xc v contains the matrix of right singular vectors. Xc v is not referenced if jobb.eq.0. if p.le.n, Xc then v may be identified whth x in the Xc subroutine call. Xc Xc info integer. Xc the singular values (and their corresponding Xc singular vectors) s(info+1),s(info+2),...,s(m) Xc are correct (here m=min(n,p)). thus if Xc info.eq.0, all the singular values and their Xc vectors are correct. in any event, the matrix Xc b = ctrans(u)*x*v is the bidiagonal matrix Xc with the elements of s on its diagonal and the Xc elements of e on its super-diagonal (ctrans(u) Xc is the conjugate-transpose of u). thus the Xc singular values of x and b are the same. Xc Xc linpack. this version dated 03/19/79 . Xc correction to shift calculation made 2/85. Xc g.w. stewart, university of maryland, argonne national lab. Xc Xc zsvdc uses the following functions and subprograms. Xc Xc external zdrot Xc blas zaxpy,zdotc,zscal,zswap,dznrm2,drotg Xc fortran dabs,dmax1,cdabs,dcmplx Xc fortran dconjg,max0,min0,mod,dsqrt Xc Xc internal variables Xc X integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, X * mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1 X complex*16 zdotc,t,r X double precision b,c,cs,el,emm1,f,g,dznrm2,scale,shift,sl,sm,sn, X * smm1,t1,test,ztest X logical wantu,wantv Xc X complex*16 csign,zdum,zdum1,zdum2 X double precision cabs1 X double precision dreal,dimag X complex*16 zdumr,zdumi X dreal(zdumr) = zdumr X dimag(zdumi) = (0.0d0,-1.0d0)*zdumi X cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) X csign(zdum1,zdum2) = cdabs(zdum1)*(zdum2/cdabs(zdum2)) Xc Xc set the maximum number of iterations. Xc Xc**** 6/21/87 Xc maxit = 30 X maxit = 100 Xc Xc determine what is to be computed. Xc X wantu = .false. X wantv = .false. X jobu = mod(job,100)/10 X ncu = n X if (jobu .gt. 1) ncu = min0(n,p) X if (jobu .ne. 0) wantu = .true. X if (mod(job,10) .ne. 0) wantv = .true. Xc Xc reduce x to bidiagonal form, storing the diagonal elements Xc in s and the super-diagonal elements in e. Xc X info = 0 X nct = min0(n-1,p) X nrt = max0(0,min0(p-2,n)) X lu = max0(nct,nrt) X if (lu .lt. 1) go to 170 X do 160 l = 1, lu X lp1 = l + 1 X if (l .gt. nct) go to 20 Xc Xc compute the transformation for the l-th column and Xc place the l-th diagonal in s(l). Xc X s(l) = dcmplx(dznrm2(n-l+1,x(l,l),1),0.0d0) X if (cabs1(s(l)) .eq. 0.0d0) go to 10 X if (cabs1(x(l,l)) .ne. 0.0d0) s(l) = csign(s(l),x(l,l)) X call zscal(n-l+1,1.0d0/s(l),x(l,l),1) X x(l,l) = (1.0d0,0.0d0) + x(l,l) X 10 continue X s(l) = -s(l) X 20 continue X if (p .lt. lp1) go to 50 X do 40 j = lp1, p X if (l .gt. nct) go to 30 X if (cabs1(s(l)) .eq. 0.0d0) go to 30 Xc Xc apply the transformation. Xc X t = -zdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) X call zaxpy(n-l+1,t,x(l,l),1,x(l,j),1) X 30 continue Xc Xc place the l-th row of x into e for the Xc subsequent calculation of the row transformation. Xc X e(j) = dconjg(x(l,j)) X 40 continue X 50 continue X if (.not.wantu .or. l .gt. nct) go to 70 Xc Xc place the transformation in u for subsequent back Xc multiplication. Xc X do 60 i = l, n X u(i,l) = x(i,l) X 60 continue X 70 continue X if (l .gt. nrt) go to 150 Xc Xc compute the l-th row transformation and place the Xc l-th super-diagonal in e(l). Xc X e(l) = dcmplx(dznrm2(p-l,e(lp1),1),0.0d0) X if (cabs1(e(l)) .eq. 0.0d0) go to 80 X if (cabs1(e(lp1)) .ne. 0.0d0) e(l) = csign(e(l),e(lp1)) X call zscal(p-l,1.0d0/e(l),e(lp1),1) X e(lp1) = (1.0d0,0.0d0) + e(lp1) X 80 continue X e(l) = -dconjg(e(l)) X if (lp1 .gt. n .or. cabs1(e(l)) .eq. 0.0d0) go to 120 Xc Xc apply the transformation. Xc X do 90 i = lp1, n X work(i) = (0.0d0,0.0d0) X 90 continue X do 100 j = lp1, p X call zaxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) X 100 continue X do 110 j = lp1, p X call zaxpy(n-l,dconjg(-e(j)/e(lp1)),work(lp1),1, X * x(lp1,j),1) X 110 continue X 120 continue X if (.not.wantv) go to 140 Xc Xc place the transformation in v for subsequent Xc back multiplication. Xc X do 130 i = lp1, p X v(i,l) = e(i) X 130 continue X 140 continue X 150 continue X 160 continue X 170 continue Xc Xc set up the final bidiagonal matrix or order m. Xc X m = min0(p,n+1) X nctp1 = nct + 1 X nrtp1 = nrt + 1 X if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) X if (n .lt. m) s(m) = (0.0d0,0.0d0) X if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) X e(m) = (0.0d0,0.0d0) Xc Xc if required, generate u. Xc X if (.not.wantu) go to 300 X if (ncu .lt. nctp1) go to 200 X do 190 j = nctp1, ncu X do 180 i = 1, n X u(i,j) = (0.0d0,0.0d0) X 180 continue X u(j,j) = (1.0d0,0.0d0) X 190 continue X 200 continue X if (nct .lt. 1) go to 290 X do 280 ll = 1, nct X l = nct - ll + 1 X if (cabs1(s(l)) .eq. 0.0d0) go to 250 X lp1 = l + 1 X if (ncu .lt. lp1) go to 220 X do 210 j = lp1, ncu X t = -zdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) X call zaxpy(n-l+1,t,u(l,l),1,u(l,j),1) X 210 continue X 220 continue X call zscal(n-l+1,(-1.0d0,0.0d0),u(l,l),1) X u(l,l) = (1.0d0,0.0d0) + u(l,l) X lm1 = l - 1 X if (lm1 .lt. 1) go to 240 X do 230 i = 1, lm1 X u(i,l) = (0.0d0,0.0d0) X 230 continue X 240 continue X go to 270 X 250 continue X do 260 i = 1, n X u(i,l) = (0.0d0,0.0d0) X 260 continue X u(l,l) = (1.0d0,0.0d0) X 270 continue X 280 continue X 290 continue X 300 continue Xc Xc if it is required, generate v. Xc X if (.not.wantv) go to 350 X do 340 ll = 1, p X l = p - ll + 1 X lp1 = l + 1 X if (l .gt. nrt) go to 320 X if (cabs1(e(l)) .eq. 0.0d0) go to 320 X do 310 j = lp1, p X t = -zdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) X call zaxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) X 310 continue X 320 continue X do 330 i = 1, p X v(i,l) = (0.0d0,0.0d0) X 330 continue X v(l,l) = (1.0d0,0.0d0) X 340 continue X 350 continue Xc Xc transform s and e so that they are double precision. Xc X do 380 i = 1, m X if (cabs1(s(i)) .eq. 0.0d0) go to 360 X t = dcmplx(cdabs(s(i)),0.0d0) X r = s(i)/t X s(i) = t X if (i .lt. m) e(i) = e(i)/r X if (wantu) call zscal(n,r,u(1,i),1) X 360 continue Xc ...exit X if (i .eq. m) go to 390 X if (cabs1(e(i)) .eq. 0.0d0) go to 370 X t = dcmplx(cdabs(e(i)),0.0d0) X r = t/e(i) X e(i) = t X s(i+1) = s(i+1)*r X if (wantv) call zscal(p,r,v(1,i+1),1) X 370 continue X 380 continue X 390 continue Xc Xc main iteration loop for the singular values. Xc X mm = m X iter = 0 Xc**** 6/23/87 added code to ensure convergence Xc compute norm of matrix X test = abs(s(m)) X do 975 i=1,m-1 X test = test + abs(s(i)) + abs(e(i)) X975 continue X test = test * m * 100. Xc**** X 400 continue Xc Xc quit if all the singular values have been found. Xc Xc ...exit X if (m .eq. 0) go to 660 Xc Xc if too many iterations have been performed, set Xc flag and return. Xc X if (iter .lt. maxit) go to 410 X info = m Xc ......exit X go to 660 X 410 continue Xc Xc this section of the program inspects for Xc negligible elements in the s and e arrays. on Xc completion the variables kase and l are set as follows. Xc Xc kase = 1 if s(m) and e(l-1) are negligible and l.lt.m Xc kase = 2 if s(l) is negligible and l.lt.m Xc kase = 3 if e(l-1) is negligible, l.lt.m, and Xc s(l), ..., s(m) are not negligible (qr step). Xc kase = 4 if e(m-1) is negligible (convergence). Xc X do 430 ll = 1, m X l = m - ll Xc ...exit X if (l .eq. 0) go to 440 Xc**** 6/24/87, nonconvergence fix Xc test = cdabs(s(l)) + cdabs(s(l+1)) Xc**** X ztest = test + cdabs(e(l)) X if (ztest .ne. test) go to 420 X e(l) = (0.0d0,0.0d0) Xc ......exit X go to 440 X 420 continue X 430 continue X 440 continue X if (l .ne. m - 1) go to 450 X kase = 4 X go to 520 X 450 continue X lp1 = l + 1 X mp1 = m + 1 X do 470 lls = lp1, mp1 X ls = m - lls + lp1 Xc ...exit X if (ls .eq. l) go to 480 Xc**** 6/24/87, nonconvergence fix Xc test = 0.0d0 Xc if (ls .ne. m) test = test + cdabs(e(ls)) Xc if (ls .ne. l + 1) test = test + cdabs(e(ls-1)) Xc**** X ztest = test + cdabs(s(ls)) X if (ztest .ne. test) go to 460 X s(ls) = (0.0d0,0.0d0) Xc ......exit X go to 480 X 460 continue X 470 continue X 480 continue X if (ls .ne. l) go to 490 X kase = 3 X go to 510 X 490 continue X if (ls .ne. m) go to 500 X kase = 1 X go to 510 X 500 continue X kase = 2 X l = ls X 510 continue X 520 continue X l = l + 1 Xc Xc perform the task indicated by kase. Xc X go to (530, 560, 580, 610), kase Xc Xc deflate negligible s(m). Xc X 530 continue X mm1 = m - 1 X f = dreal(e(m-1)) X e(m-1) = (0.0d0,0.0d0) X do 550 kk = l, mm1 X k = mm1 - kk + l X t1 = dreal(s(k)) X call drotg(t1,f,cs,sn) X s(k) = dcmplx(t1,0.0d0) X if (k .eq. l) go to 540 X f = -sn*dreal(e(k-1)) X e(k-1) = cs*e(k-1) X 540 continue X if (wantv) call zdrot(p,v(1,k),1,v(1,m),1,cs,sn) X 550 continue X go to 650 Xc Xc split at negligible s(l). Xc X 560 continue X f = dreal(e(l-1)) X e(l-1) = (0.0d0,0.0d0) X do 570 k = l, m X t1 = dreal(s(k)) X call drotg(t1,f,cs,sn) X s(k) = dcmplx(t1,0.0d0) X f = -sn*dreal(e(k)) X e(k) = cs*e(k) X if (wantu) call zdrot(n,u(1,k),1,u(1,l-1),1,cs,sn) X 570 continue X go to 650 Xc Xc perform one qr step. Xc X 580 continue Xc Xc calculate the shift. Xc X scale = dmax1(cdabs(s(m)),cdabs(s(m-1)),cdabs(e(m-1)), X * cdabs(s(l)),cdabs(e(l))) X sm = dreal(s(m))/scale X smm1 = dreal(s(m-1))/scale X emm1 = dreal(e(m-1))/scale X sl = dreal(s(l))/scale X el = dreal(e(l))/scale X b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0d0 X c = (sm*emm1)**2 X shift = 0.0d0 X if (b .eq. 0.0d0 .and. c .eq. 0.0d0) go to 590 X shift = dsqrt(b**2+c) X if (b .lt. 0.0d0) shift = -shift X shift = c/(b + shift) X 590 continue X f = (sl + sm)*(sl - sm) + shift X g = sl*el Xc Xc chase zeros. Xc X mm1 = m - 1 X do 600 k = l, mm1 X call drotg(f,g,cs,sn) X if (k .ne. l) e(k-1) = dcmplx(f,0.0d0) X f = cs*dreal(s(k)) + sn*dreal(e(k)) X e(k) = cs*e(k) - sn*s(k) X g = sn*dreal(s(k+1)) X s(k+1) = cs*s(k+1) X if (wantv) call zdrot(p,v(1,k),1,v(1,k+1),1,cs,sn) X call drotg(f,g,cs,sn) X s(k) = dcmplx(f,0.0d0) X f = cs*dreal(e(k)) + sn*dreal(s(k+1)) X s(k+1) = -sn*e(k) + cs*s(k+1) X g = sn*dreal(e(k+1)) X e(k+1) = cs*e(k+1) X if (wantu .and. k .lt. n) X * call zdrot(n,u(1,k),1,u(1,k+1),1,cs,sn) X 600 continue X e(m-1) = dcmplx(f,0.0d0) X iter = iter + 1 X go to 650 Xc Xc convergence. Xc X 610 continue Xc Xc make the singular value positive Xc X if (dreal(s(l)) .ge. 0.0d0) go to 620 X s(l) = -s(l) X if (wantv) call zscal(p,(-1.0d0,0.0d0),v(1,l),1) X 620 continue Xc Xc order the singular value. Xc X 630 if (l .eq. mm) go to 640 Xc ...exit X if (dreal(s(l)) .ge. dreal(s(l+1))) go to 640 X t = s(l) X s(l) = s(l+1) X s(l+1) = t X if (wantv .and. l .lt. p) X * call zswap(p,v(1,l),1,v(1,l+1),1) X if (wantu .and. l .lt. n) X * call zswap(n,u(1,l),1,u(1,l+1),1) X l = l + 1 X go to 630 X 640 continue X iter = 0 X m = m - 1 X 650 continue X go to 400 X 660 continue X return X end X X X subroutine zqrdc(x,ldx,n,p,qraux,jpvt,work,job) X integer ldx,n,p,job X integer jpvt(1) X complex*16 x(ldx,1),qraux(1),work(1) Xc Xc zqrdc uses householder transformations to compute the qr Xc factorization of an n by p matrix x. column pivoting Xc based on the 2-norms of the reduced columns may be Xc performed at the users option. Xc Xc on entry Xc Xc x complex*16(ldx,p), where ldx .ge. n. Xc x contains the matrix whose decomposition is to be Xc computed. Xc Xc ldx integer. Xc ldx is the leading dimension of the array x. Xc Xc n integer. Xc n is the number of rows of the matrix x. Xc Xc p integer. Xc p is the number of columns of the matrix x. Xc Xc jpvt integer(p). Xc jpvt contains integers that control the selection Xc of the pivot columns. the k-th column x(k) of x Xc is placed in one of three classes according to the Xc value of jpvt(k). Xc Xc if jpvt(k) .gt. 0, then x(k) is an initial Xc column. Xc Xc if jpvt(k) .eq. 0, then x(k) is a free column. Xc Xc if jpvt(k) .lt. 0, then x(k) is a final column. Xc Xc before the decomposition is computed, initial columns Xc are moved to the beginning of the array x and final Xc columns to the end. both initial and final columns Xc are frozen in place during the computation and only Xc free columns are moved. at the k-th stage of the Xc reduction, if x(k) is occupied by a free column Xc it is interchanged with the free column of largest Xc reduced norm. jpvt is not referenced if Xc job .eq. 0. Xc Xc work complex*16(p). Xc work is a work array. work is not referenced if Xc job .eq. 0. Xc Xc job integer. Xc job is an integer that initiates column pivoting. Xc if job .eq. 0, no pivoting is done. Xc if job .ne. 0, pivoting is done. Xc Xc on return Xc Xc x x contains in its upper triangle the upper Xc triangular matrix r of the qr factorization. Xc below its diagonal x contains information from Xc which the unitary part of the decomposition X Xc can be recovered. note that if pivoting has Xc been requested, the decomposition is not that Xc of the original matrix x but that of x Xc with its columns permuted as described by jpvt. Xc Xc qraux complex*16(p). Xc qraux contains further information required to recover Xc the unitary part of the decomposition. Xc Xc jpvt jpvt(k) contains the index of the column of the Xc original matrix that has been interchanged into Xc the k-th column, if pivoting was requested. Xc Xc linpack. this version dated 08/14/78 . Xc g.w. stewart, university of maryland, argonne national lab. Xc Xc zqrdc uses the following functions and subprograms. Xc Xc blas zaxpy,zdotc,zscal,zswap,dznrm2 Xc fortran dabs,dmax1,cdabs,dcmplx,cdsqrt,min0 Xc Xc internal variables Xc X integer j,jp,l,lp1,lup,maxj,pl,pu X double precision maxnrm,dznrm2,tt X complex*16 zdotc,nrmxl,t X logical negj,swapj Xc X complex*16 csign,zdum,zdum1,zdum2 X double precision cabs1 X double precision dreal,dimag X complex*16 zdumr,zdumi X dreal(zdumr) = zdumr X dimag(zdumi) = (0.0d0,-1.0d0)*zdumi X csign(zdum1,zdum2) = cdabs(zdum1)*(zdum2/cdabs(zdum2)) X cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) Xc X pl = 1 X pu = 0 X if (job .eq. 0) go to 60 Xc Xc pivoting has been requested. rearrange the columns Xc according to jpvt. Xc X do 20 j = 1, p X swapj = jpvt(j) .gt. 0 X negj = jpvt(j) .lt. 0 X jpvt(j) = j X if (negj) jpvt(j) = -j X if (.not.swapj) go to 10 X if (j .ne. pl) call zswap(n,x(1,pl),1,x(1,j),1) X jpvt(j) = jpvt(pl) X jpvt(pl) = j X pl = pl + 1 X 10 continue X 20 continue X pu = p X do 50 jj = 1, p X j = p - jj + 1 X if (jpvt(j) .ge. 0) go to 40 X jpvt(j) = -jpvt(j) X if (j .eq. pu) go to 30 X call zswap(n,x(1,pu),1,x(1,j),1) X jp = jpvt(pu) X jpvt(pu) = jpvt(j) X jpvt(j) = jp X 30 continue X pu = pu - 1 X 40 continue X 50 continue X 60 continue Xc Xc compute the norms of the free columns. Xc X if (pu .lt. pl) go to 80 X do 70 j = pl, pu X qraux(j) = dcmplx(dznrm2(n,x(1,j),1),0.0d0) X work(j) = qraux(j) X 70 continue X 80 continue Xc Xc perform the householder reduction of x. Xc X lup = min0(n,p) X do 200 l = 1, lup X if (l .lt. pl .or. l .ge. pu) go to 120 Xc Xc locate the column of largest norm and bring it Xc into the pivot position. Xc X maxnrm = 0.0d0 X maxj = l X do 100 j = l, pu X if (dreal(qraux(j)) .le. maxnrm) go to 90 X maxnrm = dreal(qraux(j)) X maxj = j X 90 continue X 100 continue X if (maxj .eq. l) go to 110 X call zswap(n,x(1,l),1,x(1,maxj),1) X qraux(maxj) = qraux(l) X work(maxj) = work(l) X jp = jpvt(maxj) X jpvt(maxj) = jpvt(l) X jpvt(l) = jp X 110 continue X 120 continue X qraux(l) = (0.0d0,0.0d0) X if (l .eq. n) go to 190 Xc Xc compute the householder transformation for column l. Xc X nrmxl = dcmplx(dznrm2(n-l+1,x(l,l),1),0.0d0) X if (cabs1(nrmxl) .eq. 0.0d0) go to 180 X if (cabs1(x(l,l)) .ne. 0.0d0) X * nrmxl = csign(nrmxl,x(l,l)) X call zscal(n-l+1,(1.0d0,0.0d0)/nrmxl,x(l,l),1) X x(l,l) = (1.0d0,0.0d0) + x(l,l) Xc Xc apply the transformation to the remaining columns, Xc updating the norms. Xc X lp1 = l + 1 X if (p .lt. lp1) go to 170 X do 160 j = lp1, p X t = -zdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) X call zaxpy(n-l+1,t,x(l,l),1,x(l,j),1) X if (j .lt. pl .or. j .gt. pu) go to 150 X if (cabs1(qraux(j)) .eq. 0.0d0) go to 150 X tt = 1.0d0 - (cdabs(x(l,j))/dreal(qraux(j)))**2 X tt = dmax1(tt,0.0d0) X t = dcmplx(tt,0.0d0) X tt = 1.0d0 X * + 0.05d0*tt X * *(dreal(qraux(j))/dreal(work(j)))**2 X if (tt .eq. 1.0d0) go to 130 X qraux(j) = qraux(j)*cdsqrt(t) X go to 140 X 130 continue X qraux(j) = dcmplx(dznrm2(n-l,x(l+1,j),1),0.0d0) X work(j) = qraux(j) X 140 continue X 150 continue X 160 continue X 170 continue Xc Xc save the transformation. Xc X qraux(l) = x(l,l) X x(l,l) = -nrmxl X 180 continue X 190 continue X 200 continue X return X end X X X subroutine zqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) X integer ldx,n,k,job,info X complex*16 x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1) Xc Xc zqrsl applies the output of zqrdc to compute coordinate Xc transformations, projections, and least squares solutions. Xc for k .le. min(n,p), let xk be the matrix Xc Xc xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) Xc Xc formed from columnns jpvt(1), ... ,jpvt(k) of the original Xc n x p matrix x that was input to zqrdc (if no pivoting was Xc done, xk consists of the first k columns of x in their Xc original order). zqrdc produces a factored unitary matrix q Xc and an upper triangular matrix r such that Xc Xc xk = q * (r) Xc (0) Xc Xc this information is contained in coded form in the arrays Xc x and qraux. Xc Xc on entry Xc Xc x complex*16(ldx,p). Xc x contains the output of zqrdc. Xc Xc ldx integer. Xc ldx is the leading dimension of the array x. Xc Xc n integer. Xc n is the number of rows of the matrix xk. it must Xc have the same value as n in zqrdc. Xc Xc k integer. Xc k is the number of columns of the matrix xk. k Xc must nnot be greater than min(n,p), where p is the Xc same as in the calling sequence to zqrdc. Xc Xc qraux complex*16(p). Xc qraux contains the auxiliary output from zqrdc. Xc Xc y complex*16(n) Xc y contains an n-vector that is to be manipulated Xc by zqrsl. Xc Xc job integer. Xc job specifies what is to be computed. job has Xc the decimal expansion abcde, with the following Xc meaning. Xc Xc if a.ne.0, compute qy. Xc if b,c,d, or e .ne. 0, compute qty. Xc if c.ne.0, compute b. Xc if d.ne.0, compute rsd. Xc if e.ne.0, compute xb. Xc Xc note that a request to compute b, rsd, or xb Xc automatically triggers the computation of qty, for Xc which an array must be provided in the calling Xc sequence. Xc Xc on return Xc Xc qy complex*16(n). Xc qy conntains q*y, if its computation has been Xc requested. Xc Xc qty complex*16(n). Xc qty contains ctrans(q)*y, if its computation has Xc been requested. here ctrans(q) is the conjugate Xc transpose of the matrix q. Xc Xc b complex*16(k) Xc b contains the solution of the least squares problem Xc Xc minimize norm2(y - xk*b), Xc Xc if its computation has been requested. (note that Xc if pivoting was requested in zqrdc, the j-th Xc component of b will be associated with column jpvt(j) Xc of the original matrix x that was input into zqrdc.) Xc Xc rsd complex*16(n). Xc rsd contains the least squares residual y - xk*b, Xc if its computation has been requested. rsd is Xc also the orthogonal projection of y onto the Xc orthogonal complement of the column space of xk. Xc Xc xb complex*16(n). Xc xb contains the least squares approximation xk*b, Xc if its computation has been requested. xb is also Xc the orthogonal projection of y onto the column space Xc of x. Xc Xc info integer. Xc info is zero unless the computation of b has Xc been requested and r is exactly singular. in Xc this case, info is the index of the first zero Xc diagonal element of r and b is left unaltered. Xc Xc the parameters qy, qty, b, rsd, and xb are not referenced Xc if their computation is not requested and in this case Xc can be replaced by dummy variables in the calling program. Xc to save storage, the user may in some cases use the same Xc array for different parameters in the calling sequence. a Xc frequently occuring example is when one wishes to compute Xc any of b, rsd, or xb and does not need y or qty. in this Xc case one may identify y, qty, and one of b, rsd, or xb, while Xc providing separate arrays for anything else that is to be Xc computed. thus the calling sequence Xc Xc call zqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) Xc Xc will result in the computation of b and rsd, with rsd Xc overwriting y. more generally, each item in the following Xc list contains groups of permissible identifications for Xc a single callinng sequence. Xc Xc 1. (y,qty,b) (rsd) (xb) (qy) Xc Xc 2. (y,qty,rsd) (b) (xb) (qy) Xc Xc 3. (y,qty,xb) (b) (rsd) (qy) X Xc Xc 4. (y,qy) (qty,b) (rsd) (xb) Xc Xc 5. (y,qy) (qty,rsd) (b) (xb) Xc Xc 6. (y,qy) (qty,xb) (b) (rsd) Xc Xc in any group the value returned in the array allocated to Xc the group corresponds to the last member of the group. Xc Xc linpack. this version dated 08/14/78 . Xc g.w. stewart, university of maryland, argonne national lab. Xc Xc zqrsl uses the following functions and subprograms. Xc Xc blas zaxpy,zcopy,zdotc Xc fortran dabs,min0,mod Xc Xc internal variables Xc X integer i,j,jj,ju,kp1 X complex*16 zdotc,t,temp X logical cb,cqy,cqty,cr,cxb Xc X complex*16 zdum X double precision cabs1 X double precision dreal,dimag X complex*16 zdumr,zdumi X dreal(zdumr) = zdumr X dimag(zdumi) = (0.0d0,-1.0d0)*zdumi X cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) Xc Xc set info flag. Xc X info = 0 Xc Xc determine what is to be computed. Xc X cqy = job/10000 .ne. 0 X cqty = mod(job,10000) .ne. 0 X cb = mod(job,1000)/100 .ne. 0 X cr = mod(job,100)/10 .ne. 0 X cxb = mod(job,10) .ne. 0 X ju = min0(k,n-1) Xc Xc special action when n=1. Xc X if (ju .ne. 0) go to 40 X if (cqy) qy(1) = y(1) X if (cqty) qty(1) = y(1) X if (cxb) xb(1) = y(1) X if (.not.cb) go to 30 X if (cabs1(x(1,1)) .ne. 0.0d0) go to 10 X info = 1 X go to 20 X 10 continue X b(1) = y(1)/x(1,1) X 20 continue X 30 continue X if (cr) rsd(1) = (0.0d0,0.0d0) X go to 250 X 40 continue Xc Xc set up to compute qy or qty. Xc X if (cqy) call zcopy(n,y,1,qy,1) X if (cqty) call zcopy(n,y,1,qty,1) X if (.not.cqy) go to 70 Xc Xc compute qy. Xc X do 60 jj = 1, ju X j = ju - jj + 1 X if (cabs1(qraux(j)) .eq. 0.0d0) go to 50 X temp = x(j,j) X x(j,j) = qraux(j) X t = -zdotc(n-j+1,x(j,j),1,qy(j),1)/x(j,j) X call zaxpy(n-j+1,t,x(j,j),1,qy(j),1) X x(j,j) = temp X 50 continue X 60 continue X 70 continue X if (.not.cqty) go to 100 Xc Xc compute ctrans(q)*y. Xc X do 90 j = 1, ju X if (cabs1(qraux(j)) .eq. 0.0d0) go to 80 X temp = x(j,j) X x(j,j) = qraux(j) X t = -zdotc(n-j+1,x(j,j),1,qty(j),1)/x(j,j) X call zaxpy(n-j+1,t,x(j,j),1,qty(j),1) X x(j,j) = temp X 80 continue X 90 continue X 100 continue Xc Xc set up to compute b, rsd, or xb. Xc X if (cb) call zcopy(k,qty,1,b,1) X kp1 = k + 1 X if (cxb) call zcopy(k,qty,1,xb,1) X if (cr .and. k .lt. n) call zcopy(n-k,qty(kp1),1,rsd(kp1),1) X if (.not.cxb .or. kp1 .gt. n) go to 120 X do 110 i = kp1, n X xb(i) = (0.0d0,0.0d0) X 110 continue X 120 continue X if (.not.cr) go to 140 X do 130 i = 1, k X rsd(i) = (0.0d0,0.0d0) X 130 continue X 140 continue X if (.not.cb) go to 190 Xc Xc compute b. Xc X do 170 jj = 1, k X j = k - jj + 1 X if (cabs1(x(j,j)) .ne. 0.0d0) go to 150 X info = j Xc ......exit X go to 180 X 150 continue X b(j) = b(j)/x(j,j) X if (j .eq. 1) go to 160 X t = -b(j) X call zaxpy(j-1,t,x(1,j),1,b,1) X 160 continue X 170 continue X 180 continue X 190 continue X if (.not.cr .and. .not.cxb) go to 240 Xc Xc compute rsd or xb as required. Xc X do 230 jj = 1, ju X j = ju - jj + 1 X if (cabs1(qraux(j)) .eq. 0.0d0) go to 220 X temp = x(j,j) X x(j,j) = qraux(j) X if (.not.cr) go to 200 X t = -zdotc(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) X call zaxpy(n-j+1,t,x(j,j),1,rsd(j),1) X 200 continue X if (.not.cxb) go to 210 X t = -zdotc(n-j+1,x(j,j),1,xb(j),1)/x(j,j) X call zaxpy(n-j+1,t,x(j,j),1,xb(j),1) X 210 continue X x(j,j) = temp X 220 continue X 230 continue X 240 continue X 250 continue X return X end X X END_OF_zlinpack.f if test 33916 -ne `wc -c zlistr.f <<'END_OF_zlistr.f' Xc On this file june 13, 1987: Xc listr, ppcj X subroutine listr (opt, a, b, ldab, m, n, rowb, rowe, X * colb, cole, first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr, kfirst, step, X * adlsvd, bdlsvd, X * work, x, sx, ex, q, arow, brow, w, qraux, y, X * qty, info) Xc Xc implicit none Xc**** debug space Xc the common-block declarations assume that the dimension of the Xc input matrix pencil a - lambda b is not larger than abdim. Xc the debug space is used for producing debug outputs (optional, Xc see below) Xc X integer abdim X parameter (abdim = 30) X common /debug1/ acopy(abdim,abdim),bcopy(abdim,abdim), X * atest(abdim,abdim),btest(abdim,abdim),swap X common /debug2/ idbg(20), outunit X complex*16 acopy, bcopy, atest, btest X logical swap X integer idbg, outunit Xc Xc**** formal parameter declarations X character*(*) opt X integer ldab, m, n, rowb, rowe, colb, cole, ldpp, ldqq, X * kstr(4,*), step, kfirst, info X logical first, zero X real*8 adlsvd, bdlsvd, epsua, epsub, gap X complex*16 a(ldab,*), b(ldab,*),pp(ldpp,*), qq(ldqq,*), X * work(*) Xc Xc**** work space Xc X complex*16 x(m,n), sx(*), ex(*), q(m,m), X * arow(*), brow(*), w(m,m), qraux(*), y(*), X * qty(*) Xc Xc******************************************************************* Xc Xc listr computes the kronecker left (row) structure and Xc the jordan structure of the infinite-eigenvalue of a singular Xc pencil a-lambda*b. for details concerning the listr-kernel see Xc the following papers: Xc Xc b.kagstrom, rgsvd - an algorithm for computing the kronecker Xc structure and reducing subspaces of singular a - lambda b Xc pencils, siam j.sci.stat.comput., vol. 7, 1986, pp 185-211 Xc Xc j.demmel and b.kagstrom, stably computing the kronecker Xc structure and reducing subspaces of singular pencils Xc a - lambda b for uncertain data, in large scale eigenvalue Xc problems (cullum, willoughby eds), north holland, 1986, Xc pp 283-323. Xc Xc Xc formal parameters Xc Xc on entry Xc Xc opt*(*) character, if opt = 'cind' listr computes indices Xc if opt = 'rind' already computed indices Xc are reused in the reduction Xc Xc a(ldab,*) complex*16, input matrix a of order m by n Xc Xc b(ldab,*) complex*16, input matrix b of order m by n Xc Xc ldab integer, leading dimension of a and b Xc Xc m integer, current row dimension of a and b Xc Xc n integer, current column dimension of and b Xc Xc rowb integer, first row of the subpencil Xc Xc rowe integer, last row of the subpencil Xc Xc colb integer, first column of the subpencil Xc Xc cole integer, last column of the subpencil Xc Xc first logical, first should be 'true' if first call to Xc listr, else 'false' Xc Xc zero logical, if 'true', zero out small singular values Xc so returned pencil really has structure described Xc in kstr (see below), else returned pencil is a Xc true equivalence transformation of input pencil Xc (no singular values are deleted) Xc Xc epsua real*8, threshold for deleting singular values of a Xc (used when compressing rows of a) Xc Xc epsub real*8, threshold for deleting singular values of b Xc (used when compressing rows of b) Xc Xc gap real*8, should be at least 1 and nominally 1000. Xc used by subroutine rcsvdc to make rank decisions Xc by searching for adjacent singular values whose Xc ratio exceeds gap. Xc Xc ldpp integer, leading dimension of pp Xc Xc ldqq integer, leading dimension of qq Xc Xc kfirst integer, index to the first location in kstr Xc where structure-index information is stored Xc from this reduction (see below) Xc Xc on exit Xc Xc pp(ldpp,*)complex*16, left unitary transformation matrix Xc pp of order m by m Xc Xc qq(ldqq,*)complex*16, right unitary transformation matrix Xc qq of order n by n Xc Xc a(ldab,*) transformed matrix a (pp**h * a * qq) Xc Xc b(ldab,*) transformed matrix b (pp**h * b * qq) Xc Xc kstr(4,*) integer, stores information concerning left Xc kronecker indices and the jordan structure of Xc the infinite eigenvalue. Xc kstr(1,kfirst-1+j) - kstr(2,kfirst-1+j) = Xc number of l(j-1)**t blocks (left indices of Xc degree j-1). Xc kstr(2,kfirst-1+j) - kstr(1,kfirst+j) = Xc number of jordan blocks of the infinite Xc eigenvalue of dimension j. Xc index j goes from 1 to step (see below) Xc note: rows 3 and 4 of kstr are not used inside Xc listr. Xc Xc step integer, the number of deflation-steps in this Xc reduction Xc Xc adlsvd real*8, root sum of squares of deleted singular Xc values of a (independent of the input zero) Xc Xc bdlsvd real*8, root sum of squares of deleted singular Xc values of b (independent of the input zero) Xc Xc info integer, zero if normal return, Xc 1 if svd does not converge Xc Xc on exit form listr a and b will be in block upper triangular form: Xc Xc Xc a = ( a11 * ) b = ( b11 * ) Xc ( 0 ali ) ( 0 bli ) Xc Xc the block structure of the pencil ali - lambda*bli describes Xc the kronecker row (left) structure and the jordan structure Xc of the infinite eigenvalue. if ni and ri denote the dimension of Xc the diagonal blocks in ali and bli (see example below), Xc then they have the following interpretation: Xc Xc ni - ri = the number of l(i-1)**t -blocks of order i by i-1 Xc ri - ni+1 = the number of j(inf)-blocks of order i by i Xc Xc note that if a - lambda*b is a regular pencil then ni=ri. Xc the listr reduction stops when an ni.eq.0 or ni.ne.0 but ri.eq.0. Xc then b11 will have full row rank. a11 - lambda*b11 might Xc still be a singular pencil (can have right (column) indices). Xc an example illustrates the two cases (see papers for details): Xc case 1 - n4.eq.0: Xc Xc ( a11 a12 a13 ) n3 ( 0 b12 b13 ) n3 Xc ali = ( 0 a22 a23 ) n2 bli = ( 0 0 b23 ) n2 Xc ( 0 0 a33 ) n1 ( 0 0 0 ) n1 Xc r3 r2 r1 r3 r2 r1 Xc Xc case 2 - n4.ne.0 and r4.eq.0: Xc Xc ( a11 a12 a13 ) n4 ( b11 b12 b13 ) n4 Xc ali = ( a21 a22 a23 ) n3 bli = ( 0 b22 b23 ) n3 Xc ( 0 a32 a33 ) n2 ( 0 0 b33 ) n2 Xc ( 0 0 a43 ) n1 ( 0 0 0 ) n1 Xc r3 r2 r1 r3 r2 r1 Xc Xc the ni by ri subdiagonal blocks ai+1i of ali are in the form Xc (rii) Xc ( 0 ), where rii is ri by ri, nonsingular and upper triangular. Xc Xc if kfirst = 1 on input then case 2 above cause the following Xc output for step and kstr: Xc step = 4 Xc kstr(1,1) = n1 kstr(2,1) = r1 Xc kstr(1,2) = n2 kstr(2,2) = r2 Xc kstr(1,3) = n3 kstr(2,3) = r3 Xc kstr(1,4) = n4 kstr(2,4) = 0 Xc Xc note that on output (ali,bli) or (a11,b11) can be nonexistent Xc in the block upper triangular form (a,b). (ali,bli) does not Xc exist if n1=r1=0. (a11,b11) does not exist if the input pencil Xc a -lambda*b has no right (column) singular structure and no Xc finite eigenvalues. Xc Xc Xc*** work space including size (all variables complex*16) Xc work(*) max(m,n) Xc x(m,*) m by n Xc sx(*) min(m,n) + 1 Xc ex(*) n Xc q(m,*) m by m Xc arow(*) max(m,n) Xc brow(*) max(m,n) Xc w(m,*) m by m Xc qraux(*) max(m,n) Xc y(*) max(m,n) Xc qty(*) max(m,n) Xc Xc***************************************************************** Xc Xc**** this version dated june 16, 1987 Xc authors: jim demmel, bo kagstrom Xc Xc**** listr uses the following functions and subroutines Xc kcfpack - cmatml, cmatmr, cmatpr, cmcopy, ppcj, Xc rcsvdc, upddel Xc linpack - zqrdc, zqrsl Xc Xc**** internal variables Xc X logical ldebug X integer mrow, ncol, i, j, sn1, sr1, rep, rowsn1, colsr1, xrow X * , xcol, job, ldx, ldq, n1, rnull, ldw, cnull, r1 X * , rowbm1, colbm1, idummy, ikstr, mxrc, k, iii, jjj Xc X real*8 del, difa, difb Xc X complex*16 dummy Xc Xc**** set leading dimensions of x, q, w X ldx = m X ldq = m X ldw = m Xc set debug switch X ldebug = idbg(5) .ne. 0 Xc**** compute the order of the pencil in action (mrow * ncol) X mrow = rowe - rowb + 1 X ncol = cole - colb + 1 Xc Xc*+*+*+ accumulate deleted singular values in adlsvd and bdlsvd X adlsvd = 0.0 X bdlsvd = 0.0 Xc X if (ldebug) then X write (outunit,1000) 'epsua=', epsua X write (outunit,1000) 'epsub=', epsub X endif Xc Xc Xc**** set rep depending on what option Xc X if ( opt .eq. 'cind' ) then Xc perhaps not enough !! X rep = rowe * cole X else Xc the number of deflation steps Xc rep = step - kfirst + 1 Xc***** Changes made 1986-06-17 X rep = step X endif Xc*** 6/18/87 X if (ldebug) write(outunit,2000) 'kfirst=',kfirst, X + 'step=',step,'rep=',rep X sn1 = 0 X sr1 = 0 X step = 0 Xc**** while rep > 0 do X 30 continue X if (ldebug) write(outunit,2000) 'rep at top of loop=',rep X if (rep .eq. 0) go to 500 Xc jump when while - loop satisfied Xc Xc while - clause X step = step + 1 X if (ldebug) then X write( outunit, 2000 ) 'Results from step = ', step X 2000 format( t5, a, i3/) X write(outunit,2005) opt X 2005 format(t5,a) X endif Xc Xc**** set n1 and r1 if we are reusing kstr Xc X if ( opt .eq. 'rind' ) then X ikstr = kfirst + step - 1 X n1 = kstr(1, ikstr) X r1 = kstr(2, ikstr) X rnull = n1 -r1 X endif Xc Xc**** step 1 - compress rows of b (gives n1 = dimension of the Xc row nullspace) Xc* 1.1 Xc rows, rowb:rowe-sn1 Xc cols, colb:cole-sr1 Xc------------------------------ X rowsn1 = rowe - sn1 X colsr1 = cole - sr1 Xc X rowbm1 = rowb - 1 X colbm1 = colb - 1 X xrow = mrow - sn1 X xcol = ncol - sr1 Xc**** 6/18/87 fix X if (opt .eq. 'rind') cnull = n1 - (xrow - xcol) Xc**** X do 40 i = 1, xrow X do 35 j = 1, xcol X x(i, j) = b(rowbm1 + i, colbm1 + j) X 35 continue X 40 continue X job = 1000 X if (ldebug) then X write(outunit,5000) 'rowsn1=',rowsn1,'colsr1=',colsr1, X * 'xrow=',xrow X write(outunit,5000) 'xcol=',xcol,'rowb=',rowb,'rowe=',rowe X write(outunit,5000) 'colb=',colb,'cole=',cole,'sr1=',sr1, X * 'sn1=',sn1 X if ( opt .eq. 'rind') then X write(outunit,5000) 'cnull=',cnull,'rnull=',rnull X write(outunit,5000) 'n1=',n1,'r1=',r1 X endif X endif Xc put m*n in info before calling (why ? 870608) X info = m*n X call rcsvdc (x, ldx, xrow, xcol, sx, ex, q, ldq, dummy, 1, opt, X * epsub, gap, cnull, n1, del, work, job, info ) Xc Xc X call upddel(bdlsvd, del) Xc X if (ldebug) then X write(outunit,1000) 'bdlsvd=', bdlsvd, 'del=', del X mxrc = min0( xrow, xcol) X call cmatpr( sx, 1, 1, mxrc, X * 'singular values - row compress b') X call cmatpr( ex, 1, 1, mxrc,'sub diagonal - should be zero') X write (outunit, 1005) 'info=', info, '(rownullity) n1=', n1 X 1005 format(t5, a, i3/ ) X endif Xc X if (info .ne. 0 ) then Xc*** 6/18/87 X if (ldebug) write(outunit,2007) info X 2007 format('listr - after first call to rcsvdc, info =',i4) X info = 1 X return X endif Xc Xc if n1=0, we are done X if (n1 .eq. 0) then X r1=0 X goto 450 X end if Xc Xc* 1.2 - apply left transformation q to a and b (the full matrices) Xc cols in a and b: colb:n Xc rows in a: rowb:rowe-sn1 ( xrow row's) Xc rows in b: rowb:rowe-sn1 Xc----------------------------------- X do 70 i = colb, n X do 50 j = 1, xrow X arow(j) = 0.d0 X brow(j) = 0.d0 X do 45 k = 1, xrow X arow(j) = arow(j) + a(rowbm1 + k, i) * conjg(q(k,j)) X brow(j) = brow(j) + b(rowbm1 + k, i) * conjg(q(k,j)) X 45 continue X 50 continue X do 60 j = 1, xrow X a(rowbm1 + j, i) = arow(j) X b(rowbm1 + j, i) = brow(j) X 60 continue X 70 continue Xc Xc* zero part of b Xc rows, rowe-sn1-n1+1:rowe-sn1 Xc cols, colb:cole-sr1 Xc---------------------------------------- X if (zero) then X do 80 i = rowe - sn1 - n1 + 1, rowe - sn1 X do 75 j = colb, cole - sr1 X b(i, j) = 0.d0 X 75 continue X 80 continue X endif Xc Xc**** Step 2 - row compress part of A ( gives n1 - r1 = Xc dimension of the common nullspace) Xc Xc* 2.1 Xc rows, rowe-sn1-n1+1:rowe-sn1 Xc cols, colb:cole-sr1 Xc----------------------------------- X xrow = n1 X xcol = ncol - sr1 X do 90 i = 1, xrow X do 85 j = 1, xcol X x(i, j) = a( rowsn1 - n1 + i, colbm1 + j) X 85 continue X 90 continue Xc X job = 1000 X info = m*n Xc**** 6/18/87 fix X if (opt .eq. 'rind') cnull = xcol - r1 Xc X call rcsvdc ( x, ldx, xrow, xcol, sx, ex, w, ldw, dummy, 1, opt, X * epsua, gap, cnull, rnull, del, work, job, info ) Xc Xc X if ( opt .eq. 'cind' ) r1 = n1 - rnull Xc Xc if r1 = 0 then we are done ! zero part in a and update qq Xc X if (ldebug) then X write (outunit, 1005) 'info=', info, 'rnull=', rnull, X * 'n1=', n1,'r1=', r1 Xc X mxrc = min0( xrow, xcol) X call cmatpr( sx, 1, 1, mxrc, X * 'singular values - row compress a') X call cmatpr( ex, 1, 1, mxrc,'sub diagonal - should be zero') X endif Xc X if (info .ne. 0) then Xc**** 6/18/87 X if (ldebug) write(outunit,2008) info X 2008 format('listr - after second call to rcsvdc, info= ',i4) X info = 1 X return X endif Xc X call upddel(adlsvd, del) Xc Xc X if (r1 .eq. 0) goto 3500 Xc Xc* 2.2 Xc update left transformation q Xc rows, 1:mrow-sn1 (xrow) Xc cols, xrow-n1+1:xrow Xc___________________________________________________________________ Xc X xrow = mrow - sn1 X do 110 i = 1, xrow X do 100 j = 1, n1 X arow(j) = 0.d0 X do 95 k = 1, n1 X arow(j) = arow(j) + q(i, xrow - n1 + k) * w(k, j) X 95 continue X 100 continue Xc X do 105 j = 1, n1 X q(i, xrow - n1 + j) = arow(j) X 105 continue X 110 continue Xc X 1000 format(t5, a, d13.5) X if (idbg(5) .gt. 1) then X call cmatpr(q,ldq,mrow-sn1,mrow-sn1,'q after step 2.2') X call cmatpr(a,ldab,m,n,'a before step 2.2') X call cmatpr(b,ldab,m,n,'b before step 2.2') X endif Xc Xc**** now a and b ....with w too Xc rows, rowe-sn1-n1+1:rowe-sn1 Xc cols, colb:n Xc Xc note that we do not make use of that some of the elements Xc in b are zero Xc X do 120 i = colb,n X do 114 j = 1, n1 X arow(j) = 0.d0 X brow(j) = 0.d0 X do 112 k = 1, n1 X arow(j) = arow(j) + a(rowsn1-n1+k,i) * conjg(w(k,j)) X brow(j) = brow(j) + b(rowsn1-n1+k,i) * conjg(w(k,j)) X 112 continue X 114 continue X do 116 j = 1, n1 X a(rowsn1-n1+j,i) = arow(j) X b(rowsn1-n1+j,i) = brow(j) X 116 continue X 120 continue X if (idbg(5) .gt. 1) then X call cmatpr(a,ldab,m,n,'a after step 2.2') X call cmatpr(b,ldab,m,n,'b after step 2.2') X endif Xc Xc* zero part of a Xc rows, rowe-sn1-(n1-r1)+1:rowe-sn1 Xc cols, colb:cole-sr1 Xc-------------------------------------------- Xc X 3500 continue X if (zero) then X if (ldebug) then X write(outunit, 4005) 'loop indices in 130', X * rowsn1 - (n1 - r1) + 1,rowsn1 X write(outunit, 4005) 'loop indices in 125', colb, colsr1 X 4005 format(t5, a, 2i5) X endif X do 130 i = rowsn1 - (n1 - r1) + 1,rowsn1 X do 125 j = colb, colsr1 X a(i,j) = 0.d0 X 125 continue X 130 continue X endif X if (r1 .eq. 0) go to 350 Xc Xc**** Step 3 - Triangularize A by a rq-decomposition ( using qr) Xc Xc* 3.1 Xc rows, rowb:rowe-sn1-(n1-r1) Xc cols, colb:cole-sr1 Xc--------------------------------------------- Xc X xrow = mrow - sn1 - (n1 - r1) X xcol = ncol - sr1 Xc move a(trans,conjg) with permuted columns (n,n-1,...1) Xc X do 140 i = 1, xcol X do 135 j = 1, xrow X x(i, j) = conjg( a(rowsn1 - (n1-r1)+1-j, colbm1 + i)) X 135 continue X 140 continue X job = 0 X if (idbg(5) .gt. 1) then X call cmatpr(x,ldx,xcol,xrow,'part of a before qr-decomp') X endif X call zqrdc( x, ldx, xcol, xrow, qraux, idummy, dummy, job) Xc Xc**** move the upper triangular part to a Xc X if (ldebug) then X write(outunit, 5000) 'xrow=', xrow, 'xcol=', xcol X write(outunit, 5000) 'rowb=',rowb, 'colb=', colb Xc call cmatpr(x,ldx,xcol,xrow,'x after call to zqrdc') X write(outunit, 1010) 'a(rowb,colb)', a(rowb,colb) X1010 format(t5, a, 2d15.5) X endif X call ppcj( x, ldx, 1, xcol, 1, xrow, a(rowb, colb), ldab) Xc Xc zero elements in a to make it upper triangular! Xc rows, rowe-sn1-(n1-r1)-(xcol-2):rowe-sn1-(n1-r1) Xc cols, colb:cole-sr1-1 X X do 150 i = colb, cole - sr1 -1 X do 148 j = i-colb+( rowsn1-(n1-r1)-xcol+2),rowsn1-(n1-r1) X a(j, i) = 0.d0 X 148 continue X 150 continue X if (idbg(5) .gt. 1) then X call cmatpr(a,ldab,m,n,'A after triangularization') X endif Xc Xc* 3.2 Xc apply v (xcol*xcol)to remaining rows of a Xc rows, 1:rowb-1 Xc cols, colb:cole-sr1 Xc Xc----------------------------------------------------- Xc X do 170 j = 1, rowb - 1 X X do 160 i = 1, xcol X y(i) = conjg(a( j, colbm1 + i)) X 160 continue X job = 01000 X call zqrsl(x, ldx, xcol, xrow, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 165 i = 1, xcol X a(j, colsr1-i+1) = conjg( qty(i)) X 165 continue X 170 continue X if (idbg(5) .gt. 1) then X call cmatpr(a, ldab, m, n, X * ' A after triangularization - step 3.1') X endif Xc Xc apply v to b from right (xcol*xcol) Xc rows, 1:rowe-sn1-n1 Xc cols, colb:cole-sr1 Xc---------------------------------------------------------- Xc X do 185 j = 1, rowe - sn1 - n1 X do 180 i = 1, xcol X y(i) = conjg(b(j, colbm1 + i)) X 180 continue X job = 01000 X call zqrsl(x, ldx, xcol, xrow, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 175 i = 1, xcol X b(j, colsr1 - i + 1) = conjg(qty(i)) X 175 continue X 185 continue X if (idbg(5) .gt. 1) then X call cmatpr(b, ldab, m, n, X * ' B after triangularization - step 3.1') X endif Xc Xc**** update right transformation matrix qq ( n*n ) Xc rows, 1:n Xc cols, colb:cole-sr1 Xc----------------------------------------------------- Xc X do 200 j = 1, n X do 195 i = 1, xcol X y(i) = conjg(qq(j ,colbm1 + i)) X 195 continue X job = 01000 X call zqrsl(x, ldx, xcol, xrow, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 198 i = 1, xcol X qq(j, colsr1 - i + 1) = conjg(qty(i)) X 198 continue X 200 continue X if ( idbg(5) .gt. 1) then X call cmatpr(qq,ldqq,n,n,'qq after updating') X endif X 350 continue Xc Xc**** update left transformation matrix pp ( m*m ) Xc rows, 1:m Xc cols, rowb:rowe-sn1 Xc----------------------------------------------------- Xc X xrow = mrow - sn1 X if (first) then X do 210 i = 1, m X do 205 j = 1, m X pp(i, j) = q(i, j) X 205 continue X 210 continue X else X do 240 i = 1, m X do 230 j = 1, xrow X arow(j) = 0.d0 X do 220 k = 1, xrow X arow(j) = arow(j) + pp(i, rowbm1 + k) * q(k, j) X 220 continue X 230 continue X do 235 j = 1, xrow X pp(i, rowbm1 + j) = arow(j) X 235 continue X 240 continue X endif Xc Xc**** update indices Xc X sn1 = sn1 + n1 X sr1 = sr1 + r1 X if (ldebug) then X write(outunit,5000) 'rowsn1=',rowsn1,'colsr1=',colsr1, X * 'xrow=',xrow X write(outunit,5000) 'xrow=',xrow,'rowb=',rowb,'rowe=',rowe X write(outunit,5000) 'colb=',colb,'cole=',cole,'sr1=',sr1, X * 'sn1=',sn1 X endif Xc* monitoring of the r1 and n1 in kstr Xc X 450 continue X if (ldebug) then X if (swap) then X call cmcopy(bcopy,20,m,n,atest) X call cmcopy(acopy,20,m,n,btest) X else X call cmcopy(acopy,20,m,n,atest) X call cmcopy(bcopy,20,m,n,btest) X end if X call cmatml(atest,20,m,n,pp,ldpp,m,atest,20,work,3) X call cmatmr(atest,20,m,n,qq,ldqq,n,atest,20,work,1) X call cmatml(btest,20,m,n,pp,ldpp,m,btest,20,work,3) X call cmatmr(btest,20,m,n,qq,ldqq,n,btest,20,work,1) X difa=0 X difb=0 X do 1234 iii=1,m X do 5678 jjj=1,n X difa=difa+abs(atest(iii,jjj)-a(iii,jjj)) X difb=difb+abs(btest(iii,jjj)-b(iii,jjj)) X 5678 continue X 1234 continue X write(outunit,201) 'difa=',difa X 201 format(t5,a,d13.6/) X call cmatpr(atest,20,m,n,'atest') X write(outunit,201) 'difb=',difb X call cmatpr(btest,20,m,n,'btest') X endif Xc Xc**** compute rep depending on what option is used Xc X if ( opt .eq. 'cind') then X kstr(1, kfirst - 1 + step) = n1 X kstr(2, kfirst - 1 + step) = r1 Xc***** changed 1986-06-17 Xc rep = n1 * r1 * (mrow - sr1) * (ncol - sn1) X rep = n1 * r1 * (ncol - sr1) * (mrow - sn1) X else X rep =rep - 1 X endif X if (ldebug) then X write(outunit,5000) 'sn1=',sn1,'sr1=',sr1,'rep=',rep X 5000 format(t5,a,i4/) X endif X first = .false. X go to 30 Xc Xc**** end of while clause X 500 continue Xc X return X end Xc X subroutine ppcj(from,ldfrom,rowb,rowe,colb,cole,to,ldto) Xc Xc take from(rowb:rowe, colb:cole), reverse the columns, reverse Xc the rows, take its conjugate transpose, and store in Xc to(1:cole-colb+1, 1:rowe-rowb+1) X complex*16 from(ldfrom,*), to(ldto,*) X integer rowb,rowe,colb,cole,rsum,csum X rsum=rowe+1 X csum=cole+1 X nrow=rowe-rowb+1 X ncol=cole-colb+1 X do 1 i=1,ncol X do 2 j=1,nrow X to(i,j)=conjg(from(rsum-j,csum-i)) X2 continue X1 continue X return X end END_OF_zlistr.f if test 24733 -ne `wc -c zmiscl.f <<'END_OF_zmiscl.f' X Xc in this file june 12 1987: Xc cmatg1, pertb1, cmcopy, cdife, cnorm, cond, cmatpr, matblk1 Xc Xc routines here are only for debug and test, but called by guptri Xc X subroutine cmatg1(a,lda,b,ldb,m,n,acopy,bcopy,work,job, X * epsper, trpose, binfile) Xc implicit none Xc** X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer lda,ldb,m,n,job, mtemp X real*8 epsper X complex*16 a(lda,lda),b(ldb,ldb),acopy(lda,lda), X * work(*),bcopy(ldb,ldb) X character*80 binfile Xc Xc****************************************************************** Xc Xc this routine reads input pencil from a binary file Xc created by bpenc1.for or bpenc2.for Xc revised: 870612 Xc Xc****************************************************************** X integer i, j, seed X logical wanta, wantb, pertur, prints, trpose X real*8 nea, neb, cnorm X data seed/1234/ Xc Xc note: if lda or ldb>= 20, then the dimensions of p and qinv have Xc to be changed Xc Xc Xc***** determine what is to be computed Xc only prints, pertur and trpose are used **** X wanta = job / 1000 .ne. 0 X wantb = mod(job,1000) / 100 .ne. 0 X pertur = mod(job,100) / 10 .ne. 0 X prints = mod(job,10 ) .ne. 0 X write( outunit, 400) 'trpose=', trpose X write (outunit, 400) 'pertur=', pertur X write (outunit, 400) 'prints=', prints X 400 format(t5, a, l1) Xc Xc read acopy and bcopy from binary file Xc X open(15, file = binfile, form='unformatted', status='old') X read(15) m, n X read(15) ((acopy(i,j), j = 1, n), i = 1, m) X read(15) ((bcopy(i,j), j = 1, n), i = 1, m) X close(15, status ='keep') Xc Xc X if (trpose) then X do 750 i=1,m X do 751 j=1,n X a(j,i)=acopy(i,j) X b(j,i)=bcopy(i,j) X751 continue X750 continue X mtemp = m X m = n X n = mtemp X else X do 752 i=1,m X do 753 j=1,n X a(i,j)=acopy(i,j) X b(i,j)=bcopy(i,j) X753 continue X752 continue X endif Xc X if (pertur) then Xc X nea = cnorm(a,lda,m,n,0,work) * epsper X neb = cnorm(b,ldb,m,n,0,work) * epsper Xc add perturbations to a and b X do 50 i = 1, m X do 50 j = 1, n X a(i,j) = a(i,j) + ( -0.5 +rand(seed)) * nea X b(i,j) = b(i,j) + ( -0.5 + rand(seed)) * neb X 50 continue X X endif Xc Xc compute norm(a,e) and norm(b,e) Xc X nea = cnorm(a,lda,m,n,0,work) X neb = cnorm(b,ldb,m,n,0,work) X write(outunit,350) 'epsper=', epsper X write(outunit,350) 'norm(a,e)=', nea, 'norm(b,e)=', neb X 350 format(t5,a,d12.5,tr5,a,d12.5,tr5,a,d12.5) Xc Xc copy a and b to acopy and bcopy, respectively Xc X call cmcopy(a,lda,m,n,acopy) X call cmcopy(b,ldb,m,n,bcopy) Xc X if (prints) then X call cmatpr(a,lda,m,n,'final version of a input') X call cmatpr(b,lda,m,n,'final version of b input') X endif X return Xc X end Xc X subroutine pertb1(aorig, borig, a, b, ldab,m ,n , epsbnd, X + work, job, nostat) Xc implicit none Xc*** debug space X integer abdim X parameter (abdim = 30) X common /debug1/ acopy(abdim,abdim),bcopy(abdim,abdim), X + atest(abdim, abdim), btest(abdim,abdim), swap X common /debug2/ idbg(20), outunit X complex*16 acopy, bcopy, atest, btest X integer idbg, outunit X logical swap Xc**** formal parameter declarations X integer ldab, m, n, job X complex*16 aorig(ldab,*), borig(ldab,*), a(ldab,*), X * b(ldab,*), work(*) X real*8 epsbnd X logical nostat Xc Xc**** add random noise of relative size epsbnd to aorig and borig Xc and store in a and b Xc job cotrols the structure of the perturbations Xc job = 1 add random perturbations to a and b Xc job = 2 add random perturbations to a Xc add random perturbations to the last n-m columns of b Xc job = 3 add general random perturbations to a only Xc Xc if (idbg(11) .ne. 0 ) print out perturbed a and b Xc X real*8 nea, neb, cnorm X integer i, j, seed, colb X data seed/1234/ Xc X nea = cnorm(aorig, ldab, m, n, 0, work) *epsbnd X neb = cnorm(borig, ldab, m, n, 0, work) *epsbnd Xc add perturbations to a X do 50 i = 1, m X do 50 j = 1, n X a(i,j) = aorig(i,j) + (-0.5 + rand(seed)) * nea X 50 continue X Xc add perturbations to b in columns colb to n X if (job .eq. 1) then X colb = 1 X elseif (job .eq. 2) then X colb = n - m + 1 X else Xc job .eq. 3 X colb = n + 1 X endif X if (job .eq. 1 .or. job .eq. 2) then X if ( colb .ge. 1) then X do 70 i = 1, m X do 60 j = colb, n X b(i,j) = borig(i,j) + ( -0.5 + rand(seed)) * neb X 60 continue X if (job .eq. 2) then X do 65 j = 1, colb - 1 X b(i,j) = borig(i,j) X 65 continue X endif X 70 continue X else X write(outunit,300) 'wrong dimensions! m,n=', m,n X endif X else X call cmcopy(borig, ldab, m, n, b) X endif Xc compute and norm(a,e),norm(b,e) Xc X if (nostat) then X nea = cnorm(a,ldab,m,n,0,work) X neb = cnorm(b,ldab,m,n,0,work) X write(outunit,350) 'epsbnd=', epsbnd X write(outunit,350) 'norm(aper,e)=', nea, 'norm(bper,e)=', neb X endif Xc Xc copy a and b to acopy and bcopy, respectively Xc X call cmcopy(a,ldab,m,n,acopy) X call cmcopy(b,ldab,m,n,bcopy) Xc X if (idbg(11) .gt. 0) then X call cmatpr(a,ldab,m,n,' perturbed a for input to guptri') X call cmatpr(b,ldab,m,n,' perturbed b for input to guptri') X endif X return Xc X 100 format(2i4) X 300 format(t5,a,2i5) X 350 format(t5,a,d12.5,tr5,a,d12.5,tr5,a,d12.5) X end Xc X subroutine cmcopy(a,lda,m,n,acopy) Xc implicit none X integer lda,m,n X complex*16 a(lda,1),acopy(lda,1) Xc Xc*** the routine cmcopy copies matrix a to acopy Xc X integer i,j Xc X do 10 i = 1, m X do 10 j =1, n X acopy(i,j) = a(i,j) X 10 continue Xc X return X end Xc X real*8 function cdife(a,b,ldab,m,n) Xc implicit none X integer ldab, m, n X complex*16 a(ldab,*), b(ldab,*), z Xc Xc**** the routine computes the frobenius norm of the Xc difference between a and b Xc X integer i,j X real*8 sum Xc X sum=0.0 X do 10 i = 1, m X do 5 j = 1, n X z=a(i,j)-b(i,j) X sum=sum+dreal(z)**2 + dimag(z)**2 X 5 continue X 10 continue X cdife = sqrt(sum) X return X end Xc X real*8 function cnorm(a,lda,m,n,job,work) Xc Xc implicit none Xc X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer lda,m,n,job X complex*16 a(lda,1),work(1) Xc X integer joba, info, ss, se, sx, sw, i, j X complex*16 u,v Xc X if (job .eq. 2) then Xc compute the 2-norm Xc allocate space for s(min(m+1,n)),e(n) and x(lda,n) X ss = 1 X se = ss + min(m+1,n) X sx = se + n X sw = sx + lda*n X call cmcopy(a,lda,m,n,work(sx)) X joba = 00 X call zsvdc(work(sx),lda,m,n,work(ss),work(se), X * u,1,v,1,work(sw),joba,info) X if (info .ne. 0) then X write(outunit,100) X + 'csvdc did not converge, called from cnorm' X 100 format(t5,a/) X call cmatpr(work(ss),1,1,n, X * 'singular values - main diagonal') X call cmatpr(work(se),1,1,n, X * 'sub-diagonal - should be zero') X else Xc = s(1) X cnorm = work(ss) X endif Xc ( info .eq. 2) X else Xc (job .eq. 0), compute the frobenius norm X cnorm = 0.0 X do 20 i = 1,m X do 20 j = 1,n X cnorm = cnorm + conjg(a(i,j)) * a(i,j) X 20 continue X cnorm = sqrt(cnorm) X endif Xc ( job .eq. 2) X return X end Xc X X real*8 function cond(a,lda,m,n,work) Xc Xc implicit none Xc X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer lda,m,n X complex*16 a(lda,1),work(1) Xc X integer joba, info, nn, ss, se, sx, sw X complex*16 u, v Xc Xc allocate space for s(min(m+1,n)),e(n) and x(lda,n) X ss = 1 X se = ss + min(m+1,n) X sx = se + n X sw = sx + lda*n X call cmcopy(a,lda,m,n,work(sx)) X joba = 00 X call zsvdc(work(sx),lda,m,n,work(ss),work(se), X * u,1,v,1,work(sw),joba,info) Xc X if (info .ne. 0) then X write(outunit,100) X + 'csvdc did not converge, called from cond' X 100 format(t5,a/) X call cmatpr(work(ss),1,1,n, X * 'singular values - main diagonal') X call cmatpr(work(se),1,1,n, X * 'sub-diagonal - should be zero') X else X nn = min(m,n) X if (work(nn) .eq. (0.,0.)) then X cond = 0.0 X write(outunit,100) X + 'cond = the matrix is singular' X else X cond = dreal(work(ss)/work(nn)) Xc s(1)/s(nn)) X endif X endif X return X end X X X subroutine cmatpr(a,lda,m,n,text) Xc implicit none Xc X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer lda,m,n, k X complex*16 a(lda,*) X character*(*) text Xc X write(outunit, 300) 'lda=',lda, 'm=', m, 'n=', n X 300 format(3(5x,a,i3)) X write(outunit,100)text X 100 format(t5,a) X write(outunit,200) ('-',k=1,70) X 200 format(t5,70a) Xc X if (lda .eq. 1) then X call matblk1(a,lda,1,1,1,n) X else X call matblk1(a,lda,1,m,1,n) X endif X return X end Xc X subroutine matblk1(a,lda,rf,rs,kf,ks) Xc implicit none Xc X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer lda, rf, rs, kf, ks X real*8 a(2,lda,*) Xc X integer tpr,blk,ifirst,bl,ilast,i,j,k,l X real*8 aim Xc Xc tpr is the number of elements per output-row Xc Xc is a real or complex ? yes if aim = 0.d0 X aim = 0.d0 X do 20 i = rf, rs X do 10 j = kf, ks X if (a(2,i,j) .ne. 0.0d0) aim = 1. X 10 continue X 20 continue X tpr = 3 X blk = (ks - kf) / tpr + 1 X ifirst = kf X do 40 bl = 1, blk X if (bl .ne. blk) then X ilast = ifirst + tpr - 1 X else X ilast = ks X endif X do 30 k = rf, rs X if ( aim .eq. 0.d0) then Xc a is real X write(outunit,50) (a(1,k,i), i=ifirst, ilast) X else Xc a is complex X do 25 l = 1, 2 X write(outunit,50) (a(l,k,i), i=ifirst, ilast) X 25 continue X write(outunit,60) X endif X 30 continue X ifirst = ifirst +tpr X write(outunit,60) X 40 continue X return Xc X 50 format(t3,3d24.17) X 60 format(/) X end END_OF_zmiscl.f if test 11447 -ne `wc -c zqz.f <<'END_OF_zqz.f' Xc File zqz.for contains: zqz, rcopy, icopy, ricopy, Xc zqzhs1, zqzvl1 Xc Date: 12 june, 1987 Xc X subroutine zqz(a, b, ldab, dimreg, rowb, colb, q, ldq, X * ph, ldp, ierr, work) Xc Xc implicit none Xc Xc**** debug space X common/debug2/ idbg(20), outunit X integer idbg, outunit X logical ldebug Xc Xc**** formal parameter declarations X integer ldab, dimreg, rowb, colb, ldq, ldp, ierr X complex*16 a(ldab,*), b(ldab,*), q(ldq,*), ph(ldp,*) X complex*16 work(*) Xc Xc********************************************************************* Xc Xc this routine reduces the remaining regular part (corresponding to Xc the nonzero and finite eigenvalues) to upper Xc triangular form by using the qz algorithm. Xc this routine is necessary since there is no complex*16 Xc version of the qz-routine in eispack or linpack. Xc Xc on entry Xc Xc a complex*16(ldab,*), where ldab >= dimreg Xc Xc b complex*16(ldab,*) Xc Xc ldab integer Xc leading dimension of the arrays a and b Xc Xc dimreg integer Xc dimension of the remaining regular part Xc Xc rowb integer Xc first row in a and b of remaining regular part Xc Xc colb integer Xc first column in a and b of remaining regular part Xc Xc ldq integer Xc leading dimension of the array q Xc Xc ldp integer Xc leading dimension of the array p Xc Xc work complex*16(2*dimreg*dimreg+4 + 3*dimreg) Xc scratch array Xc Xc idbg(12) integer Xc if nonzero, turn on debug output Xc Xc on exit Xc Xc a changed, contains the upper triangular a-part of the Xc qz-decomposition Xc Xc b changed, contains the upper triangular b-part of the Xc qz-decomposition Xc Xc q complex*16(ldq,*), where ldq >= dimreg Xc right transformation matrix Xc Xc ph complex*16(ldp,*), where ldp >= dimreg Xc conjugate transpose of the left transformation matrix Xc Xc ierr integer Xc error messages from qz-algorithm Xc zero for normal return Xc nonzero if eigenvalue has not converged in 50 iterations Xc (for more details see routine zqzvl1) Xc Xc********************************************************************* Xc Xc this version dated june 10, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** zqz uses the following functions and subroutines Xc Xc cmatpr, icopy, rcopy, ricopy, zqzhs1, zqzvl1 Xc Xc**** internal variables Xc X integer dimsqr, strtar, strtai, strtbr, strtbi X integer j X integer alfarb, alfaib, betab Xc X ldebug = idbg(12) .ne. 0 Xc Xc**** reduce the pencil a(rowb:rowb+dimreg-1,colb:colb+dimreg-1) Xc - lambda b(rowb:rowb+dimreg-1,colb:colb+dimreg-1) Xc to upper triangular form with the qz algorithm Xc copy a, b to separate arrays for real and imaginary parts in Xc preparation for using zqzhs1, zqzvl1 Xc X dimsqr = dimreg * dimreg / 2 + 1 X strtar = 1 X strtai = strtar + dimsqr X strtbr = strtai + dimsqr X strtbi = strtbr + dimsqr X alfarb = strtbi + dimsqr X alfaib = alfarb + dimreg X betab = alfaib + dimreg X call rcopy(a(rowb,colb), ldab, dimreg, work(strtar)) X call icopy(a(rowb,colb), ldab, dimreg, work(strtai)) X call rcopy(b(rowb,colb), ldab, dimreg, work(strtbr)) X call icopy(b(rowb,colb), ldab, dimreg, work(strtbi)) Xc X if (ldebug) then X write(outunit,100) 'entering qz' X write(outunit,100) 'ldab=',ldab,'dimreg=',dimreg, X + 'rowb=',rowb,'colb=',colb, X + 'ldq=',ldq,'ldp=',ldp, X + 'dimsrq=',dimsqr,'strtar=',strtar, X + 'strtai=',strtai,'strtbr=',strtbr, X + 'strtbi=',strtbi,'alfarb=',alfarb, X + 'alfaib=',alfaib,'betab=',betab X100 format(3x,a,1x,i4) X write(outunit,100) 'areal' X write(outunit,101) (work(strtar-1+j),j=1,dimsqr) X write(outunit,100) 'aimag' X write(outunit,101) (work(strtai-1+j),j=1,dimsqr) X write(outunit,100) 'breal' X write(outunit,101) (work(strtbr-1+j),j=1,dimsqr) X write(outunit,100) 'bimag' X write(outunit,101) (work(strtbi-1+j),j=1,dimsqr) X101 format(3d23.16) X endif X call zqzhs1(dimreg, dimreg, work(strtar),work(strtai), X * work(strtbr),work(strtbi), X * .true., q, ldq, .true., ph, ldp ) Xc X if (ldebug) then X write(outunit,100) 'after zqzhs1' X write(outunit,100) 'areal' X write(outunit,101) (work(strtar-1+j),j=1,dimsqr) X write(outunit,100) 'aimag' X write(outunit,101) (work(strtai-1+j),j=1,dimsqr) X write(outunit,100) 'breal' X write(outunit,101) (work(strtbr-1+j),j=1,dimsqr) X write(outunit,100) 'bimag' X write(outunit,101) (work(strtbi-1+j),j=1,dimsqr) X call cmatpr(q,ldq,dimreg,dimreg,'q after zqzhs1') X call cmatpr(ph,ldp,dimreg,dimreg,'ph after zqzhs1') X endif Xc X call zqzvl1(dimreg, dimreg, work(strtar),work(strtai), X * work(strtbr),work(strtbi), X * 0.0d0, work(alfarb), work(alfaib), work(betab), X * .true., q, ldq, .true., ph, ldp, ierr) Xc X if (ldebug) then X write(outunit,100) 'after zqzvl1, ierr=',ierr X write(outunit,100) 'areal' X write(outunit,101) (work(strtar-1+j),j=1,dimsqr) X write(outunit,100) 'aimag' X write(outunit,101) (work(strtai-1+j),j=1,dimsqr) X write(outunit,100) 'breal' X write(outunit,101) (work(strtbr-1+j),j=1,dimsqr) X write(outunit,100) 'bimag' X write(outunit,101) (work(strtbi-1+j),j=1,dimsqr) X write(outunit,100) 'alfarb' X write(outunit,101) (work(alfarb-1+j),j=1,dimreg) X write(outunit,100) 'alfaib' X write(outunit,101) (work(alfaib-1+j),j=1,dimreg) X write(outunit,100) 'betab' X write(outunit,101) (work(betab-1+j),j=1,dimreg) X call cmatpr(q,ldq,dimreg,dimreg,'q after zqzvl1') X call cmatpr(ph,ldp,dimreg,dimreg,'ph after zqzvl1') X endif Xc Xc if (idbg(2) .gt. 1) then Xc call cmatpr(q,ldq,dimreg,dimreg,'q from qz') Xc call cmatpr(ph,ldp,dimreg,dimreg,'ph from qz') Xc endif X if (ierr.ne.0) return Xc Xc copy the real and imaginary parts of the qz-decomposition Xc to a and b, respectively Xc X call ricopy(a(rowb,colb), ldab, dimreg, work(strtar), X * work(strtai)) X call ricopy(b(rowb,colb), ldab, dimreg, work(strtbr), X * work(strtbi)) Xc X if (ldebug) then X call cmatpr(a(rowb,colb),ldab,dimreg,dimreg,'a after qz') X call cmatpr(b(rowb,colb),ldab,dimreg,dimreg,'b after qz') X endif X return X end X X subroutine rcopy(a, lda, dimreg, acopy) Xc implicit none Xc Xc**** formal parameter declarations X integer lda, dimreg X complex*16 a(lda,*) X real*8 acopy(*) Xc Xc*** copy the real parts of a to the real vector acopy Xc Xc this version dated june 10, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc*** internal variables X integer i, j Xc X do 20 i = 1, dimreg X do 10 j = 1, dimreg X acopy(i + (j - 1) * dimreg) = dreal(a(i,j)) X 10 continue X 20 continue X return X end X X subroutine icopy(a, lda, dimreg, acopy) Xc implicit none Xc**** formal parameter declarations X integer lda, dimreg X complex*16 a(lda,*) X real*8 acopy(*) Xc Xc*** copy the imaginary parts of a to the real vector acopy Xc Xc this version dated june 10, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc*** internal variables Xc X integer i, j X do 20 i = 1, dimreg X do 10 j = 1, dimreg X acopy(i + (j - 1) * dimreg) = dimag(a(i,j)) X 10 continue X 20 continue X return X end X X subroutine ricopy(a, lda, dimreg, arcopy, aicopy) Xc implicit none Xc Xc**** formal parameter declarations X integer lda, dimreg X complex*16 a(lda,*) X real*8 arcopy(*), aicopy(*) Xc Xc*** copy arcopy and aicopy to the real and imaginary parts of a, Xc respectively Xc Xc this version dated june 10, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc*** internal variables Xc X integer i, j X do 20 i = 1, dimreg X do 10 j = 1, dimreg X a(i,j) = dcmplx(arcopy(i + (j - 1) * dimreg), X * aicopy(i + (j - 1) * dimreg)) X 10 continue X 20 continue X return X end X Xc Xc ------------------------------------------------------------------ Xc X subroutine zqzhs1(nm,n,ar,ai,br,bi,matz,z,ldz,matzl,zl,ldzl) Xc Xc Xc modified by demmel,6/23/86 to compute left, right transformations Xc in complex arithmetic Xc X integer i,j,k,l,n,k1,lb,l1,nm,nk1,nm1 X real*8 ar(nm,n),ai(nm,n),br(nm,n),bi(nm,n) X complex*16 z(ldz,*),zl(ldzl,*) X complex*16 zu,tz,zll,zll1 X real*8 r,s,t,ti,u1,u2,xi,xr,yi,yr,rho,u1i X logical matz,matzl Xc Xc this subroutine is a complex analogue of the first step of the Xc qz algorithm for solving generalized matrix eigenvalue problems, Xc siam j. numer. anal. 10, 241-256(1973) by moler and stewart. Xc Xc this subroutine accepts a pair of complex general matrices and Xc reduces one of them to upper hessenberg form with real (and non- Xc negative) subdiagonal elements and the other to upper triangular Xc form using unitary transformations. it is usually followed by Xc cqzval and possibly cqzvec. Xc Xc on input- Xc Xc nm must be set to the row dimension of two-dimensional Xc array parameters as declared in the calling program Xc dimension statement, Xc Xc n is the order of the matrices, Xc Xc a=(ar,ai) contains a complex general matrix, Xc Xc b=(br,bi) contains a complex general matrix, Xc Xc matz should be set to .true. if the right hand transformations Xc are to be accumulated for later use in computing Xc eigenvectors, and to .false. otherwise. Xc Xc matzl same as matz for left hand transformations Xc Xc on output- Xc Xc a has been reduced to upper hessenberg form. the elements Xc below the first subdiagonal have been set to zero, and the Xc subdiagonal elements have been made real (and non-negative), Xc Xc b has been reduced to upper triangular form. the elements Xc below the main diagonal have been set to zero, Xc Xc z contains the product of the right hand Xc transformations if matz has been set to .true. Xc otherwise, z is not referenced. Xc Xc zl same as z for left transformations Xc Xc questions and comments should be directed to b. s. garbow, Xc applied mathematics division, argonne national laboratory Xc Xc ------------------------------------------------------------------ Xc Xc ********** initialize z ********** X if (.not. matz) go to 10 Xc X do 3 i = 1, n Xc X do 2 j = 1, n X z(i,j) = dcmplx(0.0d0,0.0d0) X 2 continue Xc X z(i,i) = dcmplx(1.0d0,0.0d0) X 3 continue Xc Xc ********** initialize zl ********** X if (matzl) then X do 300 i=1,n X do 200 j=1,n X zl(i,j)=0. X200 continue X zl(i,i)=1. X300 continue X endif Xc Xc ********** reduce b to upper triangular form with Xc temporarily real diagonal elements ********** X 10 if (n .le. 1) go to 170 X nm1 = n - 1 Xc X do 100 l = 1, nm1 X l1 = l + 1 X s = 0.0 Xc X do 20 i = l, n X s = s + abs(br(i,l)) + abs(bi(i,l)) X 20 continue Xc X if (s .eq. 0.0) go to 100 X rho = 0.0 Xc X do 25 i = l, n X br(i,l) = br(i,l) / s X bi(i,l) = bi(i,l) / s X rho = rho + br(i,l)**2 + bi(i,l)**2 X 25 continue Xc X r = sqrt(rho) X xr = abs(dcmplx(br(l,l),bi(l,l))) X if (xr .eq. 0.0) go to 27 X rho = rho + xr * r X u1 = -br(l,l) / xr X u1i = -bi(l,l) / xr X yr = r / xr + 1.0 X br(l,l) = yr * br(l,l) X bi(l,l) = yr * bi(l,l) X go to 28 Xc X 27 br(l,l) = r X u1 = -1.0 X u1i = 0.0 Xc X 28 do 50 j = l1, n X t = 0.0 X ti = 0.0 Xc X do 30 i = l, n X t = t + br(i,l) * br(i,j) + bi(i,l) * bi(i,j) X ti = ti + br(i,l) * bi(i,j) - bi(i,l) * br(i,j) X 30 continue Xc X t = t / rho X ti = ti / rho Xc X do 40 i = l, n X br(i,j) = br(i,j) - t * br(i,l) + ti * bi(i,l) X bi(i,j) = bi(i,j) - t * bi(i,l) - ti * br(i,l) X 40 continue Xc X xi = u1 * bi(l,j) - u1i * br(l,j) X br(l,j) = u1 * br(l,j) + u1i * bi(l,j) X bi(l,j) = xi X 50 continue Xc X do 80 j = 1, n X t = 0.0 X ti = 0.0 Xc X do 60 i = l, n X t = t + br(i,l) * ar(i,j) + bi(i,l) * ai(i,j) X ti = ti + br(i,l) * ai(i,j) - bi(i,l) * ar(i,j) X 60 continue Xc X t = t / rho X ti = ti / rho Xc X do 70 i = l, n X ar(i,j) = ar(i,j) - t * br(i,l) + ti * bi(i,l) X ai(i,j) = ai(i,j) - t * bi(i,l) - ti * br(i,l) X 70 continue Xc X xi = u1 * ai(l,j) - u1i * ar(l,j) X ar(l,j) = u1 * ar(l,j) + u1i * ai(l,j) X ai(l,j) = xi Xc Xc update zl X if (matzl) then X t=0. X ti=0. X do 600 i=l,n X t= t + br(i,l)*dreal(zl(i,j)) + bi(i,l)*dimag(zl(i,j)) X ti=ti+ br(i,l)*dimag(zl(i,j))- bi(i,l)*dreal(zl(i,j)) X600 continue X tz=dcmplx(t/rho,ti/rho) X do 700 i=l,n X zl(i,j)=zl(i,j)-tz*dcmplx(br(i,l),bi(i,l)) X700 continue X zl(l,j)=zl(l,j)*dcmplx(u1,-u1i) X endif X80 continue Xc X br(l,l) = r * s X bi(l,l) = 0.0 Xc X do 90 i = l1, n X br(i,l) = 0.0 X bi(i,l) = 0.0 X 90 continue Xc X 100 continue Xc ********** reduce a to upper hessenberg form with real subdiagonal Xc elements, while keeping b triangular ********** X do 160 k = 1, nm1 X k1 = k + 1 Xc ********** set bottom element in k-th column of a real ********** X if (ai(n,k) .eq. 0.0) go to 105 X r = abs(dcmplx(ar(n,k),ai(n,k))) X u1 = ar(n,k) / r X u1i = ai(n,k) / r X ar(n,k) = r X ai(n,k) = 0.0 Xc X do 103 j = k1, n X xi = u1 * ai(n,j) - u1i * ar(n,j) X ar(n,j) = u1 * ar(n,j) + u1i * ai(n,j) X ai(n,j) = xi X 103 continue Xc Xc update zl X if (matzl) then X do 1030 j=1,n X zl(n,j)=zl(n,j)*dcmplx(u1,-u1i) X1030 continue X endif Xc X xi = u1 * bi(n,n) - u1i * br(n,n) X br(n,n) = u1 * br(n,n) + u1i * bi(n,n) X bi(n,n) = xi X 105 if (k .eq. nm1) go to 170 X nk1 = nm1 - k Xc ********** for l=n-1 step -1 until k+1 do -- ********** X do 150 lb = 1, nk1 X l = n - lb X l1 = l + 1 Xc ********** zero a(l+1,k) ********** X s = abs(ar(l,k)) + abs(ai(l,k)) + ar(l1,k) X if (s .eq. 0.0) go to 150 X u1 = ar(l,k) / s X u1i = ai(l,k) / s X u2 = ar(l1,k) / s X r = sqrt(u1*u1+u1i*u1i+u2*u2) X u1 = u1 / r X u1i = u1i / r X u2 = u2 / r X ar(l,k) = r * s X ai(l,k) = 0.0 X ar(l1,k) = 0.0 Xc X do 110 j = k1, n X xr = ar(l,j) X xi = ai(l,j) X yr = ar(l1,j) X yi = ai(l1,j) X ar(l,j) = u1 * xr + u1i * xi + u2 * yr X ai(l,j) = u1 * xi - u1i * xr + u2 * yi X ar(l1,j) = u1 * yr - u1i * yi - u2 * xr X ai(l1,j) = u1 * yi + u1i * yr - u2 * xi X 110 continue Xc Xc update zl X if (matzl) then X zu=dcmplx(u1,-u1i) X do 1100 j=1,n X zll=zl(l,j) X zll1=zl(l1,j) X zl(l,j)= zu*zll+u2*zll1 X zl(l1,j)=conjg(zu)*zll1-u2*zll X1100 continue X endif Xc X xr = br(l,l) X br(l,l) = u1 * xr X bi(l,l) = -u1i * xr X br(l1,l) = -u2 * xr Xc X do 120 j = l1, n X xr = br(l,j) X xi = bi(l,j) X yr = br(l1,j) X yi = bi(l1,j) X br(l,j) = u1 * xr + u1i * xi + u2 * yr X bi(l,j) = u1 * xi - u1i * xr + u2 * yi X br(l1,j) = u1 * yr - u1i * yi - u2 * xr X bi(l1,j) = u1 * yi + u1i * yr - u2 * xi X 120 continue Xc ********** zero b(l+1,l) ********** X s = abs(br(l1,l1)) + abs(bi(l1,l1)) + abs(br(l1,l)) X if (s .eq. 0.0) go to 150 X u1 = br(l1,l1) / s X u1i = bi(l1,l1) / s X u2 = br(l1,l) / s X r = sqrt(u1*u1+u1i*u1i+u2*u2) X u1 = u1 / r X u1i = u1i / r X u2 = u2 / r X br(l1,l1) = r * s X bi(l1,l1) = 0.0 X br(l1,l) = 0.0 Xc X do 130 i = 1, l X xr = br(i,l1) X xi = bi(i,l1) X yr = br(i,l) X yi = bi(i,l) X br(i,l1) = u1 * xr + u1i * xi + u2 * yr X bi(i,l1) = u1 * xi - u1i * xr + u2 * yi X br(i,l) = u1 * yr - u1i * yi - u2 * xr X bi(i,l) = u1 * yi + u1i * yr - u2 * xi X 130 continue Xc X do 140 i = 1, n X xr = ar(i,l1) X xi = ai(i,l1) X yr = ar(i,l) X yi = ai(i,l) X ar(i,l1) = u1 * xr + u1i * xi + u2 * yr X ai(i,l1) = u1 * xi - u1i * xr + u2 * yi X ar(i,l) = u1 * yr - u1i * yi - u2 * xr X ai(i,l) = u1 * yi + u1i * yr - u2 * xi X 140 continue Xc X if (.not. matz) go to 150 Xc X zu=dcmplx(u1,-u1i) X do 145 i = 1, n X zll1=z(i,l1) X zll=z(i,l) X z(i,l1)=zu*zll1+u2*zll X z(i,l)= conjg(zu)*zll-u2*zll1 X 145 continue Xc X 150 continue Xc X 160 continue Xc X 170 return Xc ********** last card of zqzhes ********** X end Xc Xc ------------------------------------------------------------------ Xc X subroutine zqzvl1(nm,n,ar,ai,br,bi,eps1,alfr,alfi,beta, X x matz,z,ldz,matzl,zl,ldzl,ierr) Xc Xc modified by demmel, 6/23/86 to compute left and right Xc transformations using complex arithmetic Xc X integer i,j,k,l,n,en,k1,k2,ll,l1,na,nm,its,km1,lm1, X x enm2,ierr,lor1,enorn X real*8 ar(nm,n),ai(nm,n),br(nm,n),bi(nm,n),alfr(n),alfi(n), X x beta(n) X complex*16 z(ldz,*),zl(ldzl,*) X complex*16 zu,zll,zll1 X real*8 r,s,a1,a2,ep,sh,u1,u2,xi,xr,yi,yr,ani,a1i,a33,a34,a43,a44, X x bni,b11,b33,b44,shi,u1i,a33i,a34i,a43i,a44i,b33i,b44i, X x epsa,epsb,eps1,anorm,bnorm,b3344,b3344i X integer max0 X logical matz,matzl X complex*16 z3 Xc Xc Xc Xc Xc Xc this subroutine is a complex analogue of steps 2 and 3 of the Xc qz algorithm for solving generalized matrix eigenvalue problems, Xc siam j. numer. anal. 10, 241-256(1973) by moler and stewart, Xc as modified in technical note nasa tn e-7305(1973) by ward. Xc Xc this subroutine accepts a pair of complex matrices, one of them Xc in upper hessenberg form and the other in upper triangular form, Xc the hessenberg matrix must further have real subdiagonal elements. Xc it reduces the hessenberg matrix to triangular form using Xc unitary transformations while maintaining the triangular form Xc of the other matrix and further making its diagonal elements Xc real and non-negative. it then returns quantities whose ratios Xc give the generalized eigenvalues. it is usually preceded by Xc cqzhes and possibly followed by cqzvec. Xc Xc on input- Xc Xc nm must be set to the row dimension of two-dimensional Xc array parameters as declared in the calling program Xc dimension statement, Xc Xc n is the order of the matrices, Xc Xc a=(ar,ai) contains a complex upper hessenberg matrix Xc with real subdiagonal elements, Xc Xc b=(br,bi) contains a complex upper triangular matrix, Xc Xc eps1 is a tolerance used to determine negligible elements. Xc eps1 = 0.0 (or negative) may be input, in which case an Xc element will be neglected only if it is less than roundoff Xc error times the norm of its matrix. if the input eps1 is Xc positive, then an element will be considered negligible Xc if it is less than eps1 times the norm of its matrix. a Xc positive value of eps1 may result in faster execution, Xc but less accurate results, Xc Xc matz should be set to .true. if the right hand transformations Xc are to be accumulated for later use in computing Xc eigenvectors, and to .false. otherwise, Xc Xc z=(zr,zi) contains, if matz has been set to .true., the Xc transformation matrix produced in the reduction Xc by cqzhes, if performed, or else the identity matrix. Xc if matz has been set to .false., z is not referenced. Xc Xc on output- Xc Xc a has been reduced to upper triangular form. the elements Xc below the main diagonal have been set to zero, Xc Xc b is still in upper triangular form, although its elements Xc have been altered. in particular, its diagonal has been set Xc real and non-negative. the location br(n,1) is used to Xc store eps1 times the norm of b for later use by cqzvec, Xc Xc alfr and alfi contain the real and imaginary parts of the Xc diagonal elements of the triangularized a matrix, Xc Xc beta contains the real non-negative diagonal elements of the Xc corresponding b. the generalized eigenvalues are then Xc the ratios ((alfr+i*alfi)/beta), Xc Xc z contains the product of the right hand transformations Xc (for both steps) if matz has been set to .true., Xc Xc ierr is set to Xc zero for normal return, Xc j if ar(j,j-1) has not become Xc zero after 50 iterations. Xc Xc questions and comments should be directed to b. s. garbow, Xc applied mathematics division, argonne national laboratory Xc Xc ------------------------------------------------------------------ Xc X ierr = 0 Xc ********** compute epsa,epsb ********** X anorm = 0.0 X bnorm = 0.0 Xc X do 30 i = 1, n X ani = 0.0 X if (i .ne. 1) ani = abs(ar(i,i-1)) X bni = 0.0 Xc X do 20 j = i, n X ani = ani + abs(ar(i,j)) + abs(ai(i,j)) X bni = bni + abs(br(i,j)) + abs(bi(i,j)) X 20 continue Xc X if (ani .gt. anorm) anorm = ani X if (bni .gt. bnorm) bnorm = bni X 30 continue Xc X if (anorm .eq. 0.0) anorm = 1.0 X if (bnorm .eq. 0.0) bnorm = 1.0 X ep = eps1 X if (ep .gt. 0.0) go to 50 Xc ********** compute roundoff level if eps1 is zero ********** X ep = 1.0d0 X 40 ep = ep / 2.0d0 X if (1.0d0 + ep .gt. 1.0d0) go to 40 X 50 epsa = ep * anorm X epsb = ep * bnorm Xc ********** reduce a to triangular form, while Xc keeping b triangular ********** X lor1 = 1 X enorn = n X en = n Xc ********** begin qz step ********** X 60 if (en .eq. 0) go to 1001 X if (.not. matz) enorn = en X its = 0 X na = en - 1 X enm2 = na - 1 Xc ********** check for convergence or reducibility. Xc for l=en step -1 until 1 do -- ********** X 70 do 80 ll = 1, en X lm1 = en - ll X l = lm1 + 1 X if (l .eq. 1) go to 95 X if (abs(ar(l,lm1)) .le. epsa) go to 90 X 80 continue Xc X 90 ar(l,lm1) = 0.0 Xc ********** set diagonal element at top of b real ********** X 95 b11 = abs(dcmplx(br(l,l),bi(l,l))) X if (b11 .eq. 0.0) go to 98 X u1 = br(l,l) / b11 X u1i = bi(l,l) / b11 Xc X do 97 j = l, enorn X xi = u1 * ai(l,j) - u1i * ar(l,j) X ar(l,j) = u1 * ar(l,j) + u1i * ai(l,j) X ai(l,j) = xi X xi = u1 * bi(l,j) - u1i * br(l,j) X br(l,j) = u1 * br(l,j) + u1i * bi(l,j) X bi(l,j) = xi X 97 continue Xc Xc update zl X if (matzl) then X do 970 j=1,n X zl(l,j)=zl(l,j)*dcmplx(u1,-u1i) X970 continue X endif Xc X bi(l,l) = 0.0 X 98 if (l .ne. en) go to 100 Xc ********** 1-by-1 block isolated ********** X alfr(en) = ar(en,en) X alfi(en) = ai(en,en) X beta(en) = b11 X en = na X go to 60 Xc ********** check for small top of b ********** X 100 l1 = l + 1 X if (b11 .gt. epsb) go to 120 X br(l,l) = 0.0 X s = abs(ar(l,l)) + abs(ai(l,l)) + abs(ar(l1,l)) X u1 = ar(l,l) / s X u1i = ai(l,l) / s X u2 = ar(l1,l) / s X r = sqrt(u1*u1+u1i*u1i+u2*u2) X u1 = u1 / r X u1i = u1i / r X u2 = u2 / r X ar(l,l) = r * s X ai(l,l) = 0.0 Xc X do 110 j = l1, enorn X xr = ar(l,j) X xi = ai(l,j) X yr = ar(l1,j) X yi = ai(l1,j) X ar(l,j) = u1 * xr + u1i * xi + u2 * yr X ai(l,j) = u1 * xi - u1i * xr + u2 * yi X ar(l1,j) = u1 * yr - u1i * yi - u2 * xr X ai(l1,j) = u1 * yi + u1i * yr - u2 * xi X xr = br(l,j) X xi = bi(l,j) X yr = br(l1,j) X yi = bi(l1,j) X br(l1,j) = u1 * yr - u1i * yi - u2 * xr X br(l,j) = u1 * xr + u1i * xi + u2 * yr X bi(l,j) = u1 * xi - u1i * xr + u2 * yi X bi(l1,j) = u1 * yi + u1i * yr - u2 * xi X 110 continue Xc Xc update zl X if (matzl) then X zu=dcmplx(u1,-u1i) X do 1110 j=1,n X zll=zl(l,j) X zll1=zl(l1,j) X zl(l,j)=zll*zu+zll1*u2 X zl(l1,j)=zll1*conjg(zu)-zll*u2 X1110 continue X endif Xc X lm1 = l X l = l1 X go to 90 Xc ********** iteration strategy ********** X 120 if (its .eq. 50) go to 1000 X if (its .eq. 10) go to 135 Xc ********** determine shift ********** X b33 = br(na,na) X b33i = bi(na,na) X if (abs(dcmplx(b33,b33i)) .ge. epsb) go to 122 X b33 = epsb X b33i = 0.0 X 122 b44 = br(en,en) X b44i = bi(en,en) X if (abs(dcmplx(b44,b44i)) .ge. epsb) go to 124 X b44 = epsb X b44i = 0.0 X 124 b3344 = b33 * b44 - b33i * b44i X b3344i = b33 * b44i + b33i * b44 X a33 = ar(na,na) * b44 - ai(na,na) * b44i X a33i = ar(na,na) * b44i + ai(na,na) * b44 X a34 = ar(na,en) * b33 - ai(na,en) * b33i X x - ar(na,na) * br(na,en) + ai(na,na) * bi(na,en) X a34i = ar(na,en) * b33i + ai(na,en) * b33 X x - ar(na,na) * bi(na,en) - ai(na,na) * br(na,en) X a43 = ar(en,na) * b44 X a43i = ar(en,na) * b44i X a44 = ar(en,en) * b33 - ai(en,en) * b33i - ar(en,na) * br(na,en) X a44i = ar(en,en) * b33i + ai(en,en) * b33 - ar(en,na) * bi(na,en) X sh = a44 X shi = a44i X xr = a34 * a43 - a34i * a43i X xi = a34 * a43i + a34i * a43 X if (xr .eq. 0.0 .and. xi .eq. 0.0) go to 140 X yr = (a33 - sh) / 2.0 X yi = (a33i - shi) / 2.0 X z3 = sqrt(dcmplx(yr**2-yi**2+xr,2.0*yr*yi+xi)) X u1 = dreal(z3) X u1i = dimag(z3) X if (yr * u1 + yi * u1i .ge. 0.0) go to 125 X u1 = -u1 X u1i = -u1i X 125 z3 = (dcmplx(sh,shi) - dcmplx(xr,xi) / dcmplx(yr+u1,yi+u1i)) X x / dcmplx(b3344,b3344i) X sh = dreal(z3) X shi = dimag(z3) X go to 140 Xc ********** ad hoc shift ********** X 135 sh = ar(en,na) + ar(na,enm2) X shi = 0.0 Xc ********** determine zeroth column of a ********** X 140 a1 = ar(l,l) / b11 - sh X a1i = ai(l,l) / b11 - shi X a2 = ar(l1,l) / b11 X its = its + 1 X if (.not. matz) lor1 = l Xc ********** main loop ********** X do 260 k = l, na X k1 = k + 1 X k2 = k + 2 X km1 = max0(k-1,l) Xc ********** zero a(k+1,k-1) ********** X if (k .eq. l) go to 170 X a1 = ar(k,km1) X a1i = ai(k,km1) X a2 = ar(k1,km1) X 170 s = abs(a1) + abs(a1i) + abs(a2) X u1 = a1 / s X u1i = a1i / s X u2 = a2 / s X r = sqrt(u1*u1+u1i*u1i+u2*u2) X u1 = u1 / r X u1i = u1i / r X u2 = u2 / r Xc X do 180 j = km1, enorn X xr = ar(k,j) X xi = ai(k,j) X yr = ar(k1,j) X yi = ai(k1,j) X ar(k,j) = u1 * xr + u1i * xi + u2 * yr X ai(k,j) = u1 * xi - u1i * xr + u2 * yi X ar(k1,j) = u1 * yr - u1i * yi - u2 * xr X ai(k1,j) = u1 * yi + u1i * yr - u2 * xi X xr = br(k,j) X xi = bi(k,j) X yr = br(k1,j) X yi = bi(k1,j) X br(k,j) = u1 * xr + u1i * xi + u2 * yr X bi(k,j) = u1 * xi - u1i * xr + u2 * yi X br(k1,j) = u1 * yr - u1i * yi - u2 * xr X bi(k1,j) = u1 * yi + u1i * yr - u2 * xi X 180 continue Xc Xc update zl X if (matzl) then X zu=dcmplx(u1,-u1i) X do 1800 j=1,n X zll=zl(k,j) X zll1=zl(k1,j) X zl(k,j)=zu*zll+u2*zll1 X zl(k1,j)=conjg(zu)*zll1-u2*zll X1800 continue X endif Xc X if (k .eq. l) go to 240 X ai(k,km1) = 0.0 X ar(k1,km1) = 0.0 X ai(k1,km1) = 0.0 Xc ********** zero b(k+1,k) ********** X 240 s = abs(br(k1,k1)) + abs(bi(k1,k1)) + abs(br(k1,k)) X u1 = br(k1,k1) / s X u1i = bi(k1,k1) / s X u2 = br(k1,k) / s X r = sqrt(u1*u1+u1i*u1i+u2*u2) X u1 = u1 / r X u1i = u1i / r X u2 = u2 / r X if (k .eq. na) go to 245 X xr = ar(k2,k1) X ar(k2,k1) = u1 * xr X ai(k2,k1) = -u1i * xr X ar(k2,k) = -u2 * xr Xc X 245 do 250 i = lor1, k1 X xr = ar(i,k1) X xi = ai(i,k1) X yr = ar(i,k) X yi = ai(i,k) X ar(i,k1) = u1 * xr + u1i * xi + u2 * yr X ai(i,k1) = u1 * xi - u1i * xr + u2 * yi X ar(i,k) = u1 * yr - u1i * yi - u2 * xr X ai(i,k) = u1 * yi + u1i * yr - u2 * xi X xr = br(i,k1) X xi = bi(i,k1) X yr = br(i,k) X yi = bi(i,k) X br(i,k1) = u1 * xr + u1i * xi + u2 * yr X bi(i,k1) = u1 * xi - u1i * xr + u2 * yi X br(i,k) = u1 * yr - u1i * yi - u2 * xr X bi(i,k) = u1 * yi + u1i * yr - u2 * xi X 250 continue Xc X bi(k1,k1) = 0.0 X br(k1,k) = 0.0 X bi(k1,k) = 0.0 X if (.not. matz) go to 260 Xc X zu=dcmplx(u1,-u1i) X do 255 i = 1, n X zll=z(i,k) X zll1=z(i,k1) X z(i,k)=conjg(zu)*zll-u2*zll1 X z(i,k1)=zu*zll1+u2*zll X 255 continue Xc X 260 continue Xc ********** set last a subdiagonal real and end qz step ********** X if (ai(en,na) .eq. 0.0) go to 70 X r = abs(dcmplx(ar(en,na),ai(en,na))) X u1 = ar(en,na) / r X u1i = ai(en,na) / r X ar(en,na) = r X ai(en,na) = 0.0 Xc X do 270 j = en, enorn X xi = u1 * ai(en,j) - u1i * ar(en,j) X ar(en,j) = u1 * ar(en,j) + u1i * ai(en,j) X ai(en,j) = xi X xi = u1 * bi(en,j) - u1i * br(en,j) X br(en,j) = u1 * br(en,j) + u1i * bi(en,j) X bi(en,j) = xi X 270 continue Xc Xc update zl X if (matzl) then X zu=dcmplx(u1,-u1i) X do 2700 j=1,n X zl(en,j)=zu*zl(en,j) X2700 continue X endif Xc X go to 70 Xc ********** set error -- bottom subdiagonal element has not Xc become negligible after 50 iterations ********** X 1000 ierr = en Xc ********** save epsb for use by cqzvec ********** X 1001 if (n .gt. 1) br(n,1) = 0. Xc if (n .gt. 1) br(n,1) = epsb X return Xc ********** last card of zqzval ********** X end X END_OF_zqz.f if test 32062 -ne `wc -c zrcsvdc.f <<'END_OF_zrcsvdc.f' X X subroutine rcsvdc(x, ldx, m, n, s, e, u, ldu, v, ldv, X * opt, epsu, gap, cnull, rnull, del, X * work, job, info) Xc Xc implicit none Xc**** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc Xc**** formal parameter declarations X integer ldx,m,n,ldu,ldv,cnull,rnull,job,info X real*8 epsu, gap, del X complex*16 x(ldx,n),s(m),e(m),u(ldu,1),v(ldv,n),work(n) X character*(*) opt Xc Xc********************************************************************* Xc Xc rcsvdc computes the singular value decomposition (svd) Xc of a m by n matrix x, and its numerical column and row Xc nullities, respectively. the diagonal elements s(i) are Xc the singular values. the user controls the ordering and Xc the placing of the singular values. Xc the columns of the unitary matrices u and v correspond Xc to the left and right singular vectors, respectively. Xc Xc on entry Xc Xc x complex(ldx,n), where ldx>=m. Xc Xc ldx integer Xc ldx is the leading dimension of the array x. Xc Xc m integer Xc m is the number of rows of x. Xc Xc n integer Xc n is the number of columns of x. Xc Xc ldu integer Xc ldu is the leading dimension of the array u. Xc Xc ldv integer Xc ldv is the leading dimension of the array v. Xc Xc work complex(n) Xc work is a scratch array. Xc Xc job integer Xc job controls the computations to be done. it has Xc the decimal expansion abcd with the following Xc meaning Xc a=0 do not compute the left singular vectors. Xc a=1 return the m left singular vextors in u. Xc a=2 return the first min(m,n) left singular Xc vectors in u. Xc b=0 do not compute the right singular vectors. Xc b=1 return the right singular vectors in v. Xc c=0 singular values are ordered in decreasing Xc order. Xc c=1 singular values are ordered in increasing Xc order. Xc d=0 diagonal of singular values starts in Xc position (1,1). Xc d=1 diagonal of singular values ends in Xc position (m,n). Xc Xc on return Xc Xc s complex(mm), where mm=min(m+1,n). ?????? Xc the first min(m,n) entries of s contain the Xc singular values of x. Xc Xc e complex(m) Xc e contains the subdiagonal from computing Xc the svd. should ordinarily be zeros. Xc Xc u complex(ldu,k), where ldu>=m. Xc if joba=1 then k=m, if joba=2 then k=min(m,n). Xc u contains the matrix of left singular Xc vectors of x. Xc u is not referenced if joba=0. if m<=n or if Xc joba=2, then u may be identified with x in the Xc subroutine call. Xc Xc v complex(ldv,n), where ldv>=n. Xc v contains the matrix of right singular Xc vectors of x. Xc v is not referenced if jobb=0. if n<=m, Xc then v may be identified with x in the Xc subroutine call. Xc Xc cnull integer Xc cnull contains the numerical column nullity of x. Xc Xc rnull integer Xc rnull contains the numerical row nullity of x. Xc Xc del real*8 Xc del contains the squareroot of the sum of the Xc squares of the singular values interpreted as zeros. Xc Xc info integer Xc info tells the user what has been done. Xc info=0, all the singular values and Xc vectors are correct. if info .ne.o, then Xc cnull, rnull and del contain no meaningful Xc information. for more details see the Xc linpack routine csvdc. Xc Xc******************************************************************** Xc Xc this version dated june 13, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc***** rcsvdc uses the following functions and subroutines Xc Xc linpack zsvdc Xc blas zswap Xc Xc***** internal variables Xc Xc Xc*** if idbg(6) .eq. 0 then debug output is switched off Xc on input info contains the product of the row and Xc column dimensions of the original a and b Xc X integer jobu, ncu, jobx, nsvd, i, j, n1, mn, mpn, k X logical wantu, wantv, incr, posmn, ldebug X real*8 t1, t2 X complex*16 cell Xc Xc save m*n (=info) in mpn X mpn = info Xc Xc***** determine what is to be computed X ldebug = idbg(6) .ne. 0 X jobu = job/1000 X wantu = jobu .ne. 0 Xc Xc ncu is the number of columns in u X ncu = m X if (jobu .eq. 2) ncu = min0(m,n) X wantv = mod(job,1000)/100 .ne. 0 X incr = mod(job,100)/10 .ne. 0 X posmn = mod(job,10) .ne. 0 Xc Xc***** compute the svd of x Xc singular values in decraesing order Xc X jobx = job/100 X call zsvdc(x,ldx,m,n,s,e,u,ldu,v,ldv,work,jobx,info) Xc**** 6/18/87 Xc if( info .ne. 0)return X if (info .ne. 0) then X if (ldebug) write(outunit,101) info X 101 format('rcsvdc - after zsvd, info= ',i4) X return X endif Xc Xc***** compute the column and row nullities of x Xc n1 = number of singular values interpreted as zeros Xc Xc we seek n1 so that Xc s(nsvd-n1) >= t2 > t1 >= s(nsvd-n1+1 ) Xc if this relation does not hold n1 is decreased by one Xc until we have a gap t2/t1 (=gap) between the singular Xc values we interpret as zeros and the others. Xc***** works only if singular values in increasing order Xc X t1 = epsu X t2 = gap * t1 X if (ldebug) then X write(outunit,100) 't1= ', t1, 't2= ', t2 X 100 format(t5,a,d12.5,tr5,a,d12.5) X endif Xc X X nsvd = min0(m,n) Xc Xc**** shall we compute cnull and rnull or not? Xc X if (opt .eq. 'cind') then Xc Xc**** note that if only one singular value then we interpret it Xc as zero if it is less than t2 X if (nsvd .eq. 1) then X n1 = 0 X if ( abs(s(1)) .le. t2 ) n1 = 1 X else Xc X do 20 i = nsvd, 1 , -1 X if (abs(s(i)) .ge. t1) go to 25 X 20 continue X n1 = nsvd X go to 35 X 25 continue X if ( i .ge. 1) then X if (abs(s(i)) .gt. t2) go to 30 X i = i - 1 X go to 25 X endif X 30 continue X n1 = nsvd - i X endif X 35 continue Xc X if ( m .ge. n ) then X cnull = n1 X rnull = (m - n) + n1 X else X cnull = (n - m) + n1 X rnull = n1 X endif X else Xc Xc cnull and rnull are alreday known from earlier computations X if ( m.ge. n) then X n1 = cnull X else X n1 = cnull - (n -m) X endif X endif X del = 0. X do 40 i = nsvd, (nsvd - n1 + 1), -1 Xc* accumulate square root of sum of squares X call upddel(del, abs(s(i))) X 40 continue Xc X if (incr) then Xc Xc reorder the singular values (and the corresponding vectors) Xc into increasing order Xc X do 50 i = 1, nsvd/2 X j = nsvd - i + 1 X if (wantu) X * call zswap(m,u(1,i),1,u(1,j),1) X if (wantv) X * call zswap(n,v(1,i),1,v(1,j),1) X cell = s(i) X s(i) = s(j) X s(j) = cell X 50 continue X endif Xc** incr X if (posmn) then Xc Xc move the columns of u and v, such that the diagonal of Xc singular values (of u'*x*v where '=transpose conjugate) Xc ends at position (m,n) Xc X if ( (jobu .eq. 1) .and. (m .gt. n)) then Xc Xc move the last m-n columns of u to the first positions in u, Xc and adjust the remaining col's accordingly. Xc (remember the case when a=2, ncu= number of col's of u) Xc X mn = m - n X do 70 k = 1, mn X do 70 i = 1, m X cell = u(i,ncu) X do 60 j = ncu, 2, -1 X u(i,j) = u(i,j-1) X 60 continue X u(i,1) = cell X 70 continue X endif Xc** (jobu = 1) X if (wantv .and. (m .lt. n)) then Xc Xc move the last n-m columns of v to the first positions in v Xc and adjust the remaining columns accordingly. Xc (n= the of col's of v) Xc X mn = n - m X do 90 k = 1, mn X do 90 i = 1, n X cell = v(i,n) X do 80 j = n, 2, -1 X v(i,j) = v(i,j-1) X 80 continue X v(i,1) = cell X 90 continue X endif Xc** wantv X endif Xc** posmn Xc X return X end X X X END_OF_zrcsvdc.f if test 9358 -ne `wc -c zreorder.f <<'END_OF_zreorder.f' Xc In this file June 13, 1987: reordr, exchng, cgiv, zcsrot Xc Xc X subroutine reordr (a, b, ldab, m, n, rowb, colb, rowe, cole, X * ftest, ndim, ind, pp, ldpp, qq, ldqq) Xc Xc implicit none Xc*** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer ldab, m, n, rowb, colb, rowe, cole, ftest X integer ndim, ind(*), ldpp, ldqq X complex*16 a(ldab,*), b(ldab,*), pp(ldpp,*), qq(ldqq,*) Xc Xc*********************************************************************** Xc given that the specified regular part of a - lambda*b is in Xc upper triangular form reordr reorders the 1 by 1 diagonal blocks Xc (the generalized eigenvalues) by constructing Xc equivalence transformations (pairs of left and right givens Xc transformations). the givens transformations that perform the Xc reordering are accumulated in the left and right transformation Xc matrices pp and qq, respectively. normally pp and qq result Xc from previous reductions or are initialized to the identity Xc matrix before the call. Xc Xc after the reordering the eigenvalues specified by the function Xc ftest (provided by the user) appear at the top north-west corner Xc of the specified regular part of a - lambda*b. Xc if ndim is the number of eigenvalues in the spectrum specified Xc by ftest then the rowb+ndim-1 first columns of pp, and the Xc colb+ndim-1 first columns of qq, respectively, Xc span a pair of reducing subspaces corresponding to this Xc part of the spectrum of a - lambda*b. for algorithmic details of Xc the reordering of eigenvalues see p. van dooren: algorithm 590: Xc dsubsp and exchng, fortran routines for computing deflating Xc subspaces with specified spectrum, acm toms, vol.4, 1982, Xc pp 376-382 Xc Xc if idb(7) .eq. 0 then debug output is switched off Xc Xc**** formal parameters Xc Xc on entry Xc Xc a(ldab,*) complex*16, input matrix a in upper triangular form Xc Xc b(ldab,*) complex*16, input matrix b in upper triangular form Xc Xc ldab integer, leading dimension of a and b Xc Xc m integer, current row dimension of a and b Xc Xc n integer, current column dimension of a and b Xc Xc rowb integer, first row of the regular part of a-lambda*b Xc Xc colb integer, first column of the regular part of a-lambda*b Xc Xc rowe integer, last row of the regular part of a-lambda*b Xc Xc cole integer, last column of the regular part of a-lambda*b Xc Xc ftest(alpha, beta) integer function describing the spectrum Xc of the deflating subspace to be computed. if alpha/beta Xc is in that spectrum then ftest = 1, otherwise ftest = -1. Xc Xc ldpp integer, leading dimension of pp Xc Xc ldqq integer, leading dimension of qq Xc Xc on exit Xc Xc ndim integer, the dimension of the computed pair of Xc deflating subspace Xc Xc ind(*) integer array, working array of dimension at least Xc min(rowe-rowb+1) Xc Xc pp(ldpp,*) complex*16, array, the unitary right hand transformation Xc matrix of order m by m. Xc accumulates all right hand givens transformations. Xc Xc qq(ldqq,*) complex*16, the unitary left hand transformation Xc matrix of order n by n. Xc accumulates all left hand givens transformations. Xc Xc a(ldab,*) in upper tringular form with reordered diagonal Xc elements Xc Xc b(ldab,*) in upper triangular form with reordered diagonal Xc elements Xc note: the reordered eigenvalues are a(i,i)/b(i,i) (see also above) Xc Xcc************************************************************************ Xc Xc**** this version dated 14 june, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** reordr uses the following functions and subroutines Xc cmatpr, exchng Xc ftest (user written) Xc Xc**** internal variables X integer dimr, i, k, j, inside, rfirst, kfirst, jj, nswap X integer indk, ii X logical ldebug Xc Xc set debug flag X ldebug = idbg(7) .ne. 0 Xc X if (ldebug) then X write(outunit, 2005) 'eigenvalues before reordering' X do 770 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X 2005 format(t5,a,4d15.5) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 770 continue X endif Xc*** Xc X dimr = rowe - rowb +1 X if (ldebug) then X write(outunit, 500) 'dimr=', dimr X 500 format(t5,a,i3) X endif Xc X if( dimr .ge. 2) then Xc**** search through the eigenvalues and note down in ind(*) which Xc eigenvalues are in the spectrum determined by ftest Xc X ndim = 0 X dimr = 0 X do 10 i = rowb, rowe X dimr = dimr + 1 X inside = ftest( a(i, colb + dimr - 1), b(i, colb + dimr - 1)) X if ( inside .eq. 1 ) ndim = ndim + 1 X ind(dimr) = inside X 10 continue X if (ldebug) then X write(outunit, 700) 'ind(*) before reordering', X * (ind(i), i = 1, dimr) X 700 format(t5,a,20i3) X endif Xc Xc**** reorder the blocks (eigenvalues) such that those that belong Xc to the specified spectrum appear first at the top north-west corner Xc of the specified regular part of a-lambda*b Xc X do 100 i = 1, dimr X if ( ind(i) .lt. 0) then Xc Xc search for the first block to be moved ( first ind(k) Xc that is positive) X do 60 k = i + 1, dimr X if ( ind(k) .gt. 0) go to 70 X 60 continue Xc no more blocks to test or to move, go to exit X go to 110 X else Xc continue the search X go to 100 X endif Xc Xc make k-i interchanges so that block k appear before block i X 70 continue X nswap = k - i X if (ldebug) write(outunit, 500) 'nswap=',nswap X indk = ind(k) X do 80 j =1, nswap X jj = k - j X rfirst = rowb + i - 1 + nswap - j X kfirst = colb + i - 1 + nswap - j X call exchng(a, b, ldab, m, n, rfirst, kfirst, X * pp, ldpp, qq, ldqq) X ind(jj + 1) = ind(jj) X 80 continue X ind(i) = indk X if (ldebug) then X write(outunit, 700) 'ind(*) after do 80', X * (ind(ii),ii=1,dimr) X endif Xc Xc continue to search for eigenvalues that should be reordered X 100 continue Xc Xc exit X 110 continue X if (ldebug) then X write(outunit, 700) 'final ind(*) from reorder', X * (ind(ii),ii=1,dimr) X endif Xc Xc end of if ( dimr .ge. 2) X endif Xc X if (idbg(2) .gt. 1) then X call cmatpr(qq,ldqq,n,n,'qq after reordr') X call cmatpr(pp,ldpp,m,m,'pp after reordr') X endif Xc X if (ldebug) then X write(outunit, 2005) ' eigenvalues at exit from reordr' X do 75 i = rowb, rowe X j = colb + i - rowb X if (abs(b(i ,j)) .eq. 0. ) then X write(outunit, 2005) 'infinite eigenvalue',a(i,j), b(i,j) X else X write(outunit, 2005) 'eigenvalue=', a(i,j)/b(i,j) X endif X 75 continue X endif Xc X return X end X X subroutine exchng(a, b, ldab, m, n, rowb, colb, X * pp, ldpp, qq, ldqq) Xc Xc implicit none Xc*** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc X integer ldab, m, n, rowb, colb, ldpp, ldqq X complex*16 a(ldab,*), b(ldab,*), pp(ldpp,*), qq(ldqq,*) Xc Xc*********************************************************************** Xc given that the regular part of a - lambda*b is on upper Xc triangular form exchng computes a unitary equivalence Xc transformation that exchanges the 1 by 1 diagonal blocks Xc at positions (rowb, colb) and (rowb+1, colb+1), respectively, Xc along with their generalized eigenvalues. Xc the givens rotations that perform the exchange are Xc accumulated in the left and right transformation matrices Xc pp and qq, respectively. Xc Xc if idbg(8) .eq. 0 then debug output is switched off Xc Xc formal parameters Xc Xc on entry Xc Xc a(ldab,*) complex*16, input matrix a in upper triangular form Xc Xc b(ldab,*) complex*16, input matrix b in upper triangular form Xc Xc ldab integer, leading dimension of a and b Xc Xc m integer, current row dimension of a and b Xc Xc n integer, current column dimension of a and b Xc Xc rowb integer, first row of the regular part of a-lambda*b Xc Xc colb integer, forst column of the regular part of a-lambda*b Xc Xc ldpp integer, leading dimension of pp Xc Xc ldqq integer, leading dimension of qq Xc Xc on exit Xc Xc pp(ldpp,*) complex*16, the unitary right hand transformation Xc of order m by m Xc Xc qq(ldqq,*) complex*16, the unitary left hand transformation Xc of order n by n Xc Xc a(ldab,*) in upper triangular form with two diagonal elements Xc exchanged Xc Xc b(ldab,*) in upper trinagular form with two diagonal elements Xc exchanged Xcc Xc************************************************************************ Xc Xc**** this version dated june 14, 1986 Xc authors: jim demmel and bo kagstrom Xc Xc**** exchng uses the following functions and subroutines Xc cgiv, cmatpr, zcsrot Xc Xc**** internal variables X logical altb, ldebug X integer rbp1, cbp1 X real*8 maxab1 X complex*16 sa1, sb1, f, g, s, c, ctemp Xc X ldebug = idbg(8) .ne. 0 Xc X rbp1 = rowb + 1 X cbp1 = colb + 1 X if (ldebug) then X write (outunit, 2000) 'results from exchng: rowb, colb', X * rowb, colb X 2000 format( t5, a, 2i3) X write(outunit, 2000) 'eigenvalues before exchange' X write(outunit, 2000) 'rbp1,cbp1=', rbp1, cbp1 X if (abs(b(rowb,colb)) .gt. 0.) then X ctemp = a(rowb,colb)/b(rowb,colb) X write(outunit, 3000) ctemp X else X write(outunit, 3000) a(rowb,colb), b(rowb,colb) X endif X if (abs(b(rbp1,cbp1)) .gt. 0.) then X write(outunit, 3000) a(rbp1,cbp1), b(rbp1,cbp1) X ctemp = a(rbp1,cbp1)/b(rbp1,cbp1) X write(outunit, 3000) ctemp X else X write(outunit, 3000) a(rbp1,cbp1), b(rbp1,cbp1) X endif X 3000 format( t5,d15.5) Xc end of output for debugging X endif X maxab1 = max(abs(a(rbp1, cbp1)), abs(b(rbp1, cbp1))) X altb = .true. X if (abs(a(rbp1, cbp1)) .ge. maxab1) altb = .false. X if (ldebug) then X write(outunit, 310) 'maxab1=', maxab1 X 310 format(t5, a, d15.5) X write(outunit,305) 'altb=', altb X 305 format(t5,a,l1) X endif X sa1 = a(rbp1, cbp1) / maxab1 X sb1 = b(rbp1, cbp1) / maxab1 X f = sa1 * b(rowb, colb) - sb1 * a(rowb, colb) X g = sa1 * b(rowb, cbp1) - sb1 * a(rowb, cbp1) Xc Xc**** construct the right hand transformation (affects the columns Xc colb and colb + 1 of a, b and qq) X call cgiv(f, g, c, s) X call zcsrot(rbp1, a(1, colb), 1, a(1, cbp1),1, conjg(s), -c) X call zcsrot(rbp1, b(1, colb), 1, b(1, cbp1),1, conjg(s), -c) X call zcsrot(n, qq(1, colb), 1, qq(1, cbp1), 1, conjg(s), -c) X if (ldebug) then X call cmatpr( a,ldab,m,n, ' A after right transf.') X call cmatpr( b,ldab,m,n, ' B after right transf.') X endif Xc Xc**** construct the left hand transformation (affects the rows Xc rowb and rowb + 1 of a, b, and pp(conjg,trans)) X if (altb) then X call cgiv(b(rowb, colb), b(rbp1, colb), c, s) X else X call cgiv(a(rowb, colb), a(rbp1, colb), c, s) X endif X call zcsrot(n-colb+1, a(rowb,colb), ldab, a(rbp1, colb), X * ldab, c, s) X call zcsrot(n-colb+1, b(rowb,colb), ldab, b(rbp1, colb), X * ldab, c, s) X call zcsrot(m, pp(1, rowb), 1, pp(1, rbp1), 1, c, conjg(s)) X if (ldebug) then X call cmatpr( a,ldab,m,n, ' A after left transf.') X call cmatpr( b,ldab,m,n, ' B after left transf.') X endif Xc X a(rbp1, colb) = (0.d0, 0.d0) X b(rbp1, colb) = (0.d0, 0.d0) X if (ldebug) then X write (outunit, 2000) 'eigenvalues after exchange' X if (abs(b(rowb,colb)) .gt. 0.) then X write(outunit, 3000) a(rowb,colb)/b(rowb,colb) X else X write(outunit, 3000) a(rowb,colb), b(rowb,colb) X endif X if (abs(b(rbp1,cbp1)) .gt. 0.) then X write(outunit, 3000) a(rbp1,cbp1)/b(rbp1,cbp1) X else X write(outunit, 3000) a(rbp1,cbp1), b(rbp1,cbp1) X endif X call cmatpr( a,ldab,m,n, 'Final A after one exchange') X call cmatpr( b,ldab,m,n, 'Final B after one exchange') Xc end of outputs for debugging X endif X return X end X X subroutine cgiv( a, b, c, s) Xc Xc implicit none Xc*** debug space X common /debug2/ idbg(20), outunit X integer idbg, outunit Xc*** formal parameter declarations X complex*16 a, b, s , c Xc Xc**** cgiv constructs a complex givens transformation Xc Xc c s Xc g = c*c + s*conjg(s) = 1 Xc -conjg(s) c Xc Xc which zeros the second entry of the 2-vector (a,b)**t: Xc a aprim Xc g * b = 0 Xc Xc cgiv leaves the arguments a and b unchanged, Xc (aprim is computed but no returned in this version). Xc note that the resulting c could have been chosen real Xc (but not for our application since we interchange c and s Xc when applying the the transformation in an equivalence Xc transformation) Xc Xc if idbg(8) .eq. 0 then debug output is withed off Xc Xc**** this version dated june, 1986 Xc Xc**** internal variables Xc X real*8 sigma, delta, absa X complex*16 aprim, alfa X logical ldebug X ldebug = idbg(8) .ne. 0 Xc X absa = abs(a) X if ( absa .eq. 0) then X c = 0.d0 X s = (1.d0, 0.d0) X aprim = b X else X sigma = absa + abs(b) X delta = sigma*sqrt(abs(a/sigma)**2 + abs(b/sigma)**2) X alfa = a / absa X c = absa /delta X s = alfa * conjg(b) / delta X aprim = alfa * delta X endif X if (ldebug) then X write(outunit, 100) 'cos=', c, 'sin=', s X 100 format (t5, a, 2d12.5) X write(outunit, 100) 'cos-sin-identity', X + c*conjg(c)+s*conjg(s) X endif X return X end X X subroutine zcsrot (n,cx,incx,cy,incy,c,s) Xc Xc implicit none X complex*16 cx(*), cy(*), c, s X integer incx,incy,n Xc Xc**** zcsrot Xc applies a givens transformation where cos (c) and sin (s) Xc are complex as well as the vectors cx and cy. Xc the transformation is computed by cgiv. Xc note that c can be chosen real. however since we Xc will be able to interchange the values of c and s when Xc calling zcsrot we have to declare c as complex too. Xc Xc zcsrot is a modification of csrot Xc deal with complex sin (s) and cos (c) Xc Xc**** this version dated june, 1986 Xc X integer i, ix, iy X complex*16 ctemp Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ctemp = c*cx(ix) + s*cy(iy) X cy(iy) = conjg(c)*cy(iy) - conjg(s)*cx(ix) X cx(ix) = ctemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc X 20 continue X do 30 i = 1,n X ctemp = c*cx(i) + s*cy(i) X cy(i) = conjg(c)*cy(i) - conjg(s)*cx(i) X cx(i) = ctemp X 30 continue X return X end X X END_OF_zreorder.f if test 16058 -ne `wc -c zrzstr.f <<'END_OF_zrzstr.f' X subroutine rzstr (opt, a, b, ldab, m, n, rowb, rowe, X * colb, cole, first, zero, epsua, epsub, gap, X * pp, ldpp, qq, ldqq, kstr, kfirst, step, X * adlsvd, bdlsvd, X * work, x, sx, ex, q, arow, brow, w, qraux, y, X * qty, info) Xc Xc implicit none Xc**** debug space Xc the common-block declarations assume that the dimension of the Xc input matrix pencil a - lambda b is not larger than abdim. Xc the debug space is used for producing debug outputs (optional, Xc see below) Xc X integer abdim X parameter (abdim = 30) X common /debug1/ acopy(abdim,abdim),bcopy(abdim,abdim), X * atest(abdim,abdim), btest(abdim,abdim), swap X common /debug2/ idbg(20), outunit X complex*16 acopy,bcopy,atest,btest X logical swap X integer idbg, outunit Xc Xc**** formal parameter declarations X character*(*) opt X integer ldab, m, n, rowb, rowe, colb, cole, ldpp, ldqq, X * kstr(4,*), step, kfirst, info X logical first, zero X real*8 adlsvd, bdlsvd, epsua, epsub, gap X complex*16 a(ldab,*), b(ldab,*), pp(ldpp,*), qq(ldqq,*), X * work(*) Xc Xc**** workspace Xc X complex*16 x(m,*), sx(*), ex(*), q(n,*), X * arow(*), brow(*), w(n,*), qraux(*), X * y(*), qty(*) Xc Xc******************************************************************* Xc Xc rzstr computes the kronecker right (column) structure and Xc the jordan structure of the zero-eigenvalue of a singular Xc pencil a-lambda*b.for details concerning the listr-kernel see Xc the following papers: Xc Xc b.kagstrom, rgsvd - an algorithm for computing the kronecker Xc structure and reducing subspaces of singular a - lambda b Xc pencils, siam j.sci.stat.comput., vol. 7, 1986, pp 185-211 Xc Xc j.demmel and b.kagstrom, stably computing the kronecker Xc structure and reducing subspaces of singular pencils Xc a - lambda b for uncertain data, in large scale eigenvalue Xc problems (cullum, willoughby eds), north holland, 1986, Xc pp 283-323. Xc Xc Xc formal parameters Xc Xc on entry Xc Xc opt*(*) character, if opt = 'cind' rzstr computes indices Xc if opt = 'rind' already computed indices Xc are reused in the reduction Xc Xc a(ldab,*) complex*16, input matrix a of order m by n Xc Xc b(ldab,*) complex*16, input matrix b of order m by n Xc Xc ldab integer, leading dimension of a and b Xc Xc m integer, current row dimension of a and b Xc Xc n integer, current column dimension of and b Xc Xc rowb integer, first row of the subpencil Xc Xc rowe integer, last row of the subpencil Xc Xc colb integer, first column of the subpencil Xc Xc cole integer, last column of the subpencil Xc Xc first logical, first should be 'true' if first call to Xc rzstr, else 'false' Xc Xc zero logical, if 'true', zero out small singular values Xc so returned pencil really has structure described Xc in kstr (see below), else returned pencil is a Xc true equivalence transformation of input pencil Xc (no singular values are deleted) Xc Xc epsua real*8, threshold for deleting singular values of a Xc (used when compressing columns of a) Xc Xc epsub real*8, threshold for deleting singular values of b Xc (used when compressing columns of b) Xc Xc gap real*8, should be at least 1 and nominally 1000. Xc used by subroutine rcsvdc to make rank decisions Xc by searching for adjacent singular values whose Xc ratio exceeds gap. Xc Xc ldpp integer, leading dimension of pp Xc Xc ldqq integer, leading dimension of qq Xc Xc kfirst integer, index to the first location in kstr Xc where structure-index information is stored Xc from this reduction (see below) Xc Xc on exit Xc Xc pp(ldpp,*)complex*16, left unitary transformation matrix Xc pp of order m by m Xc Xc qq(ldqq,*)complex*16, right unitary transformation matrix Xc qq of order n by n Xc Xc a(ldab,*) transformed matrix a (pp**h * a * pp) Xc Xc b(ldab,*) transformed matrix b (pp**h * b * pp) Xc Xc kstr(4,*) integer, stores information concerning right Xc kronecker indices and the jordan structure of Xc the zero eigenvalue. Xc kstr(1,kfirst-1+j) - kstr(2,kfirst-1+j) = Xc number of l(j-1) blocks (right indices of Xc degree j-1). Xc kstr(2,kfirst-1+j) - kstr(1,kfirst+j) = Xc number of jordan blocks of the zero Xc eigenvalue of dimension j. Xc index j goes from 1 to step (see below) Xc note: rows 3 and 4 of kstr are not used inside Xc rzstr. Xc Xc step integer, the number of deflation-steps in this Xc reduction Xc Xc adlsvd real*8, root sum of squares of deleted singular Xc values of a (independent of the input zero) Xc Xc bdlsvd real*8, root sum of squares of deleted singular Xc values of b (independent of the input zero) Xc Xc info integer, zero if normal return, Xc 1 if svd does not converge Xc Xc on exit from rzstr a and b will be in block upper triangular form: Xc Xc Xc a = ( arz * ) b = ( brz * ) Xc ( 0 a22 ) ( 0 b22 ) Xc Xc the block structure of arz - lambda*brz describes the Xc kronecker column (right) structure and the jordan structure Xc of the zero eigenvalue. if ni and ri denote the dimension of Xc the diagonal blocks in arz and brz (see example below), then Xc they have the following interpretation: Xc Xc ni - ri = the number of l(i-1) -blocks of order (i-1) by i Xc ri - ni+1 = the number of j(0)-blocks of order i by i Xc Xc note that if a - lambda*b is a regular pencil then ni=ri. Xc the rzstr reduction stops when an ni.eq.0 or ni.ne.0 but ri.eq.0. Xc then a22 will have full column rank. a22 - lambda*b22 might Xc still be a singular pencil (can have row (left) indices). Xc an example illustrates the two cases (see papers for details): Xc case 1 - n4.eq.0: Xc Xc ( 0 a12 a13 ) r1 ( b11 b12 b13 ) r1 Xc arz = ( 0 0 a23 ) r2 brz = ( 0 b22 b23 ) r2 Xc ( 0 0 0 ) r3 ( 0 0 b33 ) r3 Xc n1 n2 n3 n1 n2 n3 Xc Xc case 2 - n4.ne.0 and r4.eq.0: Xc Xc ( 0 a12 a13 a14 ) r1 ( b11 b12 b13 b14 ) r1 Xc arz = ( 0 0 a23 a24 ) r2 brz = ( 0 b22 b23 b24 ) r2 Xc ( 0 0 0 a34 ) r3 ( 0 0 b33 b34 ) r3 Xc n1 n2 n3 n4 n1 n2 n3 n4 Xc Xc the ri by ni diagonal blocks bii of brz are in the form Xc ( 0 rii), where rii is ri by ri, nonsingular and upper Xc triangular. Xc Xc if kfirst = 1 on input then case 2 above cause the following Xc output for step and kstr: Xc step = 4 Xc kstr(1,1) = n1 kstr(2,1) = r1 Xc kstr(1,2) = n2 kstr(2,2) = r2 Xc kstr(1,3) = n3 kstr(2,3) = r3 Xc kstr(1,4) = n4 kstr(2,4) = 0 Xc Xc note that on output (arz,brz) or (a22,b22) can be nonexistent Xc in the block upper triangular form (a,b). (arz,brz) does not Xc exist if n1=r1=0. (a22,b22) does not exist if the input pencil Xc a -lambda*b has no left (row) singular structure, no Xc infinite eigenvalue and no nonzero eigenvalues. Xc Xc*** work space including size (all variables complex*16) Xc work(*) max(m,n) Xc x(m,*) m by n Xc sx(*) min(m,n) + 1 Xc ex(*) n Xc q(n,*) n by n Xc arow(*) max(m,n) Xc brow(*) max(m,n) Xc w(n,*) n by n Xc qraux(*) max(m,n) Xc y(*) max(m,n) Xc qty(*) max(m,n) Xc Xc***************************************************************** Xc Xc**** this version dated june 16, 1987 Xc authors: jim demmel and bo kagstrom Xc Xc**** rzstr uses the following functions and subroutines Xc kcfpack - cmatml, cmatmr, cmatpr, cmcopy, rcsvdc, upddel Xc linpack - zqrdc, zqrsl Xc Xc**** internal variables Xc X logical ldebug X integer mrow, ncol, i, j, sn1, sr1, rep, rowsr1, colsn1, xrow X * , xcol, job, ldx, ldq, n1, rnull, ldw, cnull, r1, X * colsnb, jend, idummy, ikstr, mxrc, k, iii, jjj Xc X real*8 del, difa, difb Xc X complex*16 dummy Xc Xc**** set leading dimensions of x, q, and w Xc X ldx = m X ldq = n X ldw = n Xc set debug switch X ldebug= (idbg(4).ne.0) Xc**** compute the order of the pencil in action (mrow * ncol) Xc X mrow = rowe - rowb + 1 X ncol = cole - colb + 1 Xc Xc*+*+* accumulate deleted singular values in adlsvd, bdlsvd X adlsvd = 0.0 X bdlsvd = 0.0 Xc X if (ldebug) write (outunit,1001) 'epsua=', epsua X if (ldebug) write (outunit,1001) 'epsub=', epsub X1001 format(t5,a,d13.6) Xc Xc Xc**** set rep depending on what option Xc X if ( opt .eq. 'cind' ) then Xc perhaps not enough !! X rep = rowe * cole X else X rep = step - kfirst + 1 X endif Xc*** 6/18/87 X if (ldebug) write(outunit,2000) 'kfirst=',kfirst, X + 'step=',step,'rep=',rep Xc X sn1 = 0 X sr1 = 0 X step = 0 Xc**** while rep > 0 do X 30 continue X if (ldebug) write(outunit,2000) 'rep at top of loop=',rep X if (rep .eq. 0) go to 500 Xc jump when while - loop satisfied Xc Xc while - clause X step = step + 1 X if (ldebug) write(outunit,2000) 'Results from step = ', step X 2000 format( t5, a, i3/) X if (ldebug) write(outunit,2005) opt X 2005 format(t5,a) Xc Xc**** set n1 and r1 if we are reusing kstr Xc X if ( opt .eq. 'rind' ) then X ikstr = kfirst + step - 1 X n1 = kstr(1, ikstr) X r1 = kstr(2, ikstr) X cnull = n1 -r1 X endif Xc Xc**** step 1 - compress columns of a (gives n1 = dimension of the Xc column nullspace) Xc* 1.1 Xc rows, rowb+sr1:rowe Xc cols, colb+sn1:cole Xc X rowsr1 = rowb + sr1 - 1 X colsn1 = colb + sn1 - 1 X xrow = mrow - sr1 X xcol = ncol - sn1 X do 40 i = 1, xrow X do 35 j = 1, xcol X x(i, j) = a(rowsr1 + i, colsn1 + j) X 35 continue X 40 continue X if ( xrow .ge. xcol ) then X job = 0110 X else X job = 0111 X endif X if (ldebug) then X write(outunit,5000) 'rowsr1=',rowsr1,'colsn1=',colsn1, X + 'xrow=',xrow X write(outunit,5000) 'xcol=',xcol,'rowb=',rowb,'rowe=',rowe X write(outunit,5000) 'colb=',colb,'cole=',cole,'sr1=',sr1, X + 'sn1=',sn1 X endif Xc Xc put m*n in info before calling X if (idbg(4) .gt. 2) then X call cmatpr(x ,ldx, xrow, xcol,'a-input rcsvdc') X endif X info = m*n X call rcsvdc (x, ldx, xrow, xcol, sx, ex, dummy, 1, q, ldq, opt, X * epsua, gap, n1, rnull, del, work, job, info ) Xc Xc X call upddel(adlsvd, del) Xc X mxrc = min0( xrow, xcol) X if (ldebug) call cmatpr( sx, 1, 1, mxrc, X * 'singular values - column compress a') X if (idbg(4) .gt. 1 .or. (info .ne. 0 .and. ldebug) ) then X call cmatpr( ex, 1, 1, mxrc,'sub diagonal - should be zero') X call cmatpr(q, ldq, xcol, xcol, X * 'step1.1: right singular vectors of A') X endif X if (ldebug) write (outunit,1005) 'info=', info, 'n1=', n1 X 1005 format(t5, a, i3/ ) Xc X if (info .ne. 0) then Xc**** 6/18/87 X if (ldebug) write(outunit,2007) info X 2007 format('rzstr - after first call to rcsvdc, info= ',i4) X info = 1 X return X endif Xc Xc if n1=0, we are done X if (n1 .eq. 0) then X r1=0 X goto 450 X end if Xc Xc* 1.2 - apply right transformation q to a and b (the full matrices) Xc rows in a and b: 1:rowe Xc columns in a: colb+sn1:cole ( xcol col's) Xc columns in b: colb+sn1:cole Xc X do 70 i = 1, rowe X do 50 j = 1, xcol X arow(j) = 0.d0 X brow(j) = 0.d0 X do 45 k = 1, xcol X arow(j) = arow(j) + a(i, colsn1 + k) * q(k, j) X brow(j) = brow(j) + b(i, colsn1 + k) * q(k, j) X 45 continue X 50 continue X do 60 j = 1, xcol X a(i, colsn1 + j) = arow(j) X b(i, colsn1 + j) = brow(j) X 60 continue X 70 continue Xc Xc* zero part of a Xc rows, rowb+sr1:rowe Xc cols, colb+sn1:colb+sn1+n1-1 Xc X if (zero) then X do 80 i = rowb + sr1, rowe X do 75 j = colb + sn1, colsn1 + n1 X a(i, j) = 0.d0 X 75 continue X 80 continue X endif Xc Xc**** Step 2 - column compress part of B ( gives n1 - r1 = Xc dimension of the common nullspace) Xc Xc* 2.1 Xc rows, rowb+sr1:rowe Xc cols, colb+sn1:colb+sn1+n1-1 Xc X xrow = mrow - sr1 X xcol = n1 X do 90 i = 1, xrow X do 85 j = 1, xcol X x(i, j) = b( rowsr1 + i, colsn1 + j) X 85 continue X 90 continue X X if (xrow .ge. xcol) then X job = 0110 X else X job = 0111 X endif X if (idbg(4) .gt. 2) then X call cmatpr(x ,ldx, xrow, xcol,'b-input rcsvdc') X endif X info = m*n X call rcsvdc ( x, ldx, xrow, xcol, sx, ex, dummy, 1, w, ldw, X * opt, epsub, gap, cnull, rnull, del, work, job, info ) Xc X if ( opt .eq. 'cind' ) r1 = n1 - cnull Xc Xc if r1 = 0 then we are done ! Zero part in b and then update qq Xc Xc X if (ldebug) write(outunit,1005) 'info=', info, 'cnull=', cnull, X * 'n1=', n1,'r1=', r1 Xc X mxrc = min0( xrow, xcol) X if (ldebug) call cmatpr( sx, 1, 1, mxrc, X * 'singular values - column compress b') X if (idbg(4) .gt. 1 .or. (info .ne. 0 .and. ldebug) ) then X call cmatpr( ex, 1, 1, mxrc,'sub diagonal - should be zero') X call cmatpr ( w, ldw, xcol, xcol, X * 'step 2.1: right singular vectors of b') X endif Xc X call upddel(bdlsvd, del) Xc X if (info .ne. 0) then Xc**** 6/18/87 X if (ldebug) write(outunit,2008) info X 2008 format('rzstr - after second call to rcsvdc, info= ',i4) X info = 1 X return X endif Xc X if (r1 .eq. 0) goto 3500 Xc Xc* 2.2 Xc update q rows, 1:ncol-sn1 Xc cols, 1:n1 Xc a, b rows, 1:rowe Xc cols, colb+sn1:colb+sn1+n1-1 Xc Xc note that we do not make use of that some of the elements in a Xc are zero Xc first q X xcol = ncol - sn1 X do 110 i = 1, xcol X do 100 j = 1, n1 X arow(j) = 0.d0 X do 95 k = 1, n1 X arow(j) = arow(j) + q(i, k) * w(k, j) X 95 continue X 100 continue Xc X do 105 j = 1, n1 X q(i, j) = arow(j) X 105 continue X 110 continue Xc X if (idbg(4) .gt. 2) then X call cmatpr(q, ldq, xcol, xcol, X * 'updated q after second column compress') X endif Xc Xc now a and b .... X do 120 i = 1, rowe X do 114 j = 1, n1 X arow(j) = 0.d0 X brow(j) = 0.d0 X do 112 k = 1, n1 X arow(j) = arow(j) + a(i, colsn1 + k) * w(k, j) X brow(j) = brow(j) + b(i, colsn1 + k) * w(k, j) X 112 continue X 114 continue X do 116 j = 1, n1 X a(i, colsn1 + j) = arow(j) X b(i, colsn1 + j) = brow(j) X 116 continue X 120 continue Xc Xc* zero part of b Xc rows, rowb+sr1:rowe Xc cols, colb+sn1:colb+sn1+(n1-r1)-1 Xc X 3500 continue X if (zero) then X do 130 i = rowb + sr1, rowe X do 125 j = 1, n1 - r1 X b(i, colsn1 + j) = 0.d0 X 125 continue X 130 continue X endif Xc X if (r1 .eq. 0 )go to 350 Xc Xc**** Step 3 - Triangularize b ( using qr) Xc Xc* 3.1 Xc rows, rowb+sr1:rowe Xc cols, colb+sn1+(n1-r1):cole Xc X xrow = mrow - sr1 X xcol = ncol - sn1 - (n1 - r1) X colsnb = colsn1 + (n1-r1) X do 140 i = 1, xrow X do 135 j = 1, xcol X x(i, j) = b( rowsr1 + i, colsnb + j) X 135 continue X 140 continue X job = 0 X call zqrdc( x, ldx, xrow, xcol, qraux, idummy, dummy, job) Xc Xc move the upper triangular part to b Xc X do 150 i = 1, xrow X do 145 j = i, xcol X b(rowsr1 + i, colsnb + j) = x(i, j) X 145 continue X jend = min0(xcol, i - 1) X do 148 j = 1, jend X b(rowsr1 + i, colsnb + j) = 0.d0 X 148 continue X 150 continue Xc Xc* 3.2 Xc apply v(conj,trans) to remaining cols of b Xc from the left (xrow*xrow) Xc rows, rowb+sr1:rowe Xc cols, cole+1:n Xc X do 170 j = cole+1, n X do 160 i = 1, xrow X y(i) = b(rowsr1 + i, j) X 160 continue X job = 01000 X call zqrsl(x, ldx, xrow, xcol, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 165 i = 1, xrow X b(rowsr1 + i, j) = qty(i) X 165 continue X 170 continue Xc if (ldebug) call cmatpr(b, ldab, m, n, Xc * 'B after triangularization - step 3.1') Xc Xc apply v(conj,trans) to a from the left (xrow*xrow) Xc rows, rowb+sr1:rowe Xc cols, colb+sn1+n1:n Xc X do 185 j = colb + sn1 + n1, n X do 180 i = 1, xrow X y(i) = a(rowsr1 + i, j) X 180 continue X job = 01000 X call zqrsl(x, ldx, xrow, xcol, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 175 i = 1, xrow X a(rowsr1 + i, j) = qty(i) X 175 continue X 185 continue Xc if (ldebug) call cmatpr(a,ldab,m,n,'A after step 3.2') Xc Xc**** update left transformation matrix pp ( m*m ) Xc rows, 1:m Xc cols, rowb+sr1:rowe Xc X do 200 i = 1, m X do 190 j = 1, xrow X y(j) = conjg( pp(i, rowsr1+j) ) X 190 continue X job = 01000 X call zqrsl( x, ldx, xrow, xcol, qraux, y, dummy, qty, X * dummy, dummy, dummy, job, info) X do 195 j = 1, xrow X pp(i, rowsr1 + j) = conjg( qty(j) ) X 195 continue X 200 continue Xc X if (idbg(4) .gt. 1) then X call cmatpr(pp, ldpp, m, m, X * 'step 3.2: pp after updating with w from qr') X endif X 350 continue Xc Xc**** update right transformation matrix qq (n*n) Xc rows, 1:n Xc cols, colb+sn1:cole Xc X xcol = ncol - sn1 X if (first) then X do 210 i = 1, n X do 205 j = 1, n X qq(i, j) = q(i, j) X 205 continue X 210 continue X else X do 240 i = 1, n X do 230 j = 1, xcol X arow(j) = 0.d0 X do 220 k = 1, xcol X arow(j) = arow(j) + qq(i, colsn1 + k) * q(k, j) X 220 continue X 230 continue X do 235 j = 1, xcol X qq(i, colsn1 + j) = arow(j) X 235 continue X 240 continue X endif X if (idbg(4) .gt. 2) then X call cmatpr(qq,ldqq, m, m, 'updated qq') X endif Xc Xc**** update indices Xc X sn1 = sn1 + n1 X sr1 = sr1 + r1 X if (ldebug) then X write(outunit,5000) 'rowsr1=',rowsr1,'colsn1=',colsn1, X + 'xrow=',xrow X write(outunit,5000) 'xcol=',xcol,'rowb=',rowb,'rowe=',rowe X write(outunit,5000) 'colb=',colb,'cole=',cole,'sr1=',sr1, X + 'sn1=',sn1 X endif Xc* monitoring of the r1 and n1 in kstr Xc X 450 continue Xc**** added 060787 to match zlistr X if (ldebug) then X if (swap) then X call cmcopy(bcopy,20,m,n,atest) X call cmcopy(acopy,20,m,n,btest) X else X call cmcopy(acopy,20,m,n,atest) X call cmcopy(bcopy,20,m,n,btest) X end if X call cmatml(atest,20,m,n,pp,ldpp,m,atest,20,work,3) X call cmatmr(atest,20,m,n,qq,ldqq,n,atest,20,work,1) X call cmatml(btest,20,m,n,pp,ldpp,m,btest,20,work,3) X call cmatmr(btest,20,m,n,qq,ldqq,n,btest,20,work,1) X difa=0 X difb=0 X do 1234 iii=1,m X do 5678 jjj=1,n X difa=difa+abs(atest(iii,jjj)-a(iii,jjj)) X difb=difb+abs(btest(iii,jjj)-b(iii,jjj)) X 5678 continue X 1234 continue X write(outunit,201) 'difa=',difa X 201 format(t5,a,d13.6/) Xc call cmatpr(atest,20,m,n,'atest') X write(outunit,201) 'difb=',difb Xc call cmatpr(btest,20,m,n,'btest') X endif Xc Xc**** compute rep depending on what option is used Xc X if ( opt .eq. 'cind') then X kstr(1, step) = n1 X kstr(2, step) = r1 X rep = n1 * r1 * (mrow - sr1) * (ncol - sn1) X else X rep =rep - 1 X endif X if (ldebug) write(outunit,5000) 'sn1=',sn1,'sr1=',sr1, X + 'rep=',rep X 5000 format(t5,a,i4/) X first = .false. X go to 30 Xc Xc**** end of while clause X 500 continue Xc X return X end Xc last line of zrstr X X END_OF_zrzstr.f if test 22304 -ne `wc -c