Subject: guptri_for_netlib

From: [email-masked]
Date: Sun, 1 Apr 90 12:59:59 +0200

#! /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 <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  readme kcfin.c1 zblas.f zbnd.f zcmatmlr.f zftest1.f
#   zgschur.c1 zgschurm.f zguptri.f zlinpack.f zlistr.f zmiscl.f zqz.f
#   zrcsvdc.f zreorder.f zrzstr.f
# Wrapped by bokg@ikaros on Sun Apr  1 12:43:01 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f readme -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"readme\"
else
echo shar: Extracting \"readme\" \(3177 characters\)
sed "s/^X//" >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: [email-masked]
X	  or   [email-masked]
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: [email-masked]
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 <readme`; then
    echo shar: \"readme\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f kcfin.c1 -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"kcfin.c1\"
else
echo shar: Extracting \"kcfin.c1\" \(527 characters\)
sed "s/^X//" >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 <kcfin.c1`; then
    echo shar: \"kcfin.c1\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zblas.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zblas.f\"
else
echo shar: Extracting \"zblas.f\" \(11182 characters\)
sed "s/^X//" >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 <zblas.f`; then
    echo shar: \"zblas.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zbnd.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zbnd.f\"
else
echo shar: Extracting \"zbnd.f\" \(52873 characters\)
sed "s/^X//" >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 = < <a11' .*. eye(m-rowred) , -eye(colred) .*. a22 >;
Xc                     <b11' .*. eye(m-rowred) , -eye(colred) .*. b22 >>
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 <zbnd.f`; then
    echo shar: \"zbnd.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zcmatmlr.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zcmatmlr.f\"
else
echo shar: Extracting \"zcmatmlr.f\" \(6590 characters\)
sed "s/^X//" >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 <zcmatmlr.f`; then
    echo shar: \"zcmatmlr.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zftest1.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zftest1.f\"
else
echo shar: Extracting \"zftest1.f\" \(752 characters\)
sed "s/^X//" >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 <zftest1.f`; then
    echo shar: \"zftest1.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zgschur.c1 -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zgschur.c1\"
else
echo shar: Extracting \"zgschur.c1\" \(17039 characters\)
sed "s/^X//" >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 <zgschur.c1`; then
    echo shar: \"zgschur.c1\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zgschurm.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zgschurm.f\"
else
echo shar: Extracting \"zgschurm.f\" \(59481 characters\)
sed "s/^X//" >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 <zgschurm.f`; then
    echo shar: \"zgschurm.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zguptri.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zguptri.f\"
else
echo shar: Extracting \"zguptri.f\" \(42915 characters\)
sed "s/^X//" >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 <zguptri.f`; then
    echo shar: \"zguptri.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zlinpack.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zlinpack.f\"
else
echo shar: Extracting \"zlinpack.f\" \(33916 characters\)
sed "s/^X//" >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 <zlinpack.f`; then
    echo shar: \"zlinpack.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zlistr.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zlistr.f\"
else
echo shar: Extracting \"zlistr.f\" \(24733 characters\)
sed "s/^X//" >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 <zlistr.f`; then
    echo shar: \"zlistr.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zmiscl.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zmiscl.f\"
else
echo shar: Extracting \"zmiscl.f\" \(11447 characters\)
sed "s/^X//" >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 <zmiscl.f`; then
    echo shar: \"zmiscl.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zqz.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zqz.f\"
else
echo shar: Extracting \"zqz.f\" \(32062 characters\)
sed "s/^X//" >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 <zqz.f`; then
    echo shar: \"zqz.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zrcsvdc.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zrcsvdc.f\"
else
echo shar: Extracting \"zrcsvdc.f\" \(9358 characters\)
sed "s/^X//" >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 <zrcsvdc.f`; then
    echo shar: \"zrcsvdc.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zreorder.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zreorder.f\"
else
echo shar: Extracting \"zreorder.f\" \(16058 characters\)
sed "s/^X//" >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 <zreorder.f`; then
    echo shar: \"zreorder.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f zrzstr.f -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"zrzstr.f\"
else
echo shar: Extracting \"zrzstr.f\" \(22304 characters\)
sed "s/^X//" >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 <zrzstr.f`; then
    echo shar: \"zrzstr.f\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of shell archive.
exit 0