C      ALGORITHM 747, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 21, NO. 3, September, 1995, P.  299-326.
C
C This file contains 36 files separated by lines of the form
C         C*** filename
C
C The filenames in this file are:
C
C blas.f               ddemo.f              ddemo.sh            
C dlog.ref             dmevas.f             dstair.f            
C eispk.f              lapack.f             makefile            
C readme               sdemo.f              sdemo.sh            
C slog.ref             smevas.f             sstair.f            
C test.doc             test01.dat           test02.dat          
C test03.dat           test04.dat           test05.dat          
C test06.dat           test07.dat           test08.dat          
C test09.dat           test10.dat           test11.dat          
C test12.dat           test13.dat           test14.dat          
C test15.dat           test16.dat           test17.dat          
C test18.dat           test19.dat           test20.dat          
C                                                               
C
C*** blas.f
c
c FILE: Blas.f
c
c**********************************************************
c**********************************************************
c
      subroutine  dcopy(n,dx,incx,dy,incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end
c
c**********************************************************
c**********************************************************
c
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
c
c**********************************************************
c**********************************************************
c
      subroutine  drot (n,dx,incx,dy,incy,c,s)
c
c     applies a plane rotation.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp,c,s
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = c*dx(ix) + s*dy(iy)
        dy(iy) = c*dy(iy) - s*dx(ix)
        dx(ix) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
   20 do 30 i = 1,n
        dtemp = c*dx(i) + s*dy(i)
        dy(i) = c*dy(i) - s*dx(i)
        dx(i) = dtemp
   30 continue
      return
      end
c
c**********************************************************
c**********************************************************
c
      subroutine drotg(da,db,c,s)
c
c     construct givens plane rotation.
c     jack dongarra, linpack, 3/11/78.
c                    modified 9/27/86.
c
      double precision da,db,c,s,roe,scale,r,z
c
      roe = db
      if( dabs(da) .gt. dabs(db) ) roe = da
      scale = dabs(da) + dabs(db)
      if( scale .ne. 0.0d0 ) go to 10
         c = 1.0d0
         s = 0.0d0
         r = 0.0d0
         go to 20
   10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
      r = dsign(1.0d0,roe)*r
      c = da/r
      s = db/r
   20 z = s
      if( dabs(c) .gt. 0.0d0 .and. dabs(c) .le. s ) z = 1.0d0/c
      da = r
      db = z
      return
      end
c
c**********************************************************
c**********************************************************
c
      subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
c
ccccc ******************************************************************
ccccc ******************************************************************
c
      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      double precision function dnrm2 ( n, dx, incx)
      integer   incx, n,  next
      double precision   dx(*), cutlo, cuthi, hitest, sum, xmax,zero,one
      data   zero, one /0.0d0, 1.0d0/
c
c     euclidean norm of the n-vector stored in dx() with storage
c     increment incx .
c     if n .le. 0 return with result = 0.
c     if n .ge. 1 then incx must be .ge. 1
c
c           c.l.lawson, 1978 jan 08
c
c     four phase method     using two built-in constants that are
c     hopefully applicable to all machines.
c         cutlo = maximum of  dsqrt(u/eps)  over all known machines.
c         cuthi = minimum of  dsqrt(v)      over all known machines.
c     where
c         eps = smallest no. such that eps + 1. .gt. 1.
c         u   = smallest positive no.   (underflow limit)
c         v   = largest  no.            (overflow  limit)
c
c     brief outline of algorithm..
c
c     phase 1    scans zero components.
c     move to phase 2 when a component is nonzero and .le. cutlo
c     move to phase 3 when a component is .gt. cutlo
c     move to phase 4 when a component is .ge. cuthi/m
c     where m = n for x() real and m = 2*n for complex.
c
c     values for cutlo and cuthi..
c     from the environmental parameters listed in the imsl converter
c     document the limiting values are as follows..
c     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
c                   univac and dec at 2**(-103)
c                   thus cutlo = 2**(-51) = 4.44089e-16
c     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
c                   thus cuthi = 2**(63.5) = 1.30438e19
c     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
c                   thus cutlo = 2**(-33.5) = 8.23181d-11
c     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
c     data cutlo, cuthi / 8.232d-11,  1.304d19 /
c     data cutlo, cuthi / 4.441e-16,  1.304e19 /
      data cutlo, cuthi / 8.232d-11,  1.304d19 /
c
      if(n .gt. 0) go to 10
         dnrm2  = zero
         go to 300
c
   10 assign 30 to next
      sum = zero
      nn = n * incx
c                                                 begin main loop
      i = 1
   20    go to next,(30, 50, 70, 110)
   30 if( dabs(dx(i)) .gt. cutlo) go to 85
      assign 50 to next
      xmax = zero
c
c                        phase 1.  sum is zero
c
   50 if( dx(i) .eq. zero) go to 200
      if( dabs(dx(i)) .gt. cutlo) go to 85
c
c                                prepare for phase 2.
      assign 70 to next
      go to 105
c
c                                prepare for phase 4.
c
  100 i = j
      assign 110 to next
      sum = (sum / dx(i)) / dx(i)
  105 xmax = dabs(dx(i))
      go to 115
c
c                   phase 2.  sum is small.
c                             scale to avoid destructive underflow.
c
   70 if( dabs(dx(i)) .gt. cutlo ) go to 75
c
c                     common code for phases 2 and 4.
c                     in phase 4 sum is large.  scale to avoid overflow.
c
  110 if( dabs(dx(i)) .le. xmax ) go to 115
         sum = one + sum * (xmax / dx(i))**2
         xmax = dabs(dx(i))
         go to 200
c
  115 sum = sum + (dx(i)/xmax)**2
      go to 200
c
c
c                  prepare for phase 3.
c
   75 sum = (sum * xmax) * xmax
c
c
c     for real or d.p. set hitest = cuthi/n
c     for complex      set hitest = cuthi/(2*n)
c
   85 hitest = cuthi/float( n )
c
c                   phase 3.  sum is mid-range.  no scaling.
c
      do 95 j =i,nn,incx
      if(dabs(dx(j)) .ge. hitest) go to 100
   95    sum = sum + dx(j)**2
      dnrm2 = dsqrt( sum )
      go to 300
c
  200 continue
      i = i + incx
      if ( i .le. nn ) go to 20
c
c              end of main loop.
c
c              compute square root and adjust for scaling.
c
      dnrm2 = xmax * dsqrt(sum)
  300 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      double precision function dasum(n,dx,incx)
c
c     takes the sum of the absolute values.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dtemp
      integer i,incx,m,mp1,n,nincx
c
      dasum = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dtemp = dtemp + dabs(dx(i))
   10 continue
      dasum = dtemp
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,6)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dabs(dx(i))
   30 continue
      if( n .lt. 6 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,6
        dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2))
     *  + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
   50 continue
   60 dasum = dtemp
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      LOGICAL FUNCTION LSAME ( CA, CB )
*     .. Scalar Arguments ..
      CHARACTER*1            CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME  tests if CA is the same letter as CB regardless of case.
*  CB is assumed to be an upper case letter. LSAME returns .TRUE. if
*  CA is either the same as CB or the equivalent lower case letter.
*
*  N.B. This version of the routine is only correct for ASCII code.
*       Installers must modify the routine for other character-codes.
*
*       For EBCDIC systems the constant IOFF must be changed to -64.
*       For CDC systems using 6-12 bit representations, the system-
*       specific code in comments must be activated.      
*
*  Parameters
*  ==========
*
*  CA     - CHARACTER*1
*  CB     - CHARACTER*1
*           On entry, CA and CB specify characters to be compared.
*           Unchanged on exit.
*
*
*  Auxiliary routine for Level 2 Blas.
*
*  -- Written on 20-July-1986
*     Richard Hanson, Sandia National Labs.
*     Jeremy Du Croz, Nag Central Office.
*
*     .. Parameters ..
      INTEGER                IOFF
      PARAMETER            ( IOFF=32 )
*     .. Intrinsic Functions ..
      INTRINSIC              ICHAR
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA .EQ. CB
*
*     Now test for equivalence
*
      IF ( .NOT.LSAME ) THEN
         LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB)
      END IF
*
      RETURN
*
*  The following comments contain code for CDC systems using 6-12 bit
*  representations.
*
*     .. Parameters ..
*     INTEGER                ICIRFX
*     PARAMETER            ( ICIRFX=62 )
*     .. Scalar Arguments ..
*     CHARACTER*1            CB
*     .. Array Arguments ..
*     CHARACTER*1            CA(*)
*     .. Local Scalars ..
*     INTEGER                IVAL
*     .. Intrinsic Functions ..
*     INTRINSIC              ICHAR, CHAR
*     .. Executable Statements ..
*
*     See if the first character in string CA equals string CB.
*
*     LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
*
*     IF (LSAME) RETURN
*
*     The characters are not identical. Now check them for equivalence.
*     Look for the 'escape' character, circumflex, followed by the
*     letter.
*
*     IVAL = ICHAR(CA(2))
*     IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
*        LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
*     END IF
*
*     RETURN
*
*     End of LSAME.
*
      END
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      SUBROUTINE XERBLA ( SRNAME, INFO )
*     ..    Scalar Arguments ..
      INTEGER            INFO
      CHARACTER*6        SRNAME
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the Level 2 BLAS routines.
*
*  It is called by the Level 2 BLAS routines if an input parameter is
*  invalid.
*
*  Installers should consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Parameters
*  ==========
*
*  SRNAME - CHARACTER*6.
*           On entry, SRNAME specifies the name of the routine which
*           called XERBLA.
*
*  INFO   - INTEGER.
*           On entry, INFO specifies the position of the invalid
*           parameter in the parameter-list of the calling routine.
*
*
*  Auxiliary routine for Level 2 Blas.
*
*  Written on 20-July-1986.
*
*     .. Executable Statements ..
*
      WRITE (*,99999) SRNAME, INFO
*
      STOP
*
99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2,
     $         ' had an illegal value' )
*
*     End of XERBLA.
*
      END
c
ccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*
************************************************************************
*
      SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTRSV  solves one of the systems of equations
*
*     A*x = b,   or   A'*x = b,
*
*  where b and x are n element vectors and A is an n by n unit, or
*  non-unit, upper or lower triangular matrix.
*
*  No test for singularity or near-singularity is included in this
*  routine. Such tests must be performed before calling this routine.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the equations to be solved as
*           follows:
*
*              TRANS = 'N' or 'n'   A*x = b.
*
*              TRANS = 'T' or 't'   A'*x = b.
*
*              TRANS = 'C' or 'c'   A'*x = b.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element right-hand side vector b. On exit, X is overwritten
*           with the solution vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := inv( A )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*A( I, J )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, I = J - 1, 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*A( I, J )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, I = J + 1, N
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := inv( A' )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( I )
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( I )
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRSV .
*
      END
*
************************************************************************
*
      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRSM  solves one of the matrix equations
*
*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
*
*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  The matrix X is overwritten on B.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry, SIDE specifies whether op( A ) appears on the left
*           or right of X as follows:
*
*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
*
*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain  the  right-hand  side  matrix  B,  and  on exit  is
*           overwritten by the solution matrix  X.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
*
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*inv( A )*B.
*
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*inv( A' )*B.
*
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*B*inv( A ).
*
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*B*inv( A' ).
*
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRSM .
*
      END
c
ccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
*
************************************************************************
*
*     File of the DOUBLE PRECISION Level-3 BLAS.
*     ==========================================
*
*     SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE DSYMM ( SIDE,   UPLO,   M, N,    ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE DSYRK ( UPLO,   TRANS,     N, K, ALPHA, A, LDA,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE DSYR2K( UPLO,   TRANS,     N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     See:
*
*        Dongarra J. J.,   Du Croz J. J.,   Duff I.  and   Hammarling S.
*        A set of  Level 3  Basic Linear Algebra Subprograms.  Technical
*        Memorandum No.88 (Revision 1), Mathematics and Computer Science
*        Division,  Argonne National Laboratory, 9700 South Cass Avenue,
*        Argonne, Illinois 60439.
*
*
************************************************************************
*
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the *           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And if  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B' + beta*C
*
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMM .
*
      END
c
c
c SINGLE PRECISION ROUTINES FOLLOW
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      real function sasum(n,sx,incx)
c
c     takes the sum of the absolute values.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increments, 9/29/88. 
c
      real sx(*),stemp
      integer i,ix,incx,m,mp1,n
c
      sasum = 0.0e0
      stemp = 0.0e0
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      do 10 i = 1,n
        stemp = stemp + abs(sx(ix))
        ix = ix + incx
   10 continue
      sasum = stemp
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,6)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + abs(sx(i))
   30 continue
      if( n .lt. 6 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,6
        stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2))
     *  + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5))
   50 continue
   60 sasum = stemp
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine saxpy(n,sa,sx,incx,sy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(*),sy(*),sa
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sy(i) + sa*sx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
   50 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine scopy(n,sx,incx,sy,incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to 1.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(*),sy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        sy(i) = sx(i)
        sy(i + 1) = sx(i + 1)
        sy(i + 2) = sx(i + 2)
        sy(i + 3) = sx(i + 3)
        sy(i + 4) = sx(i + 4)
        sy(i + 5) = sx(i + 5)
        sy(i + 6) = sx(i + 6)
   50 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      real function sdot(n,sx,incx,sy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(*),sy(*),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      stemp = 0.0e0
      sdot = 0.0e0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = stemp + sx(ix)*sy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      sdot = stemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + sx(i)*sy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
     *   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
   50 continue
   60 sdot = stemp
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      real function snrm2 ( n, sx, incx)
      integer  incx, n,  next
      real   sx(*),  cutlo, cuthi, hitest, sum, xmax, zero, one
      data   zero, one /0.0e0, 1.0e0/
c
c     euclidean norm of the n-vector stored in sx() with storage
c     increment incx .
c     if n .le. 0 return with result = 0.
c     if n .ge. 1 then incx must be .ge. 1
c
c           c.l.lawson, 1978 jan 08
c
c     four phase method     using two built-in constants that are
c     hopefully applicable to all machines.
c         cutlo = maximum of  sqrt(u/eps)  over all known machines.
c         cuthi = minimum of  sqrt(v)      over all known machines.
c     where
c         eps = smallest no. such that eps + 1. .gt. 1.
c         u   = smallest positive no.   (underflow limit)
c         v   = largest  no.            (overflow  limit)
c
c     brief outline of algorithm..
c
c     phase 1    scans zero components.
c     move to phase 2 when a component is nonzero and .le. cutlo
c     move to phase 3 when a component is .gt. cutlo
c     move to phase 4 when a component is .ge. cuthi/m
c     where m = n for x() real and m = 2*n for complex.
c
c     values for cutlo and cuthi..
c     from the environmental parameters listed in the imsl converter
c     document the limiting values are as follows..
c     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
c                   univac and dec at 2**(-103)
c                   thus cutlo = 2**(-51) = 4.44089e-16
c     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
c                   thus cuthi = 2**(63.5) = 1.30438e19
c     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
c                   thus cutlo = 2**(-33.5) = 8.23181d-11
c     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
c     data cutlo, cuthi / 8.232d-11,  1.304d19 /
c     data cutlo, cuthi / 4.441e-16,  1.304e19 /
      data cutlo, cuthi / 4.441e-16,  1.304e19 /
c
      if(n .gt. 0) go to 10
         snrm2  = zero
         go to 300
c
   10 assign 30 to next
      sum = zero
      nn = n * incx
c                                                 begin main loop
      i = 1
   20    go to next,(30, 50, 70, 110)
   30 if( abs(sx(i)) .gt. cutlo) go to 85
      assign 50 to next
      xmax = zero
c
c                        phase 1.  sum is zero
c
   50 if( sx(i) .eq. zero) go to 200
      if( abs(sx(i)) .gt. cutlo) go to 85
c
c                                prepare for phase 2.
      assign 70 to next
      go to 105
c
c                                prepare for phase 4.
c
  100 i = j
      assign 110 to next
      sum = (sum / sx(i)) / sx(i)
  105 xmax = abs(sx(i))
      go to 115
c
c                   phase 2.  sum is small.
c                             scale to avoid destructive underflow.
c
   70 if( abs(sx(i)) .gt. cutlo ) go to 75
c
c                     common code for phases 2 and 4.
c                     in phase 4 sum is large.  scale to avoid overflow.
c
  110 if( abs(sx(i)) .le. xmax ) go to 115
         sum = one + sum * (xmax / sx(i))**2
         xmax = abs(sx(i))
         go to 200
c
  115 sum = sum + (sx(i)/xmax)**2
      go to 200
c
c
c                  prepare for phase 3.
c
   75 sum = (sum * xmax) * xmax
c
c
c     for real or d.p. set hitest = cuthi/n
c     for complex      set hitest = cuthi/(2*n)
c
   85 hitest = cuthi/float( n )
c
c                   phase 3.  sum is mid-range.  no scaling.
c
      do 95 j =i,nn,incx
      if(abs(sx(j)) .ge. hitest) go to 100
   95    sum = sum + sx(j)**2
      snrm2 = sqrt( sum )
      go to 300
c
  200 continue
      i = i + incx
      if ( i .le. nn ) go to 20
c
c              end of main loop.
c
c              compute square root and adjust for scaling.
c
      snrm2 = xmax * sqrt(sum)
  300 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine srot (n,sx,incx,sy,incy,c,s)
c
c     applies a plane rotation.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(*),sy(*),stemp,c,s
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = c*sx(ix) + s*sy(iy)
        sy(iy) = c*sy(iy) - s*sx(ix)
        sx(ix) = stemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
   20 do 30 i = 1,n
        stemp = c*sx(i) + s*sy(i)
        sy(i) = c*sy(i) - s*sx(i)
        sx(i) = stemp
   30 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine srotg(sa,sb,c,s)
c
c     construct givens plane rotation.
c     jack dongarra, linpack, 3/11/78.
c                    modified 9/27/86.
c
      real sa,sb,c,s,roe,scale,r,z
c
      roe = sb
      if( abs(sa) .gt. abs(sb) ) roe = sa
      scale = abs(sa) + abs(sb)
      if( scale .ne. 0.0 ) go to 10
         c = 1.0
         s = 0.0
         r = 0.0
         go to 20
   10 r = scale*sqrt((sa/scale)**2 + (sb/scale)**2)
      r = sign(1.0,roe)*r
      c = sa/r
      s = sb/r
   20 z = s
      if( abs(c) .gt. 0.0 .and. abs(c) .le. s ) z = 1.0/c
      sa = r
      sb = z
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine sswap (n,sx,incx,sy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal to 1.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(*),sy(*),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = sx(ix)
        sx(ix) = sy(iy)
        sy(iy) = stemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = sx(i)
        sx(i) = sy(i)
        sy(i) = stemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        stemp = sx(i)
        sx(i) = sy(i)
        sy(i) = stemp
        stemp = sx(i + 1)
        sx(i + 1) = sy(i + 1)
        sy(i + 1) = stemp
        stemp = sx(i + 2)
        sx(i + 2) = sy(i + 2)
        sy(i + 2) = stemp
   50 continue
      return
      end
*
************************************************************************
*
*     File of the REAL             Level-3 BLAS.
*     ==========================================
*
*     SUBROUTINE SGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE SSYMM ( SIDE,   UPLO,   M, N,    ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE SSYRK ( UPLO,   TRANS,     N, K, ALPHA, A, LDA,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE SSYR2K( UPLO,   TRANS,     N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE STRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     SUBROUTINE STRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     See:
*
*        Dongarra J. J.,   Du Croz J. J.,   Duff I.  and   Hammarling S.
*        A set of  Level 3  Basic Linear Algebra Subprograms.  Technical
*        Memorandum No.88 (Revision 1), Mathematics and Computer Science
*        Division,  Argonne National Laboratory, 9700 South Cass Avenue,
*        Argonne, Illinois 60439.
*
*
************************************************************************
*
      SUBROUTINE SGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      REAL               ALPHA, BETA
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  SGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - REAL            .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - REAL             array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - REAL             array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - REAL            .
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - REAL             array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      REAL               TEMP
*     .. Parameters ..
      REAL               ONE         , ZERO
      PARAMETER        ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'SGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And if  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B' + beta*C
*
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of SGEMM .
*
      END
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      integer function isamax(n,sx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increments, 9/29/88.  
c
      real sx(*),smax
      integer i,incx,ix,n
c
      isamax = 0
      if( n .lt. 1 ) return
      isamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      smax = abs(sx(ix))
      ix = ix + incx
      do 10 i = 2,n
         if(abs(sx(ix)).le.smax) go to 5
         isamax = i
         smax = abs(sx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 smax = abs(sx(1))
      do 30 i = 2,n
         if(abs(sx(i)).le.smax) go to 30
         isamax = i
         smax = abs(sx(i))
   30 continue
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine sscal(n,sa,sx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to 1.
c     jack dongarra, linpack, 3/11/78.
c     modified to correct problem with negative increments, 9/29/88.
c
      real sa,sx(*)
      integer i,ix,incx,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1 
      if(incx.lt.0)ix = (-n+1)*incx + 1 
      do 10 i = 1,n 
        sx(ix) = sa*sx(ix)
        ix = ix + incx 
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end
*
************************************************************************
*
      SUBROUTINE STRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      REAL               ALPHA
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  STRSM  solves one of the matrix equations
*
*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
*
*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  The matrix X is overwritten on B.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry, SIDE specifies whether op( A ) appears on the left
*           or right of X as follows:
*
*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
*
*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - REAL            .
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - REAL             array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - REAL             array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain  the  right-hand  side  matrix  B,  and  on exit  is
*           overwritten by the solution matrix  X.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      REAL               TEMP
*     .. Parameters ..
      REAL               ONE         , ZERO
      PARAMETER        ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
*
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'STRSM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*inv( A )*B.
*
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*inv( A' )*B.
*
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*B*inv( A ).
*
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*B*inv( A' ).
*
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of STRSM .
*
      END
*
************************************************************************
*
      SUBROUTINE STRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  STRSV  solves one of the systems of equations
*
*     A*x = b,   or   A'*x = b,
*
*  where b and x are n element vectors and A is an n by n unit, or
*  non-unit, upper or lower triangular matrix.
*
*  No test for singularity or near-singularity is included in this
*  routine. Such tests must be performed before calling this routine.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the equations to be solved as
*           follows:
*
*              TRANS = 'N' or 'n'   A*x = b.
*
*              TRANS = 'T' or 't'   A'*x = b.
*
*              TRANS = 'C' or 'c'   A'*x = b.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - REAL             array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - REAL             array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element right-hand side vector b. On exit, X is overwritten
*           with the solution vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER        ( ZERO = 0.0E+0 )
*     .. Local Scalars ..
      REAL               TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'STRSV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := inv( A )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*A( I, J )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, I = J - 1, 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*A( I, J )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, I = J + 1, N
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := inv( A' )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( I )
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( I )
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of STRSV .
*
      END
C*** ddemo.f
c
c FILE: ddemo.f
c
c==== ==============================================================
c
        program ddemo
c
c       This program reads in data, calls staircase subroutine DSTAIR,
c       calls pole placement subroutine DMEVAS, and calls back
c       transformation routine DBKTRN.
c       Computes eigenvalues of closed loop, and writes results.
c
c       .. Parameters ..
c       implicit none
        integer          Nin, Nout
        parameter        (Nin = 5, Nout = 6)
        integer          Nmax, Mmax
        parameter        (Nmax = 40, Mmax = 40)
        integer          lda, ldb, ldf
        parameter        (lda=Nmax, ldb=Nmax, ldf=Mmax)
c       .... for upper bounds on Givens and Householder transformations
c            with N in {1,..,Nmax} and M in {1,..,min(N,Mmax)} 
c                the expressions for gmax and hmax yield
c                greatest gmax = 211 when N=40, M=20
c                greatest hmax = 401 when N=40, M=1
        integer          gmax
        parameter        (gmax = 211)
        integer          hmax
        parameter        (hmax = 401)
c       .... and for the work space bounds
        integer          liwork
c
c
c       Parameter liwork should normaly be declared as
c
c        parameter        (liwork = max(4*Nmax, Nmax+Nmax/2+gmax+hmax))
c
c       Microsoft's FORTRAN 5.00 compiler however reports a parameter
c       error that seems to be coming from the use of max. We have therefore
c       replace the declaration with the one below which is fine so far
c       as the  test*.dat  are concerned. All UNIX based FORTRAN 
c       compilers had no problem with the above declaration.
c
        parameter        (liwork = Nmax + Nmax/2 + gmax + hmax)
c
        integer          lrwork
        parameter        (lrwork = 3*Nmax + 2*gmax + 3*hmax)
c
c       .. Local Scalars ..
        double precision tol
        integer          n, m, kmax, ncmplx, iwarn, ierr, i, j
        character*20     header
c
c       .. Local Arrays ..
        double precision A(lda,Nmax), B(ldb,Mmax), F(ldf,Nmax)
        double precision eigs(Nmax), rwork(lrwork)
        integer          kstair(Nmax+1), info(2), iwork(liwork)
        integer          itrnsf(nmax*(mmax+1)/2 + mmax+2*nmax+3)
        double precision rtrnsf(nmax*(mmax+1)/2 + nmax*(nmax+1)/2)
        double precision AA(lda,Nmax), BB(ldb,Mmax)
        double precision reigs(Nmax), imeigs(Nmax)
c
c       .. External Subroutines ..      
        external dstair, dmevas, dbktrn, lpeigs
c
c       .. Executable Statements ..
c
c       .. read the two headings in the data file
c       .. echo the second heading
        read (Nin,FMT=99990) header
        read (Nin,FMT=99990) header
        write (Nout,FMT=99999)
        write (Nout,FMT=99990) header
c
c       .. read the data ..
        read (Nin,FMT=*) n, m, tol
        if (n.le.0 .or. n.gt.Nmax) then
           write (Nout,FMT=99998) n
        else
           read (Nin,FMT=*) (( A(i,j), j=1,n), i=1,n)
           if (m.le.0 .or. m.gt.Mmax) then
              write (Nout,FMT=99997) m
           else
              read (Nin,FMT=*) (( B(i,j), j=1,m), i=1,n)
              read (Nin,FMT=*) ( eigs(i), i=1,n )
              read (Nin,FMT=*) ncmplx 
c
c             .. make copies of A,B so we can compute eigenvalues of closed loop
c             .. copy A to AA ..
              do 100 j = 1, n
                  call dcopy(n, A(1,j), 1, AA(1,j), 1)
  100         continue
c             .. copy B to BB ..
              do 120 j = 1, m
                  call dcopy(n, B(1,j), 1, BB(1,j), 1)
  120         continue
c
c             .. echo the eigenvalues to be allocated
              write(Nout,FMT=80058)
              do 150 i = 1, ncmplx, 2
                  write(Nout,FMT=80054) EIGS(i),EIGS(i+1)           
                  write(Nout,FMT=80055) EIGS(i),EIGS(i+1)           
  150         continue
              do 170 i = ncmplx+1, n
                  write(Nout,FMT=80056) EIGS(I)
  170         continue
c
c             ..compute the staircase form and the ranks of the
c               staircase blocks..
			  call dstair(n,m,A,lda,B,ldb, kmax, kstair, itrnsf,
     &                    rtrnsf, iwork, rwork, tol, iwarn, ierr)
c
              if(ierr .lt. 0) then
                 write(Nout,FMT=80000) -ierr
              else
                 if (iwarn .ne. 0) then
                    write (Nout,FMT=80020) iwarn
                 end if
c
c                .. allocate the eigenvalues ..
                 call dmevas (n,m, ncmplx, gmax, hmax, A, lda,
     &                          B,ldb, F,ldf, eigs, kmax, kstair,
     &                          info, iwork, rwork, tol, iwarn, ierr)
c
                 write (Nout,FMT='()')
                 if (ierr .lt. 0) then
                    write(Nout,FMT=80000) -ierr
                 else
c                   .. print results ..
                    if (iwarn .ne. 0) then
                       write (Nout,FMT=80020) iwarn
                    end if
                    if (ierr .ne. 0) then
                       write(Nout,FMT=80010) ierr
                    end if
                    write (Nout,FMT=80030) tol
                    if (info(2) .ne. n) then
                       write (Nout,FMT=80040)
                       write (Nout,FMT=80041) info(2)
                    end if
                    if (info(1) .ne. n) then
                       write (Nout,FMT=80050) n, info(1)
c                      .. print UNallocated eigenvalues ..
                       write (Nout,FMT=80052)
                       do 200 i=info(1)+1,info(1)+ncmplx,2
                          write(Nout,FMT=80054) EIGS(i),EIGS(i+1)           
                          write(Nout,FMT=80055) EIGS(i),EIGS(i+1)           
  200                  continue
                       do 220 i = info(1)+1+ncmplx, n
                          write(Nout,FMT=80056) EIGS(I)
  220                  continue
                    end if
c
c                   ..do the back transform on F1
                    call dbktrn(n,m,F,ldf,itrnsf,rtrnsf,rwork,ierr)
c
c                   .. before printing F compute and print eigenvalues
c                      of the closed loop. (lpeigs will overwrite AA).. 
                    call lpeigs(n,m, AA,lda, BB, ldb, F,ldf,
     &                             reigs, imeigs, iwork, rwork)
c
c                   .. print computed eigenvalues of closed loop ..
c                   .. imaginary parts with magnitude < tol are set to zero ..
                    write (Nout,FMT=80060)
                    DO 400 i=1,n
                        if ( abs(imeigs(i)) .LE. tol ) then
                           write(Nout,FMT=80056) reigs(i)
                        else if ( imeigs(i) .GE. 0.0 ) then
                           write(Nout,FMT=80054) reigs(i),imeigs(i)           
                        else
                           write(Nout,FMT=80055) reigs(i),-imeigs(i)
                        endif
  400               continue
c
c                   .. print computed F ..
                    write (Nout,FMT='()')
                    write (Nout,FMT=80080)
                    DO 500 i = 1, m
                        write(Nout,FMT=88888) (F(i,j), j=1,n)
  500               continue
c
                 end if
              end if
           end if
        end if
c
80000   FORMAT (' ERROR: error on ENTRY with argument ', I2)
80010   FORMAT (' ERROR: on EXIT ierr  = ', I2)
80020   FORMAT (' WARNING: on exit iwarn = ', I1)
80030   FORMAT (' tolerance used = ', E16.8)
80040   FORMAT (' eigenvalue stored at EIGS(N) on entry ')
80041   FORMAT ('        now stored at EIGS(', I2, ')')
80050   FORMAT (' of', I3, ' eigenvalues, the number allocated = ', I2)
80052   FORMAT (' the following eigenvalues were NOT allocated')
80054   FORMAT (F8.4, '  +  i*', F8.4)
80055   FORMAT (F8.4, '  -  i*', F8.4)
80056   FORMAT (F8.4)
80058   FORMAT (' the eigenvalues to be allocated are:')
80060   FORMAT (' the eigenvalues of the closed loop are:')
80080   FORMAT (' computed gain matrix F:')
88888   FORMAT (20(1x,F9.4))
99990   FORMAT (A20)
99996   FORMAT (' kmax is out of range: kmax = ', I2)
99997   FORMAT (' m is out of range: m = ', I2)
99998   FORMAT (' n is out of range: n = ', I2)
99999   FORMAT (' Demonstration Program Results')
c
        stop
        end
c===================================================================
c
        subroutine lpeigs(n, m, A,lda, B,ldb, F,ldf, reig, imeig,
     &                    iwork, rwork)
c
c    Purpose
c    =======
c    To call routines to compute A-BF and the eigenvalues of A-BF.
c
c    Arguments
c    =========

c    Arguments In
c    ------------
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           column dimension of matrix F.
c
c    M      INTEGER.
c           Column dimension of matrix B,
c           row dimension of matrix F.
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the matrix A.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the matrix B.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c    F      DOUBLE PRECISION array of DIMENSION (LDF,N).
c           The leading M by N part of this array must contain the matrix F.
c
c    LDF    INTEGER.
c           Row dimension of array F, as declared in the calling program
c           LDB .ge. M.
c
c    Arguments Out
c    -------------
c    REIG   DOUBLE PRECISION array of DIMENSION(N).
c           Contains the real parts of the computed eigenvalues.
c
c    IMEIG  DOUBLE PRECISION array of DIMENSION(N).
c           Contains the imaginary parts of the computed eigenvalues.
c
c    Workspace
c    ---------
c    IWORK  INTEGER array of DIMENSION(N).
c
c    RWORK  DOUBLE PRECISION array of DIMENSION(N).
c
c    Tolerances
c    ----------
c    None.
c
c    Warning Indicator
c    -----------------
c    None.
c
c    Error Indicator
c    ---------------
c    None.
c
c    Warnings and Errors Detected by the Routine
c    ===========================================
c    None
c
c    Method
c    ======
c    Uses BLAS routine DGEMM to compute B-AF.
c    Subsequent calls to EISPACK routines BALANC, ELMHES, HQR 
c    balance the matrix, reduce it to upper hessenberg form, and
c    compute the eigenvalues via the QR algorithm.
c
c    References
c    ==========
c    1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, Chapter 7.  
c    
c    2. Press, W.H. et al, Numerical Recipes, Cambridge University Press,
c       1986, pp.365-376
c
c
c    Revisions
c    =========
c    1994 Feb 03
c
c    arguments
c       implicit none
        integer n, m, lda, ldb, ldf, iwork(*)
        double precision A(lda,*), B(ldb,*), F(ldf,*)
        double precision reig(*), imeig(*), rwork(*)
c
c    parameters
        character*1 Tran
        parameter(Tran='n')
c
c    local variables
        integer low,igh,ierr
c
c       ..compute closed loop A-B*F and store in A
        call dgemm(Tran,Tran, n,n,m, -1.0d0, B,ldb, F,ldf, 1.0d0, A,lda)
c
c       ..compute eigenvalues of the closed loop (stored in A)
        call balanc( lda, n, A, low, igh, rwork)
        call elmhes( lda, n, low, igh, A, iwork)
        call hqr( lda, n, low, igh, A, reig, imeig, ierr)
c
        return
        end

C*** ddemo.sh
# FILE: ddemo.sh
#
#!/bin/sh
rm -f ddemo.log
for i in test*.dat
    do echo $i 
       ddemo.x < $i >> ddemo.log
done
C*** dlog.ref
FILE:  dlog.ref

 Demonstration Program Results
   test01           
 the eigenvalues to be allocated are:
   .9544  +  i*   .8513
   .9544  -  i*   .8513
   .2893  +  i*   .5374
   .2893  -  i*   .5374
   .5144  +  i*   .1034
   .5144  -  i*   .1034
   .4140
   .5767
   .8766
   .4400
   .7298

 tolerance used =    .98703268E-15
 eigenvalue stored at EIGS(N) on entry 
        now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .9544  +  i*   .8513
   .9544  -  i*   .8513
   .2893  +  i*   .5374
   .2893  -  i*   .5374
   .7298
   .8766
   .5144  +  i*   .1034
   .5144  -  i*   .1034
   .5767
   .4140
   .4400

 computed gain matrix F:
    1.2366    -.0621   -1.1794     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .6030    -.1087    1.2359     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.1042    -.8806    -.3792     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.1902     .6348    -.5265     .1831    -.4240     .1296    -.3876     .2118     .1149     .0152     .0374 
     .5347    -.3346     .1998    -.0448    1.3815    -.1915    1.2044    -.1380    -.4250     .0377    -.0325 
     .1073    -.3782     .1560     .0393     .3933    -.8726     .6780    -.6574    -.6013    -.0181    -.1687 
     .1528    -.0455    -.4707     .0090     .5769     .3959    -.2292     .1545     .2531    -.2305    -.6368 
 Demonstration Program Results
   test02           
 the eigenvalues to be allocated are:
   .1312  +  i*   .8857
   .1312  -  i*   .8857
   .0922  +  i*   .1622
   .0922  -  i*   .1622
   .0711  +  i*   .3653
   .0711  -  i*   .3653
   .2531
   .1351
   .7832
   .4553
   .3495

 tolerance used =    .10610132E-14
 eigenvalue stored at EIGS(N) on entry 
        now stored at EIGS( 5)
 the eigenvalues of the closed loop are:
   .1312  +  i*   .8857
   .1312  -  i*   .8857
   .7832
   .0711  +  i*   .3653
   .0711  -  i*   .3653
   .4553
   .0922  +  i*   .1622
   .0922  -  i*   .1622
   .3495
   .2531
   .1351

 computed gain matrix F:
     .1001    1.2141    -.0966     .0711    5.0344     .0000     .0000     .0000     .0000     .0000     .0000 
    -.4456     .3309    -.9465    -.4678     .0858   -1.3265     .5564    -.6209    -.0797    -.2924     .2009 
   -1.1914   -1.3564    2.8527    1.5547    1.6460    2.1313   -1.7744    1.2853    -.1253     .7265    -.4825 
     .6008    -.3938    -.2453   -1.5008    -.2922    -.2535     .2332    -.0025     .0174     .0085    -.2005 
 Demonstration Program Results
   test03           
 the eigenvalues to be allocated are:
   .7298  +  i*   .8693
   .7298  -  i*   .8693
   .7156  +  i*   .8007
   .7156  -  i*   .8007
   .7065  +  i*   .7417
   .7065  -  i*   .7417
   .0191
   .8860
   .5250
   .4633
   .0652
   .7134
   .4889

 tolerance used =    .11399781E-14
 the eigenvalues of the closed loop are:
   .7298  +  i*   .8693
   .7298  -  i*   .8693
   .7156  +  i*   .8007
   .7156  -  i*   .8007
   .7065  +  i*   .7417
   .7065  -  i*   .7417
   .0191
   .8860
   .0652
   .7134
   .4633
   .4889
   .5250

 computed gain matrix F:
    3.8000    2.6996    1.8115  -12.1405   -1.2960  -12.3325   35.2843  -12.7917  -12.3098    6.7445  -46.2238     .0000     .0000 
    -.1299    2.2954    1.3242   -2.0195   -1.3181   -7.1153   12.0253   -6.3949   -5.2201     .1470  -22.7628     .0000     .0000 
     .1054     .7980    -.7706     .1107     .1728     .7289    -.1496     .0750     .0050     .5155    -.1578     .0200    -.1811 
 Demonstration Program Results
   test04           
 the eigenvalues to be allocated are:
   .1236  +  i*   .9734
   .1236  -  i*   .9734
   .0296
   .0804
   .4942
   .7694
   .9340
   .2502
   .3597
   .7691
   .5000
   .7493
   .6719
   .6817
   .7568
   .0364
   .2306
   .2217
   .5626

 tolerance used =    .19538777E-14
 eigenvalue stored at EIGS(N) on entry 
        now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .1236  +  i*   .9733
   .1236  -  i*   .9733
   .9340
   .0296
   .0804
   .3597
   .4942
   .5000
   .6817
   .7694
   .6719
   .7691
   .5626
   .7493
   .2502
   .0364
   .7568
   .2217
   .2306

 computed gain matrix F:
     .6844    -.7049    -.8840     .0815     .4088     .2177    -.9352     .6891     .3737    -.0426     .1916     .1751    -.5344     .3431    -.3536    -.0610     .1607     .0000     .0000 
     .5377   -1.2897    -.3693    -.0620   -1.1130     .6192    -.8361   -1.4656    1.1668   -1.0074    -.5434     .1141    -.8746     .4087   -1.5800    -.3427    -.2769     .0000     .0000 
    -.3414    -.1132   -1.1144   -1.0554   -1.0811     .8136     .9407    -.4220    1.7581     .6850     .9596     .4047     .0269   -1.2368   -1.1616     .8826    -.0732     .0000     .0000 
    -.2265    -.0043    -.2213   -1.1224     .3588    -.2094     .4005     .2942     .3240     .0002    -.2662    -.2661     .6789     .0902     .2643     .0241    -.1756     .0000     .0000 
     .2899    -.0107     .0301     .1390     .4738    -.7477     .6664     .2663     .5584     .8707    -.7539    -.1938     .2546     .1765     .4003     .2046    -.0310     .0000     .0000 
     .1126    -.0106     .1036     .4032     .6697    -.8356     .0606     .0181    -.2327     .3014    -.2265     .1679    -.1145     .0397     .0835     .0852    -.1335    -.0229     .1828 
 Demonstration Program Results
   test05           
 the eigenvalues to be allocated are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .1783
   .1537
   .5717
   .8024
   .0331
   .5345

 tolerance used =    .69008470E-15
 the eigenvalues of the closed loop are:
   .0331
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .1537
   .1783
   .5344
   .5717
   .8024

 computed gain matrix F:
    -.3808    -.3672    -.9907   -2.1210    3.0556   -1.1266    -.2946   -1.3675 
     .0657    1.5508    -.9710    -.4255    8.9037   -3.4898     .0508     .2359 
     .3084     .3142     .3307    1.2718     .4935   -1.1860     .2385    1.1073 
    -.8329    -.1707    -.6103     .2794    -.0432     .0798    -.4747    -.6511 
 Demonstration Program Results
   test06           
 the eigenvalues to be allocated are:
   .6216  +  i*   .8031
   .6216  -  i*   .8031
   .2478
   .4764
   .3893
   .2033
   .0284
   .9017
   .4265

 tolerance used =    .88104024E-15
 eigenvalue stored at EIGS(N) on entry 
        now stored at EIGS( 7)
 the eigenvalues of the closed loop are:
   .6216  +  i*   .8031
   .6216  -  i*   .8031
   .4764
   .2478
   .4265
   .3893
   .2033
   .9017
   .0284

 computed gain matrix F:
   -2.5724     .6769   -1.2574     .3528    -.4997    -.9656    1.1845     .0000     .0000 
    -.2849    -.5452   -1.2494     .1274    -.5668    -.6412    -.3376     .0000     .0000 
    1.9985     .1808    1.2753     .5530    -.1198    -.8179    1.8712     .0000     .0000 
    -.6681   -1.0619    -.6613     .0059    -.1181     .3824    -.7930     .0000     .0000 
   -1.3325   -1.0313   -1.1417    -.1453    -.6545    -.2722     .0440     .0000     .0000 
    1.9865     .9305    -.2219     .2053    -.6571   -1.4549    1.0235     .0000     .0000 
     .2828    -.3858     .4358     .0333    -.4449     .3022    -.1848     .0000     .0000 
     .0465    -.0552     .7267     .2009    -.3151     .0733     .5488    -.0808    -.6580 
 Demonstration Program Results
   test07           
 the eigenvalues to be allocated are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .1783  +  i*   .1537
   .1783  -  i*   .1537
   .5717
   .8024
   .0331
   .5345

 tolerance used =    .70267792E-15
 the eigenvalues of the closed loop are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .0331
   .1783  +  i*   .1537
   .1783  -  i*   .1537
   .8024
   .5717
   .5344

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .8879     .1303     .1784    -.5409     .0000     .0000     .0000     .0000 
     .6435    1.7507   -2.2184     .2100    1.3477   -6.4379   -2.4985  -23.3845 
     .0380    -.0819    2.0681    -.0602   -2.0816    7.7146    2.8935   26.6307 
 Demonstration Program Results
   test08           
 the eigenvalues to be allocated are:
   .5045  +  i*   .5163
   .5045  -  i*   .5163
   .3190
   .9866
   .4940
   .2661
   .0907

 tolerance used =    .49349413E-15
 the eigenvalues of the closed loop are:
   .9866
   .5045  +  i*   .5163
   .5045  -  i*   .5163
   .4940
   .0907
   .3190
   .2661

 computed gain matrix F:
     .2489   -2.3904    3.2020    -.0094    -.9292    1.9323     .0990 
 Demonstration Program Results
   test09           
 the eigenvalues to be allocated are:
   .3888  +  i*   .9522
   .3888  -  i*   .9522
   .9476  +  i*   .3898
   .9476  -  i*   .3898
   .2692  +  i*   .6922
   .2692  -  i*   .6922
   .2840
   .7769

 tolerance used =    .78095530E-15
 the eigenvalues of the closed loop are:
   .3888  +  i*   .9522
   .3888  -  i*   .9522
   .2692  +  i*   .6922
   .2692  -  i*   .6922
   .9475  +  i*   .3898
   .9475  -  i*   .3898
   .2840
   .7769

 computed gain matrix F:
     .3892     .0044     .5935   -1.0112    -.9976    -.1775     .3247   -1.2121 
   -1.4578     .0233     .2380     .5325     .8624    -.5668    -.1984    -.2923 
    -.6029    -.7545   -2.1290     .0062    1.1338    -.0397    -.7087    2.4381 
     .1572    -.1593    -.5716    1.6415     .6629    -.1088    -.1790    1.1188 
     .3124    -.2093    1.4273    -.8024    -.4689     .7710     .0748   -1.4526 
     .2782     .2652    1.8953    -.1284   -2.0392     .1586    -.0217   -1.6027 
    -.8854     .6067    -.7371     .3861     .3295    -.4005     .7691     .8716 
    -.7646    -.2133   -1.9246     .0416     .0268     .0591    -.3556    2.0463 
 Demonstration Program Results
   test10           
 the eigenvalues to be allocated are:
   .8287  +  i*   .0945
   .8287  -  i*   .0945
   .0817  +  i*   .7640
   .0817  -  i*   .7640
   .6296  +  i*   .2139
   .6296  -  i*   .2139
   .2136
   .0811

 tolerance used =    .74874551E-15
 the eigenvalues of the closed loop are:
   .0817  +  i*   .7640
   .0817  -  i*   .7640
   .8287  +  i*   .0945
   .8287  -  i*   .0945
   .6296  +  i*   .2139
   .6296  -  i*   .2139
   .0811
   .2135

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.0992     .7753    1.2865    1.2901     .0150    -.5475     .0000     .0000 
     .1659    -.4842     .6537    -.0132    -.1184    -.0933     .0000     .0000 
     .3834    -.3197     .2206     .2743     .1338     .1617     .0000     .0000 
     .2288    -.0223    -.0122    -.4309     .6747     .5071     .0000     .0000 
     .1007    -.2591     .0032    -.7122    -.4544     .2169     .0000     .0000 
     .2359     .2166    -.0051    -.2988     .1992    -.7912     .0000     .0000 
    -.3387    -.2734    -.0615     .3452    -.1993    -.2667     .3435    -.3311 
 Demonstration Program Results
   test11           
 the eigenvalues to be allocated are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .1420  +  i*   .9475
   .1420  -  i*   .9475
   .4103  +  i*   .1312
   .4103  -  i*   .1312
   .8857
   .0922

 WARNING: on exit iwarn = 1
 tolerance used =    .79822926E-15
 the eigenvalues of the closed loop are:
   .1420  +  i*   .9475
   .1420  -  i*   .9475
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .8856
   .0922
   .4103  +  i*   .1312
   .4103  -  i*   .1312

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .2648    -.9294     .1674     .2470    -.9065    -.4097    -.1178     .1701 
     .7043     .2260    -.1191    -.1199    -.2421     .2311    -.1223     .0333 
    -.5400     .5475     .6162    -.1538     .6763    -.6769    -.2359     .2566 
     .3207     .0781    -.7164     .1622     .4649    -.7413     .2581    -.0665 
    -.0691     .2863    -.5469    -.8528     .9486    1.2726     .3715    -.6028 
    -.1964     .4532    -.0715    -.3426     .2323    -.0024     .7386     .3585 
     .8049     .5425    -.1440    -.1333    -.2610     .1466     .6978     .1215 
   -1.0747     .0777     .0194    -.5196     .8482    -.3907    -.4436   -1.2912 
 Demonstration Program Results
   test12           
 the eigenvalues to be allocated are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .1420
   .9475
   .4103
   .1312
   .8857
   .0922

 WARNING: on exit iwarn = 1
 tolerance used =    .89167673E-15
 the eigenvalues of the closed loop are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .9475
   .1420
   .8856
   .4103
   .1312
   .0922

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .5939    -.4165    -.5444    -.7489     .0000     .0000     .0000     .0000 
    -.0214    1.1300    -.0313     .7734     .0000     .0000     .0000     .0000 
    -.1453    -.1448    1.2168     .4517     .0000     .0000     .0000     .0000 
    -.2979    -.0431     .3522     .7659     .0000     .0000     .0000     .0000 
    -.1032    -.0728    -.5010    -.2337     .5275     .3007     .9273    -.3155 
    -.3026    -.1632    -.3029     .2156     .1829    -.7744     .0493     .1539 
 Demonstration Program Results
test13              
 the eigenvalues to be allocated are:
   .1234  +  i*   .4321
   .1234  -  i*   .4321
   .6789  +  i*   .9876
   .6789  -  i*   .9876
   .2468  +  i*   .8642
   .2468  -  i*   .8642
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .37747583E-14
 of  6 eigenvalues, the number allocated =  4
 the following eigenvalues were NOT allocated
   .2468  +  i*   .8642
   .2468  -  i*   .8642
 the eigenvalues of the closed loop are:
  1.0000
   .1234  +  i*   .4321
   .1234  -  i*   .4321
   .6789  +  i*   .9876
   .6789  -  i*   .9876
  8.0000

 computed gain matrix F:
    1.3871    -.1798   -1.3884   -1.5106   -1.7360     .0000 
    -.0764     .3491     .5212    1.1550    1.2771     .0000 
   -2.1276     .2688    2.1960    1.8309    2.2450     .0000 
 Demonstration Program Results
   test14           
 the eigenvalues to be allocated are:
   .4645  +  i*   .9410
   .4645  -  i*   .9410
   .0501
   .7615
   .7702
   .8278
   .1254
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .53935489E-15
 of  7 eigenvalues, the number allocated =  6
 the following eigenvalues were NOT allocated
   .1254
 the eigenvalues of the closed loop are:
   .4644  +  i*   .9410
   .4644  -  i*   .9410
   .0501
   .8278
   .7702
   .7615
  -.1122

 computed gain matrix F:
   -1.0843     .0882     .2301     .2246     .0000     .0000     .2557 
    -.2033    1.2802     .0694    -.3091    -.5666     .0000    -.7177 
   -2.0619    -.1116    2.5711   -1.8260    2.1958   -9.5969    -.1839 
 Demonstration Program Results
   test15           
 the eigenvalues to be allocated are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0537
   .4416
   .5192
   .7719
   .0654
   .4428
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .64061423E-15
 of  8 eigenvalues, the number allocated =  7
 the following eigenvalues were NOT allocated
   .4428
 the eigenvalues of the closed loop are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0654
   .0537
   .7719
   .5192
   .4416
  -.3030

 computed gain matrix F:
     .3227    -.5004    -.4283    -.4781     .0902    -.3277    -.1166     .0000 
    -.0068    1.5612   -2.2274   -4.2036     .0341   -9.1466   -4.7626     .0000 
     .0732    -.3890     .1507   -1.1243    -.2800    2.2841    -.3359     .0000 
    -.3282    -.0839     .3472     .1730    -.0922     .2528     .0081     .0000 
 Demonstration Program Results
   test16           
 the eigenvalues to be allocated are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0537  +  i*   .4416
   .0537  -  i*   .4416
   .5192  +  i*   .7719
   .5192  -  i*   .7719
   .0654  +  i*   .4428
   .0654  -  i*   .4428
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .64061423E-15
 of  8 eigenvalues, the number allocated =  6
 the following eigenvalues were NOT allocated
   .0654  +  i*   .4428
   .0654  -  i*   .4428
 the eigenvalues of the closed loop are:
  1.5847
   .5192  +  i*   .7719
   .5192  -  i*   .7719
   .0537  +  i*   .4416
   .0537  -  i*   .4416
   .7219  +  i*   .4966
   .7219  -  i*   .4966
  -.3030

 computed gain matrix F:
    -.2632    -.4941    -.3114    -.5365     .0647    -.5069     .0518     .0000 
     .2203    1.1585   -2.2792   -4.0142   -3.1412   -8.6576   -3.4432     .0000 
    -.3401    -.4836    -.9029    -.5833    -.3461    3.9367   -1.7233     .0000 
     .1311    -.0904     .2283     .2323    -.0662     .4350    -.1631     .0000 
 Demonstration Program Results
   test17           
 the eigenvalues to be allocated are:
   .1312  +  i*   .8857
   .1312  -  i*   .8857
   .0922
   .1622
   .0711
   .3653
   .2531
   .1351
   .7832
   .4553
   .3495
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .10610132E-14
 of 11 eigenvalues, the number allocated =  8
 the following eigenvalues were NOT allocated
   .7832
   .4553
   .3495
 the eigenvalues of the closed loop are:
   .1312  +  i*   .8856
   .1312  -  i*   .8856
   .3653
   .0711
   .0922
   .1351
   .1622
   .2531
   .4872
   .0551  +  i*   .3677
   .0551  -  i*   .3677

 computed gain matrix F:
     .2857     .9355   -2.4787   -1.0795     .2068   -1.9580    1.4284    -.8409     .1869     .0000     .0000 
    -.3546     .5065     .2770     .3595     .0899    -.1065     .0110    -.0425     .3711     .0000     .0000 
    -.7520     .5500    1.7342    1.5942     .7685     .5034    -.0882    -.2786    -.3631     .0000     .0000 
     .8251    -.4281    -.0957   -1.5130    -.1432    -.0325    -.0890     .0828     .2589     .0000     .0000 
 Demonstration Program Results
   test18          
 the eigenvalues to be allocated are:
  -.0219  +  i*  1.9999
  -.0219  -  i*  1.9999
  -.0865  +  i*  1.9981
  -.0865  -  i*  1.9981
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.3309  +  i*  1.9724
  -.3309  -  i*  1.9724
  -.5000  +  i*  1.9365
  -.5000  -  i*  1.9365
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8955  +  i*  1.7883
  -.8955  -  i*  1.7883
 -1.1045  +  i*  1.6673
 -1.1045  -  i*  1.6673
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.5000  +  i*  1.3229
 -1.5000  -  i*  1.3229
 -1.6691  +  i*  1.1018
 -1.6691  -  i*  1.1018
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.9135  +  i*   .5817
 -1.9135  -  i*   .5817
 -1.9781  +  i*   .2948
 -1.9781  -  i*   .2948
 -2.0000
  2.0000

 tolerance used =    .51625371E-13
 the eigenvalues of the closed loop are:
  -.0219  +  i*  1.9999
  -.0219  -  i*  1.9999
  -.0865  +  i*  1.9981
  -.0865  -  i*  1.9981
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.3309  +  i*  1.9724
  -.3309  -  i*  1.9724
  -.5000  +  i*  1.9365
  -.5000  -  i*  1.9365
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8955  +  i*  1.7883
  -.8955  -  i*  1.7883
 -1.1045  +  i*  1.6673
 -1.1045  -  i*  1.6673
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.5000  +  i*  1.3229
 -1.5000  -  i*  1.3229
 -1.6691  +  i*  1.1018
 -1.6691  -  i*  1.1018
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.9135  +  i*   .5817
 -1.9135  -  i*   .5817
 -1.9781  +  i*   .2948
 -1.9781  -  i*   .2948
 -2.0000
  2.0000

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000    -.0001    -.0001    -.0001     .0000
     .0002     .0004     .0007     .0001     .0015     .0053     .0192     .0647     .2241     .7693 
 Demonstration Program Results
   test19           
 the eigenvalues to be allocated are:
  -.0123  +  i*  2.0000
  -.0123  -  i*  2.0000
  -.0489  +  i*  1.9994
  -.0489  -  i*  1.9994
  -.1090  +  i*  1.9970
  -.1090  -  i*  1.9970
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.2929  +  i*  1.9784
  -.2929  -  i*  1.9784
  -.4122  +  i*  1.9571
  -.4122  -  i*  1.9571
  -.5460  +  i*  1.9240
  -.5460  -  i*  1.9240
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8436  +  i*  1.8134
  -.8436  -  i*  1.8134
 -1.0000  +  i*  1.7321
 -1.0000  -  i*  1.7321
 -1.1564  +  i*  1.6318
 -1.1564  -  i*  1.6318
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.4540  +  i*  1.3733
 -1.4540  -  i*  1.3733
 -1.5878  +  i*  1.2161
 -1.5878  -  i*  1.2161
 -1.7071  +  i*  1.0420
 -1.7071  -  i*  1.0420
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.8910  +  i*   .6512
 -1.8910  -  i*   .6512
 -1.9511  +  i*   .4397
 -1.9511  -  i*   .4397
 -1.9877  +  i*   .2216
 -1.9877  -  i*   .2216
 -2.0000
  2.0000

 ERROR: on EXIT ierr  =  1
 tolerance used =    .91038288E-13
 of 40 eigenvalues, the number allocated = 36
 the following eigenvalues were NOT allocated
 -1.9877  +  i*   .2216
 -1.9877  -  i*   .2216
 -2.0000
  2.0000
 the eigenvalues of the closed loop are:
  -.0123  +  i*  2.0000
  -.0123  -  i*  2.0000
  -.0489  +  i*  1.9994
  -.0489  -  i*  1.9994
  -.1090  +  i*  1.9970
  -.1090  -  i*  1.9970
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.2929  +  i*  1.9784
  -.2929  -  i*  1.9784
  -.4122  +  i*  1.9571
  -.4122  -  i*  1.9571
  -.5460  +  i*  1.9240
  -.5460  -  i*  1.9240
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8436  +  i*  1.8134
  -.8436  -  i*  1.8134
 -1.0000  +  i*  1.7321
 -1.0000  -  i*  1.7321
 -1.1564  +  i*  1.6318
 -1.1564  -  i*  1.6318
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.4540  +  i*  1.3733
 -1.4540  -  i*  1.3733
 -1.5878  +  i*  1.2161
 -1.5878  -  i*  1.2161
 -1.7071  +  i*  1.0420
 -1.7071  -  i*  1.0420
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.8910  +  i*   .6512
 -1.8910  -  i*   .6512
 -1.9511  +  i*   .4397
 -1.9511  -  i*   .4397
 -1.9877  +  i*   .2210
 -1.9877  -  i*   .2210
 -2.0011
  2.0000

 computed gain matrix F:
     .0012    -.0014     .0034    -.0036     .0084    -.0102     .0096    -.0221     .0333    -.0370     .0768    -.0252     .1214    -.2405     .1026    -.3231     .4644    -.2767    1.1941    -.7582
     .8250   -2.9476     .8129   -1.7353    7.5120    -.2505    5.1128  -11.8175   -1.2124   -3.5922   15.9099   -2.9972    9.8457   14.5012   46.5532   61.2849  -71.2015  -87.4967    2.5050    7.9990
 Demonstration Program Results
test20              
 the eigenvalues to be allocated are:
   .1537  +  i*   .5717
   .1537  -  i*   .5717
   .8024  +  i*   .0331
   .8024  -  i*   .0331
   .5344
   .4985
   .9554
   .7483
   .5546

 tolerance used =    .64827308E-15
 eigenvalue stored at EIGS(N) on entry 
        now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .1537  +  i*   .5717
   .1537  -  i*   .5717
   .4985
   .5344
   .5546
   .9554
   .8024  +  i*   .0331
   .8024  -  i*   .0331
   .7483

 computed gain matrix F:
   -4.9627   10.3565   -4.3886   20.6874   41.5572  -20.4770    -.5653  -47.2729   29.5050 
    9.8123  -19.5555   10.5491  -37.6111  -81.4043   40.8125    1.4422   92.0295  -58.0640 
   -1.6539    2.4905   -1.4994    4.1482   11.2578   -4.9630    -.3038  -10.0436    7.3492 
C*** dmevas.f
c
c FILE: dmevas.f
c
c  == ==================================================================
c
      subroutine dmevas(n, m, ncmplx, gmax, hmax, A, lda,
     &                     B,ldb, F,ldf, eigs, kmax, kstair,
     &                     info, iwork, rwork, tol, iwarn, ierr)
c
c  == ==================================================================
c
c    Purpose
c    =======
c
c    To compute a real matrix F so that the "closed-loop" matrix (A - B*F)
c    has a specified set of eigenvalues.
c
c    Here A and B are real matrices such that the system (B,A) is in "upper
c    staircase" (or "controllability") form, with
c    staircase blocks in upper triangular form, and
c    the set of specified eigenvalues is self conjugate.
c
c    This routine is a driver for the subroutine DMVS1.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           column dimension of matrix F.
c           length of vector of eigenvalues EIGS.
c           N .ge. 1
c
c    M      INTEGER.
c           Column dimension of matrix B.
c           row dimension of matrix F.
c           M .ge. 1
c
c    NCMPLX INTEGER
c           Number of complex eigenvalues in EIGS. 
c           0 .le. NCMPLX .le. N, and NCMPLX even.
c
c    GMAX   INTEGER.
c           Maximum number of Givens rotations to be used in the
c           computation.  A sufficient value of  GMAX  may be computed as
c           follows (see also HMAX below):
c           let: q = ifix(N/M) and
c                r = N-q*M  so that  
c                N = q*M+r  where q, r are non-negative integers and r < M
c                rsum = r*(r+1)/2
c                Msum1 = M*(M-1)/2
c           then
c                     |     (q/2)*(1 + Msum1) + M-r,   q even
c              GMAX = |
c                     | ((q-1)/2)*(1 + Msum1) + rsum,  q odd.
c
c    HMAX   INTEGER.
c           Maximum number of Householder transformations to be used in 
c           the computation.  A sufficient value of  HMAX  may be computed
c           as follows:
c           let  q, r, rsum, Msum1 be defined as for GMAX above. In addition,
c           let: Msum = M*(M+1)/2 
c           then
c                     |     (q/2)*(Msum*(q-2)/2 + rsum + 1) + M,   q even
c              HMAX = |
c                     | ((q-1)/2)*(Msum*(q-1)/2 + rsum + M-r) + r, q odd.
c
c
c           The following code computes GMAX and HMAX for given N and M
c
c              INTEGER   N, M
c              INTEGER   Q, Q2, R, RSUM, MSUM, MSUM1, GMAX, HMAX
c              LOGICAL   EVEN
c              .. assume N and M are initialised and carry on ..
c              Q = IFIX(N/M)
c              Q2 = IFIX(Q/2)
c              R = N-Q*M
c              RSUM = R*(R+1)/2
c              MSUM = M*(M+1)/2
c              MSUM1 = M*(M-1)/2
c              EVEN = (Q2*2 .EQ. Q)
c              IF (EVEN) THEN
c                  GMAX = (Q2)*(1 + MSUM1) + M-R
c                  HMAX = (Q2)*(1 + RSUM + (Q2-1)*MSUM) + M
c              ELSE
c                  GMAX = (Q2)*(1 + MSUM1) + RSUM
c                  HMAX = (Q2)*(M-R + RSUM + Q2*MSUM) + R
c              END IF
c
c           and the following declarations define less stringent but simpler
c           values of GMAX and HMAX    
c             (Here we set N=M=20 for no particular reason other than 
c              supplying a value)
c
c              INTEGER   N, M
c              PARAMETER (N = 20, M = 20)
c              INTEGER   Q, R, RSUM, MSUM, MSUM1
c              PARAMETER (Q = N/M,  R = N-Q*M,  RSUM = R*(R+1)/2)
c              PARAMETER (MSUM = M*(M+1)/2,  MSUM1 = M*(M-1)/2)
c              INTEGER   GMAX
c              PARAMETER (GMAX = (Q/2)*(1 + MSUM1) + M*(R+2)/2)
c              INTEGER   HMAX
c              PARAMETER (HMAX = (Q/2)*(MSUM*Q/2 + RSUM + M-R) + M)
c
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the state
c           transition matrix A in controllability (upper staircase) form,
c           with staircase blocks in upper triangular form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the input
c           matrix B in controllability (upper staircase) form.
c           Note: this array is overwritten.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c    LDF    INTEGER.
c           Row dimension of array F, as declared in the calling program
c           LDF .ge. M.
c
c    EIGS   DOUBLE PRECISION array of DIMENSION (N).
c           Vector of eigenvalues to be allocated.
c           The complex eigenvalues (there are NCMPLX of them) must occur as
c           conjugate pairs.  They are stored in EIGS(1:NCMPLX),  and the
c           real eigenvalues (there are N-NCMPLX of them) are stored in
c           EIGS(NCMPLX+1:N)
c           Since the real and imaginary parts of a complex number 
c           also determine its conjugate, only one real part and one
c           imaginary part are stored for each pair of conjugates. These
c           parts are stored in successive elements of EIGS, with the real
c           parts having odd indices.
c
c           EXAMPLE:
c              To store the four complex eigenvalues
c                     (0.1, 0.2), (0.1, -0.2), (0.3, -0.4), (0.3, 0.4)
c              and the two real eigenvalues
c                     0.5, 0.6
c              EIGS may be initialized to
c                     0.1, 0.2, 0.3, -0.4, 0.5, 0.6
c
c           Observe that for odd i < NCMPLX,  EIGS(i) and EIGS(i+1) are the
c           real and imaginary parts, respectively, of either member of a
c           pair of complex conjugate eigenvalues, as required.
c
c           Note: this array is overwritten. (That is, it may be rearranged).
c
c    KMAX   INTEGER.
c           Controllability index of the system [B,A],
c           i.e. the number of stairs in the staircase form.
c
c    KSTAIR INTEGER array of DIMENSION (1+KMAX).
c           The leading KMAX elements must contain the ranks of B and the
c           staircase blocks of A, so that     
c           KSTAIR (1) = rank of B, 
c           KSTAIR (k) = rank of (k,k-1) block element of A, for k=2:KMAX,
c                        and 
c           KSTAIR (KMAX+1) = 0 is set by the routine.
c           Note: this array is overwritten.
c
c
c    Arguments Out
c    -------------
c
c    NCMPLX INTEGER.
c           Number of complex eigenvalues that were not allocated.
c           Complex eigenvalues are always allocated as conjugate pairs, so 
c           NCMPLX will always be even.
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           This array contains no useful information.
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           This array contains no useful information.
c
c    F      DOUBLE PRECISION array of DIMENSION (LDF,N).
c           The leading M by N part of this array contains the computed
c           gain matrix "F".
c           If the given data has M>N, then the first M-N rows of F
c           are set to zero.
c
c    EIGS   DOUBLE PRECISION array of DIMENSION (N).
c           Vector of allocated eigenvalues followed by eigenvalues 
c           that were not allocated, if any.
c           The number of successfully allocated eigenvalues is returned
c           in INFO(1).  (See INFO below).
c           Order of eigenvalues in EIGS may differ from the original 
c           insofar as the eigenvalue origially stored as EIGS(N) may
c           be moved to EIGS(I), with I .ne. N.   
c           Then the eigenvalues originally stored in EIGS(I:N-1) will
c           be shifted to EIGS(I+1:N), with no additional re-ordering.
c           This can occur only if N is odd (and hence EIGS(N) is real)
c           The index I is returned to the calling program in INFO(2). 
c           (See INFO below).
c
c    KSTAIR INTEGER array of DIMENSION (KMAX+1).
c           This array contains no useful information.
c
c    INFO   INTEGER array of DIMENSION (2).
c           INFO(1) returns number of successfully allocated eigenvalues.
c           INFO(2) returns index in EIGS of eigenvalue originally stored
c                   as EIGS(N), ie on exit EIGS(INFO(2)) contains the value
c                   that was stored in EIGS(N) on entry. (See also EIGS above).
c
c
c    Work Space
c    ----------
c
c    RWORK  DOUBLE PRECISION array of DIMENSION (3N + 2*GMAX + 3*HMAX).
c
c    IWORK  INTEGER array of DIMENSION (N + N/2 + GMAX + HMAX).
c
c
c    Tolerances
c    ----------
c
c    TOL    DOUBLE PRECISION.
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER.
c           Unless M>N, or the ranks of the staircase blocks do not sum to N
c           (see Warnings and Errors below), IWARN comtains 0 on exit.
c           
c
c    Error Indicator
c    ---------------
c
c    IERR   INTEGER.
c           Unless the routine detects an error (see next section),
c           IERR contains 0 on exit.
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    IWARN = 1  On entry, M > N.
c               In this case the first N-M rows of F can be freely
c               chosen and will not be stored.
c
c    IWARN = 2  Sum of ranks of staircase blocks is not equal to N.
c
c    IWARN = 3  On entry, conditions for  iwarn=1  and  iwarn=2 
c               both exist.
c
c
c    IERR < 0   IERR = -j indicates a problem with the j-th argument
c               on entry.  Specifically:
c               IERR = -1   On entry,  N < 1
c               IERR = -2   On entry,  M < 1
c               IERR = -3   On entry,  NCMPLX < 0
c                                 or   NCMPLX > N
c                                 or   NCMPLX is an odd number
c               IERR = -4   On entry,  GMAX < 1
c               IERR = -5   On entry,  HMAX < 1
c               IERR = -7   On entry,  LDA < N
c               IERR = -9   On entry,  LDB < N
c               IERR = -11  On entry,  LDF < M
c               IERR = -13  On entry,  KMAX > N
c                                 or   KMAX < 0
c
c    IERR = 1   Signifies attempt to divide by zero (ie a magnitude
c               less than TOL), or to solve a numerically singular
c               system of equations.
c
c    IERR = 2   During eigenvalue assignment a rank defficiency is
c               discovered in one of the staircase blocks, indicating
c               the system (B,A) is uncontrollable and assignment of
c               eigenvalues can proceed no farther.
c
c    IERR = 3   Signifies insufficient storage space for Givens rotations.
c               The quantity  GMAX  needs to be increased.
c
c    IERR = 4   Signifies insufficient storage space for Householder
c               transformations.  The quantity  HMAX  needs to be increased.
c
c
c    Method
c    ======
c
c    An orthogonal matrix Q is computed along with the feedback matrix F so
c    that  Q'(A-BF)Q is in its real Schur form with specified eigenvalues.
c    The algorithm allocates two eigenvalues at a time in a series of double
c    steps. During the first double step, for example, the algorithm computes
c    orthogonal matrix Q1, say, and the first two columns of F*Q1, so that
c
c                  | a b | * * .. * |
c                  | c d | * * .. * |
c    Q1'(A-BF)Q1 = |-----|----------|
c                  |     | AA-BB*FF |
c
c    with  |a b|
c          |c d|  having two specified eigenvalues, and (BB, AA) being in
c    staircase form.  The orthogonal matrix Q is the product of N/2  or 
c    (N-1)/2 + 1 (depending on whether N is even or odd) orthogonal matrices
c    of the type Q1.
c
c
c    References
c    ==========
c
c    [1]  G. S. Miminis and C.C. Paige,
c         A double step algorithm for pole assignment of time invariant
c         multi-input linear systems using state feedback,
c         Technical Report 8908, Department of Computer Science,
c         Memorial University of Newfoundland, 1989.
c
c
c    Numerical Aspects
c    =================
c     
c    The computation uses only real arithmetic, allocating complex eigenvalues
c    as conjugate pairs in "double steps".
c
c    The algorithm requires O( n(n**2 + m(n-m)) ) operations
c    (see ref [1]).
c
c
c    Contributors
c    ============
c
c    G. Miminis and H. Roth  (Memorial University of Newfoundland, Canada)
c
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c  == ==================================================================
c  == ==================================================================
c
c  declarations
c  ============
c
c     implicit none
c
c  arguments
      integer          n, m, ncmplx, gmax, hmax, lda, ldb, ldf
      double precision A(lda,*), B(ldb,*), F(ldf,*), eigs(*)
      integer          kmax, kstair(*), info(*), iwork(*)
      double precision rwork(*), tol
      integer          iwarn, ierr
c
c  parameters
      double precision  dzero
      parameter        (dzero = 0.0d0)
      integer           izero
      parameter        (izero = 0)
c
c  external subroutines
      external dcopy, dmvs1
c
c  local variables
      integer i, ilen, rlen
c
c
c  code starts here
c  ================
c
c  initialize
c  ==========
        info(1) = 0
        info(2) = 0
        iwarn = 0
        ierr = 0
c
c  check some input arguments 
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, ncmplx, gmax, hmax   A, lda, B, ldb, F,   ldf, eigs, 
c         kmax, kstair, info,   iwork, rwork, tol, iwarn, ierr)
      IF( (kmax .gt. n) .OR. (kmax .lt. 0) ) ierr = -13
      IF( ldf .lt. m ) ierr = -11
      IF( ldb .lt. n ) ierr = -9
      IF( lda .lt. n ) ierr = -7
      IF( hmax .lt. 1 ) ierr = -5
      IF( gmax .lt. 1 ) ierr = -4
      IF( (ncmplx .lt. 0) .OR. ((ncmplx/2)*2 .ne. ncmplx)
     &  .OR. (ncmplx .gt. n) ) ierr = -3
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  set kstair(kmax+1) to zero as required for dmvs1
      kstair(kmax+1) = 0
c
c  clear the workspace
c  ===================
      rlen = 2*gmax + 3*hmax + 3*n
      ilen = gmax + hmax + n/2 + n
c
      call dcopy( rlen, dzero, 0, rwork, 1 )
c
      do 60 i = 1, ilen
          iwork(i) = izero
   60 continue
c
c  summarize the workspace partitioning
c  ====================================
c     .. QG    starts at rwork(1);                has dimension(2,gmax)
c     .. QH    starts at rwork(1+2*gmax);         has dimension(3,hmax)
c     .. Rwork starts at rwork(1+2*gmax+3*hmax);  has length 3N
c              min length(rwork) = 2*gmax+3*hmax+3*N
c     .. GCOL  starts at iwork(1);                has length gmax
c     .. HCOL  starts at iwork(1+gmax);           has length hmax
c     .. FCOL  starts at iwork(1+gmax+hmax);      has length N/2
c     .. Iwork starts at iwork(1+gmax+hmax+N/2);  has length N
c              min length(iwork) = gmax+hmax+N/2+N
c
c  do the job
c  ==========
      call dmvs1 (n,m,ncmplx, A,lda, B,ldb, F,ldf, eigs, kstair,
     &            info, rwork(1), 2, gmax, iwork(1),
     &            rwork(1+2*gmax), 3, hmax, iwork(1+gmax),
     &            iwork(1+gmax+hmax), tol, iwork(1+gmax+hmax+N/2),
     &            rwork(1+2*gmax+3*hmax), iwarn, ierr)
c
 9000 continue
      return
c  last line of subroutine dmevas follows
      end
c
c==== ==================================================================
c==== ==================================================================
c
      subroutine dmvs1 (n,m,ncmplx, A,lda, B,ldb, F,ldf,
     &                  l, nn, info, QG,ldqg, colqg, Gcol,
     &                  QH,ldqh, colqh, Hcol, Fcol,
     &                  tol, Iwork, Rwork, iwarn, ierr)
c
c
c    Purpose
c    =======
c
c    To compute a real matrix F so that the "closed-loop" matrix (A - B*F)
c    has a specified set of eigenvalues.
c
c    Here A and B are real matrices such that the system (B,A) is in "upper
c    staircase" (or "controllability") form, and
c    the set of specified eigenvalues has the property that the complex
c    conjugate of any complex member is also a member.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER
c           Row and column dimension of matrix A
c           Row dimension of matrix B
c           Column dimension of matrix F
c           Length of vector of eigenvalues L
c           N .ge. 1
c
c    M      INTEGER
c           Column dimension of matrix B
c           Row dimension of matrix F
c           M .ge. 1
c
c    NCMPLX INTEGER
c           (Even) number of complex eigenvalues in L. (See L below)
c           0 .le. NCMPLX .le. N;  NCMPLX even
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N)
c           The leading N by N part of this array must contain the state
c           transition matrix A in controllability (upper staircase) form,
c           with the staircase blocks in upper triangular form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER
c           Row dimension of array A, as declared in the calling program.
c           LDA .ge. N
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M)
c           The leading N by M part of this array must contain the input
c           matrix B in controllability form.
c           Note: this array is overwritten
c
c    LDB    INTEGER
c           Row dimension of array B, as declared in the calling program.
c           LDB .ge. N
c
c    LDF    INTEGER
c           Row dimension of array F, as declared in the calling program.
c           LDF .ge. M
c
c    L      DOUBLE PRECISION array of DIMENSION (N)
c           Vector of eigenvalues to be allocated.
c           The complex eigenvalues (there are NCMPLX of them) must occur as
c           conjugate pairs.  They are stored in L(1:NCMPLX),  and the
c           real eigenvalues (there are N-NCMPLX of them) are stored in
c           L(NCMPLX+1:N)
c           Since the real and imaginary parts of a complex number 
c           also determine its conjugate, only one real part and one
c           imaginary part are stored for each pair of conjugates. These
c           parts are stored in successive elements of L, with the real
c           parts having odd indices.
c
c           EXAMPLE:
c              To store the four complex eigenvalues
c                     (0.1, 0.2), (0.1, -0.2), (0.3, -0.4), (0.3, 0.4)
c              and the two real eigenvalues
c                     0.5, 0.6
c              L may be initialized to
c                     0.1, 0.2, 0.3, -0.4, 0.5, 0.6
c
c           Observe that for odd i < NCMPLX,  L(i) and L(i+1) are the
c           real and imaginary parts, respectively, of either member of a
c           pair of complex conjugate eigenvalues, as required.
c
c           Note: this array is overwritten. (That is, it may be rearranged).
c
c    NN     INTEGER array of DIMENSION (kp1)
c           where kp1 = (1 + controllability index)  of the system [B,A],  
c           Vector of ranks of B and staircase blocks of A.
c           NN(1) = rank of B
c           NN(k) = rank of (k,k-1) block element of A, for k = 2,...,kp1-1
c           Furthermore, it is important that
c                          NN(kp1) = 0  
c           as the subroutine assumes the existence of this dummy value.
c           Note: this array is overwritten
c
c    LDQG   INTEGER
c           Leading dimension of the array QG, as declared in the calling
c           program. Require  LDQG .GE. 2
c
c    COLQG  INTEGER
c           Number of columns of array QG.
c           A sufficiently large value of COLQG is  g  calculated as follows
c              let: mu = NN(1) = rank(B)
c                   a,b be non-negative integers such that  N = a*mu + b,  b<mu
c                   bsum = b*(b+1)/2,
c                   musum1 = (mu-1)*mu/2
c              then
c                       | ( a/2 )*( 1 + musum1 ) + mu - b ,       a even
c                   g = |
c                       | ( (a-1)/2 )*( 1 + musum1 ) + bsum ,     a odd
c
c    LDQH   INTEGER
c           Leading dimension of the array QH, as declared in the calling
c           program.
c           Require LDQH .GE. 3
c
c    COLQH  INTEGER
c           Number of columns of array QH.
c           A sufficiently large value of COLQH is  h  calculated as follows
c              let: mu, a, b, bsum1  be defined as above (see COLQG)
c                   musum = mu*(mu+1)/2
c              then
c                     | ( a/2 )*( musum*(a-2)/2 + bsum + 1 ) + mu,       a even
c                 h = |
c                     | ( (a-1)/2 )*( musum*(a-1)/2 + bsum + mu-b ) + b, a odd
c
c
c    Arguments out
c    -------------
c
c    NCMPLX INTEGER
c           Number of complex eigenvalues that were not allocated.
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N)
c           This array contains no useful information.
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M)
c           This array contains no useful information.
c
c    F      DOUBLE PRECISION array of DIMENSION (LDF,N)
c           The leading M by N part of this array contains the computed
c           gain matrix "F" 
c           If the given data has M>N, then the first M-N rows of F 
c           are set to zero.
c
c    L      DOUBLE PRECISION array of DIMENSION (N)
c           Vector of allocated eigenvalues followed by eigenvalues 
c           that were not allocated.
c           Order of eigenvalues in L may differ from the original 
c           insofar as the eigenvalue origially stored as L(N) may
c           be moved to L(I), I .ne. N.   
c           Then the eigenvalues originally stored in L(I:N-1) will
c           be shifted to L(I+1:N), with no additional re-ordering.
c           The index I is returned to the calling program in INFO(2)
c
c    NN     INTEGER array of DIMENSION (kp1)
c           This array contains no useful information.
c
c    INFO   INTEGER array of DIMENSION (2)
c           INFO(1) returns number of successfully allocated eigenvalues.
c           INFO(2) returns index in L of eigenvalue originally stored
c                   as L(N)
c
c    QG     DOUBLE PRECISION array of DIMENSION (LDQG,COLQG)
c           Stores the Givens rotations used in the computation.
c
c    GCOL   INTEGER array of DIMENSION (COLQG)
c           Vector storing index associated with each stored rotation
c
c    QH     DOUBLE PRECISION array of DIMENSION (LDQH,COLQH)
c           Stores the Householder reflectors used in the computation.
c
c    HCOL   INTEGER array of DIMENSION (COLQH)
c           Vector storing index associated with each stored Householder
c
c    FCOL   INTEGER array of DIMENSION (N/2)
c           Vector of indeces indicating portions of feedback "F" to which
c           rotations comprising "P" have been applied. (see ref[1] for 
c           further details)
c
c
c    Work Space
c    ----------
c
c    IWORK  INTEGER array of DIMENSION (N)
c
c    RWORK  DOUBLE PRECISION array of DIMENSION (3*N)
c
c
c    Tolerances
c    ----------
c
c    TOL    DOUBLE PRECISION
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm 
c           See LAPACK routine DLAMCH for details on computation of "eps"
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER
c           Unless M>N or the ranks of the staircase blocks do not sum to N
c           (see Warnings and Errors below), IWARN comtains 0 on exit
c           
c
c    Error Indicator
c    ---------------
c
c    IERR   INTEGER
c           Unless the routine detects an error (see next section),
c           IERR contains 0 on exit
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    IWARN = 1  On entry, M>N
c               In this case the first M-N rows of F can be freely chosen and 
c               will be neither computed nor stored.
c
c    IWARN = 2  Sum of ranks of staircase blocks is not equal to N.
c
c    IWARN = 3  On entry, conditions for  iwarn=1  and  iwarn=2 
c               both exist.
c
c
c    IERR = 1   Attempt to divide by zero or to solve singular system of 
c               equations. Here zero means any magnitude less than TOL
c
c    IERR = 2   Rank of the current deflated matrix is too low, indicating the
c               given system (B,A) is found to be too close (ie within TOL)
c               to an uncontrollable system.
c
c    IERR = 3   On entry, COLQG is too small for the number of Givens
c               transformations required for the computation.
c
c    IERR = 4   On entry, COLQH is too small for the number of Householder
c               transformations required for the computation.
c
c
c    Method
c    ======
c
c    An orthogonal matrix Q is computed along with the feedback matrix F so
c    that  Q'(A-BF)Q is in its real Schur form with specified eigenvalues.
c    The algorithm allocates two eigenvalues at a time in a series of double
c    steps. During the first double step, for example, the algorithm computes
c    orthogonal matrix Q1, say, and the first two columns of F*Q1, so that
c
c                  | a b | * * .. * |
c                  | c d | * * .. * |
c    Q1'(A-BF)Q1 = |-----|----------|
c                  |     | AA-BB*FF |
c
c    with  |a b|
c          |c d|  having two specified eigenvalues, and (BB, AA) being in
c    staircase form.  The orthogonal matrix Q is the product of N/2  or 
c    (N-1)/2 + 1 (depending on whether N is even or odd) orthogonal matrices
c    of the type Q1.
c
c
c    References
c    ==========
c
c    [1]  G. S. Miminis and C.C. Paige,
c         A double step algorithm for pole assignment of time invariant
c         multi-input linear systems using state feedback,
c         Technical Report 8908, Department of Computer Science,
c         Memorial University of Newfoundland, 1989.
c
c
c    Numerical Aspects
c    =================
c
c    The algorithm requires O(N(N^2 + M(N-M))) operations. (see ref [1])
c    The computation uses only real arithmetic, allocating complex 
c    eigenvalues as conjugate pairs in double steps.
c
c
c    Additional Comments
c    ===================
c
c    In the course of the computation of F, DMVS1 applies a number of
c    Givens rotations and Householder reflectors whose inverses are
c    applied later. 
c
c    Each Householder reflector used in the subroutine is computed to 
c    eliminate the first two elements of a 3-vector into the third.  
c    Thus the reflector can be completely specified by a three-element 
c    vector v:  H = I-2vv'/v'v,  where v' is the transpose of v.
c    In DMVS1, the vector v is computed so that its third element is 
c    normalized to unity.  Since the value of v(3) is known, it need not
c    be stored and v(3) is used to store  v'v/2 instead.
c    The individual vectors are stored in columns of the 3xh matrix QH,
c    where h is the maximum number of Householders that may be expected.
c    Associated with each householder is an index indicating where the 
c    reflector is to be applied to a vector (ie which 3 elements of an
c    n-component vector will be affected).  This index is stored in the
c    corresponding element of Hcol.  Thus if the Householder stored at
c    QH(j) is to be applied to a vector at index i, then Hcol(j) is 
c    assigned the value i.
c    When a householder is computed to eliminate x(1) and x(2) into x(3),
c    not only is the vector v computed as above, but also x is overwritten
c    by Hx.
c
c    Similarly, each Givens rotation can be specified by a two-element
c    vector.  Each such vector is stored in a column of the 2xg matrix QG,
c    where g represents the maximum number of rotations expected.  The
c    associated index is stored in the corresponding element of the
c    vector Gcol.  The Givens rotations are computed and applied by the
c    BLAS routines DROTG and DROT respectively.
c
c    The subprogram first computes P'FQ and then applies P from the left
c    and Q' from the right to extract F.  
c    P' consists entirely of rotations and is stored in QG beginning at
c    high column index and progressing toward lower column indeces.
c    The individual rotations of P' apply to only part of F, the
c    associated index of F being stored in the vector Fcol. 
c    Q consists of both rotations and reflectors computed in each 
c    deflation step.  The rotations and reflectors of Q are both stored
c    by increasing column index beginning at column 1 in QG and QH
c    respectively.  The end of each step is marked in the structures by
c    setting negative in Gcol and Hcol the indeces associated with the
c    last rotation and reflector in that step.
c
c    If in a particular step a Householder but no rotation is required,
c    a dummy rotation is inserted into QG and recognized by its
c    associated index in Gcol, which is given the value zero.  
c    Similarly if a rotation but no Householder is required, a dummy
c    Householder is introduced with associated index equal to zero
c    placed in Hcol.  These manoeuvres facilitate the application of Q'.
c
c
c    Contributors
c    ============
c 
c    G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c  arguments
c     implicit         none
      integer          lda, n, ldb, m, ldf, ncmplx, nn(*)
      double precision A(lda,*), B(ldb,*), F(ldf,*), l(*), tol
      integer          ldqg, colqg, Gcol(*)
      integer          ldqh, colqh, Hcol(*), Fcol(*)
      double precision QG(ldqg,*), QH(ldqh,*), Rwork(*)
      integer          info(*), Iwork(*), iwarn, ierr
c
c
c  parameters
      double precision zero, one, two
      parameter (zero=0.0d0, one=1.0d0, two=2.0d0)
      integer ok
      parameter (ok=0)
c
c  local variables
      integer status, lnpos
      integer m0, m1, nm2
      integer i, j, j1, k, s, ss, itmp, infot, oddn, step, step1
      integer Bfree, Bfree1, free, free1, r, q, size, row, col
      integer Findex, Gindex, Hindex, Pindex, Pstart
      double precision atmp, cx, sx, lsum, lprod, f11, f12
      double precision eps
c      
c  intrinsic functions
      intrinsic min, max, abs
c
c  external functions
c   BLAS:     ddot
c   LAPACK:   dlamch
c   PACKAGE:  d1nrmU, d1nrmA
      double precision  ddot, dlamch, d1nrmU, d1nrmA
      external  ddot, dlamch, d1nrmU, d1nrmA
c
c  external subroutines
c   BLAS:
      external dcopy, drotg, drot, dswap
c   PACKAGE
      external dtinvb, dhhldr, dhhrfl, dabort
c     note:
c          dtinvb calls LAPACK routines dtrtrs, dtrcon
c          d1nrmU, d1nrmA call BLAS routine dasum
c
c
c  INITIALIZATION
c  **************
c
      status = 0
      lnpos = n
      iwarn = 0
      ierr  = 0
c
c  ====================================================================
c  Input arguments are checked by the driver subroutine dmevas.
c  Hence the following checks are commented out and not mentioned
c  in the documentation, but may be useful for further development.
c  
c  the arguments to dmvs1 are
c     n, m, ncmplx, A, lda,        B, ldb, F, ldf, l,
c     nn, info, QG, ldqg, colqg,   Gcol, QH, ldqh, colqh, Hcol,
c     Fcol, tol Iwork, Rwork, iwarn,   ierr
c
c  check some input arguments
c     IF (colqh .LT. 1) ierr = -19
c     IF (ldqh .LT. 3) ierr = -18
c     IF (colqg .LT. 1) ierr = -15
c     IF (ldqg .LT. 2) ierr = -14
c     IF (ldf .LT. m) ierr = -9
c     IF (ldb .LT. n) ierr = -7
c     IF (lda .LT. n) ierr = -5
c     IF( (ncmplx .LT. 0) .OR. ((ncmplx/2)*2 .NE. ncmplx)
c    &  .OR. (ncmplx .gt. n) ) ierr = -3
c     IF (m .LT. 1) ierr = -2
c     IF (n .LT. 1) ierr = -1
c
c     IF (ierr .lt. 0) THEN
c         GOTO 9900
c     ENDIF
c  ====================================================================
c
c  check that sum of ranks of staircase blocks is equal to N
c  if not set iwarn = 2
      k = 1
      itmp = N
c     do while ((nn(k) .ne. 0) .and. (k .le. N))
   70 IF ((nn(k) .ne. 0) .and. (k .le. N)) then
         itmp = itmp - nn(k)
         k = k + 1
         go to 70
      ENDIF
      IF (itmp .ne. 0) then
         iwarn = 2
      ENDIF
c
c     lnpos indicates position in final l-vector of initial l(n)
c     Bfree initialises to number of leading zero columns in B
c     free keeps number of leading zero rows in current A
c     step: A(step,step) is leading element in current A
c     Gindex is index to current Givens rotation in "Q"
c     Hindex is index to current Householder reflector in "Q"
c     Pindex is index to current Givens rotation in "P"
c     Findex points to first of columns of F which receive application
c          of current rotation in "P"
c     Pstart is index to first rotation (if any) in "P"
c     oddn = 1 if n is odd; 0 otherwise
c     m0 stores initial m and 
c     m1 is initialized to min(m,n). A warning is given if m>n. 
c
      m0 = m
      IF (m .LE. n) then
          m1 = m
      ELSE
          m1 = n
          iwarn = iwarn + 1
      ENDIF
      Bfree = m0-nn(1)
      Bfree1 = Bfree+1
      free = m1-nn(1)
      free1 = free+1
      step=1
      Gindex=0
      Hindex=0
      Findex=0
      Pstart=colqg+1
      Pindex=Pstart
      oddn = n-(n/2)*2
c
c  reset "tol" for numerical singularity, if necessary
c
c     .. calculate machine epsilon and store in "eps"
      eps = dlamch('e')
      IF (tol .lt. eps) then
c         .. compute 1-norm of system [B,A] and reset tol
          atmp = max(d1nrmU(B(1,Bfree1),ldb,nn(1)), d1nrmA(A,lda,n) )
          tol = (n+m1) * atmp * eps
      ENDIF
c
c
c  INITIAL IMMEDIATE ALLOCATIONS
c  *****************************
c
      s=nn(1)-nn(2)
      ss=(s/2)*2
      itmp = min(ss, ncmplx)
      IF (ss .GT. 0) then
            DO 110 i=2,itmp,2
               A(i-1,i-1) = A(i-1,i-1) - l(i-1)
               A(i,i-1) = A(i,i-1) + l(i)
               A(i,i) = A(i,i) - l(i-1)
               A(i-1,i) = A(i-1,i) - l(i)
  110       CONTINUE    
            ncmplx = ncmplx-itmp
            DO 120 i=itmp+1,ss
               A(i,i) = A(i,i) - l(i)
  120       CONTINUE
      ENDIF
c
c     If  s  and  n  both odd then allocate a real eigenvalue;
c     in particular allocate  l(n), the last eigenvalue in l,
c     shift l(s:n-1) to l(s+1:n), and set ss=s
c
      IF ((ss .NE. s) .AND. (oddn .NE. 0)) then
          atmp = l(n)
          call dcopy (n-s, l(s), -1, l(s+1), -1)
          l(s) = atmp
          A(s,s) = A(s,s) - atmp
          ss = s
          lnpos = s
      ENDIF
c
      IF (ss .GT. 0) then
          call dtinvb( B(step,Bfree1), ldb, nn(1), 
     &                 A, lda, ss, Iwork, Rwork, tol, infot )
          IF (infot .NE. ok) then
                   ierr = 1
                   call dabort(A, lda, m1, n, 0)
                   GOTO 9000
          ENDIF
c
c         relocate computed cols if free>0
          IF (free .GT. 0) then
              DO 140 j=1,ss
                  call dcopy(nn(1), A(1,j), -1, A(free1,j), -1)
                  call dcopy(free, zero, 0, A(1,j), 1)
  140         CONTINUE
          ENDIF
c
          IF (nn(1) .EQ. n) then
              status = n
              GOTO 9000
          ENDIF
      ENDIF
c
c     updates
      status = ss
      free = free+ss
      free1 = free+1
      Bfree = Bfree+ss
      Bfree1 = Bfree+1
      nn(1) = nn(1)-ss
      step = ss+1
c
c
c  DEFLATIONARY LOOP:
c  *****************
c
      nm2 = n-2
c     do while( step .LE. nm2  .AND.  nn(1)+nn(2) .GE. 2)
  200 IF ((step .LE. nm2) .AND. (nn(1)+nn(2) .GE. 2))  then
c               The second clause of the condition handles some 
c               pathological cases that can arise when SUM(nn(i)) < N
c
          s=nn(1)-nn(2)
c
          IF ( (s .EQ. 1) .AND. (oddn .EQ. 1) ) then
c
c            begin CASE 1.  Immediate single allocation of l(n)
c            ************
c
             atmp = l(n)
             call dcopy(n-step, l(step), -1, l(step+1), -1)
             l(step) = atmp
             lnpos = step
             A(step,step)=A(step,step)-atmp
c
             free1 = free+1
             Bfree1 = Bfree+1
             call dtinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 1, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call dabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate 'F'
             IF (free1 .LT. step) then
                 call dcopy(nn(1), A(step,step), 1, A(free1,step), 1)
             ELSE
                 IF (free1 .GT. step) then
                    call dcopy(nn(1), A(step,step),-1, A(free1,step),-1)
                 ENDIF
             ENDIF
             call dcopy(free, zero, 0, A(1,step), 1)
c
c            updates
             status = status+1
             nn(1) = nn(2)
             step = step+1
             free = free1
             free1 = free+1
             Bfree = Bfree1
             Bfree1 = Bfree+1
             oddn = 0
c            end case 1: immediate single allocation
c
          ELSE IF (s .EQ. 2) then
c
c            begin CASE 2.  Immediate double allocation of l(step), l(step+1)
c            ************ 
c
             free1 = free+1
             Bfree1 = Bfree+1
             step1 = step+1
             IF (ncmplx .GT. 0) then
                A(step,step) = A(step,step)-l(step)
                A(step1,step) = A(step1,step)+l(step1)
                A(step1,step1) = A(step1,step1)-l(step)
                A(step,step1) = A(step,step1)-l(step+1)
             ELSE
                A(step,step) = A(step,step)-l(step)
                A(step1,step1) = A(step1,step1)-l(step1)
             ENDIF
             call dtinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 2, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call dabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate 'F'
             IF (free1 .LT. step) then
                 call dcopy(nn(1), A(step,step),  1, A(free1,step),  1)
                 call dcopy(nn(1), A(step,step1), 1, A(free1,step1), 1)
             ELSE IF (free1 .GT. step) then
                 call dcopy(nn(1), A(step,step), -1, A(free1,step), -1)
                 call dcopy(nn(1), A(step,step1),-1, A(free1,step1),-1)
             ENDIF
                 call dcopy(free, zero, 0, A(1,step),  1)
                 call dcopy(free, zero, 0, A(1,step1), 1)

             IF (ncmplx .GT. 0) then
                 ncmplx = ncmplx-2
             ENDIF
c
c            update
             status = status+2
             nn(1) = nn(2)
             free = free+2
             free1 = free+1
             Bfree = Bfree+2
             Bfree1 = Bfree+1
             step = step+2
c
c            end CASE 2.  Immediate double allocation of l(step), l(step+1)
c
          ELSE
c
c            begin CASE 3: cases (s=0) OR (s=1 and n even)
c            ************
c
c            FIND NEXT r
             r=2
  300        CONTINUE
             IF ( nn(r) .EQ. nn(r+1) )  then
                r = r+1
                goto 300
             ENDIF
c
             IF ( r .GT. 2 ) then
c
c               begin CASE 3a.   regular double allocation  ( r>2 )
c               -------------
c
                q=nn(r)
                size = step-1 + nn(1) + (r-1)*q
                row = size-q+1
                col = row-q
c
c               Form row of N, taking advantage of upper Hessenberg structure,
c               and store in Rwork(1:n)
c               First non-zero in row-th row of A is in column col
c               First non-zero in row-th row of N is in column col-q
c               Use contiguous copy of row-th row of A
c
                IF (ncmplx .GT. 0) then
                    lsum = two * l(step)
                    lprod = l(step)**2 + l(step+1)**2
                ELSE 
                    lsum = l(step) + l(step+1)
                    lprod = l(step) * l(step+1)
                ENDIF
c
c               copy row-th row of A to Rwork(n+1:2n)
c               first non zero will be in Rwork(n+col)
                call dcopy(n, A(row,1), lda, Rwork(n+1), 1)
c
                ss = n+col
                itmp = col-q
                DO 350 j=itmp,row-1
                    k = j-itmp+1
c                     = # non-zeros in j-th column of A(col:size,col-q:size-q)
                    Rwork(j) = ddot(k, Rwork(ss), 1, A(col,j), 1) 
     &                           - lsum*A(row,j)
  350           CONTINUE
c
                k = 2*q
                Rwork(row) = lprod - lsum*A(row,j) +
     &                         ddot(k, Rwork(ss), 1, A(col,j), 1)
c
                DO 360 j=row+1,size
                    Rwork(j) = ddot(k, Rwork(ss), 1, A(col,j), 1)
     &                           - lsum*A(row,j)
  360           CONTINUE
c
c               P1:  first q-1 rotations
c
                IF (q .EQ. 1) then
c                   dummy rotation (to facilitate back transformation)
                    Gindex = Gindex+1
                    IF (Gindex .ge. Pindex) THEN
                        Gindex = Gindex-1
                        ierr = 3
                        call dabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    Gcol(Gindex) = 0
                ELSE      
                    DO 420 i=size,size-q+2,-1
                        j = i-q
                        j1 = j+1
                        itmp = j-q
c
c                       compute rotation eliminating A(i,j) into A(i,j+1)
                        Gindex = Gindex+1
                        IF (Gindex .ge. Pindex) THEN
                            Gindex = Gindex-1
                            ierr = 3
                            call dabort(A, lda, m1, n, step-1)
                            GOTO 3000
                        ENDIF
                        call drotg( A(i,j1), A(i,j), cx, sx)
                        A(i,j) = zero
                        QG(1,Gindex) = cx 
                        QG(2,Gindex) = sx
                        Gcol(Gindex) = j
c
c                       post multiply A by computed rotation (to row i)
                        call drot( i-step, A(step,j1), 1,
     &                                  A(step,j), 1, cx, sx )
c
c                       pre multiply A by computed rotation (from column j-q)
                        call drot( n-itmp+1, A(j1,itmp), lda,
     &                                     A(j,itmp), lda, cx, sx )
c
c                       post multiply Rwork by computed rotation
                        call drot(1, Rwork(j1), 1, Rwork(j), 1, cx, sx)
  420               CONTINUE
                ENDIF
c
c               P2:  q-1 householders
c
                DO 480 i=row,row-q+2,-1
                    j=i-q-1
c                   compute Householder vector and store in QH(1:3,Hindex)
                    Hindex=Hindex+1
                    IF (Hindex .gt. colqh) THEN
                        Hindex = Hindex-1
                        ierr = 4
                        call dabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    call dhhldr( A(i,j), lda, tol, QH(1,Hindex))
                    Hcol(Hindex) = j
c
c                   post multiply A by computed Householder
                    DO 440 k=step,i-1
                        call dhhrfl( A(k,j), lda, QH(1,Hindex) )
  440               CONTINUE
c
c                   pre multiply A by computed Householder
                    DO 460 k=step,n
                        call dhhrfl( A(j,k), 1, QH(1,Hindex) )
  460               CONTINUE
c
c                   pre multiply B by computed Householder
                    DO 470 k=Bfree1,m0
                        call dhhrfl( B(j,k), 1, QH(1,Hindex) )
  470               CONTINUE
c
c                   post multiply Rwork by computed Householder
                    call dhhrfl( Rwork(j), 1, QH(1,Hindex) )
c
  480           CONTINUE
c
c               P3:   householder for row of N
c      
                j=col-q
                Hindex=Hindex+1
                IF (Hindex .gt. colqh) THEN
                    Hindex = Hindex-1
                    ierr = 4
                    call dabort(A, lda, m1, n, step-1)
                    GOTO 3000
                ENDIF
                call dhhldr (Rwork(j), 1, tol, QH(1,Hindex))
                Hcol(Hindex) = j
c
c               post multiply A by computed Householder
                DO 500 i=step,col+1
                   call dhhrfl( A(i,j), lda, QH(1,Hindex))
  500           CONTINUE
c
c               pre multiply A by computed Householder
                DO 510 i=step,n
                   call dhhrfl( A(j,i), 1, QH(1,Hindex))
  510           CONTINUE
c
c               pre multiply B by computed Householder
                DO 520 k=Bfree1,m0
                    call dhhrfl( B(j,k), 1, QH(1,Hindex) )
  520           CONTINUE
c
c               Compute P4: product of  nn(1)-(r-4)*q  Householders
c
c               P4a: all but the last of P4's Householders:
c
                DO 650 i=row-q+1,step+q+3,-1
                     j=i-q-2
                     Hindex=Hindex+1
                     IF (Hindex .gt. colqh) THEN
                         Hindex = Hindex-1
                         ierr = 4
                         call dabort(A, lda, m1, n, step-1)
                         GOTO 3000
                     ENDIF
                     call dhhldr( A(i,j), lda, tol, QH(1,Hindex) )
                     Hcol(Hindex) = j
c
c                    post multiply A by computed Householder
                     DO 600 k=step,i-1
                          call dhhrfl( A(k,j), lda, QH(1,Hindex) )
  600                CONTINUE
c
c                    pre multiply A by computed Householder
                     DO 610 k=step,n
                          call dhhrfl( A(j,k), 1, QH(1,Hindex) )
  610                CONTINUE
c
c                    pre multiply B by computed Householder 
                     DO 620 k=Bfree1,m0
                          call dhhrfl( B(j,k), 1, QH(1,Hindex) )
  620                CONTINUE
  650           CONTINUE
c
c               P4b: last householder if needed
c
                IF ( nn(1)+(r-4)*q .NE. 0 ) then
c
                    Hindex = Hindex+1
                    IF (Hindex .gt. colqh) THEN
                        Hindex = Hindex-1
                        ierr = 4
                        call dabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    Hcol(Hindex) = step
c
                    IF ( nn(1) .EQ. q ) then 
c                       case nn(1) = q
                        call dhhldr(A(step+q+2,step), lda, tol,
     &                                                   QH(1,Hindex))
c                       post multiply A by computed Householder
                        DO 670 k=step,step+q+1
                            call dhhrfl( A(k,step), lda, QH(1,Hindex) )
  670                   CONTINUE
                    ELSE
c                       case nn(1) = q+1
                        QH(1,Hindex) = -one
                        QH(2,Hindex) = zero
                        QH(3,Hindex) = one

c                       post multiply A by permuting Householder
                        call dswap(n-step+1, A(step,step), 1,
     &                                       A(step,step+2), 1)
                    ENDIF
c
c                   pre multiply A by computed Householder
                    DO 690 k=step,n
                        call dhhrfl( A(step,k), 1, QH(1,Hindex) )
  690               CONTINUE
c
c                   pre multiply B by  computed Householder 
                    DO 700 k=Bfree1,m0
                        call dhhrfl( B(step,k), 1, QH(1,Hindex) )
  700               CONTINUE
                ENDIF
c
                step1 = step+1
                itmp = step+2
                call dtinvb( B(itmp,Bfree1),ldb,nn(1), 
     &                A(itmp,step),lda,2, Iwork, Rwork, tol, infot)
c
                IF (infot .NE. ok) then
                    ierr = 1
                    call dabort(A, lda, m1, n, step-1)
                    GOTO 3000
                ENDIF
c
c               relocate computed cols of F to first m rows of A
                IF (free .LT. step1) then
c                   { free1 < itmp }
                    call dcopy(nn(1), A(itmp,step), 1, 
     &                                  A(free1,step), 1)
                    call dcopy(nn(1), A(itmp,step1), 1, 
     &                                  A(free1,step1), 1)
                ELSE IF (free .GT. step1) then
                    call dcopy(nn(1), A(itmp,step), -1, 
     &                                  A(free1,step), -1)
                    call dcopy(nn(1), A(itmp,step1), -1, 
     &                                  A(free1,step1), -1)
                ENDIF
                call dcopy(free, zero, 0, A(1,step),  1)
                call dcopy(free, zero, 0, A(1,step1), 1)
c
c               end CASE 3a.   regular double allocation  ( r>2 )
c
             ELSE
c
c               begin CASE 3b.   Case r=2
c               -------------
c
                q = nn(2)
c
                IF ( s .EQ. 0 ) then
c
c                 begin 3b SUB-CASE  r=2 with nn(1) = nn(2)
c                 -----------------------------------------
c
c                 P1:  q-1 rotations
c      
                  DO 1020 j=step-1+q,step+1,-1
                     i=j+q
c
c                    compute rotation eliminating A(i,j) into A(i,j+1)
                     call drotg( A(i,j+1), A(i,j), cx, sx)
                     A(i,j)=zero
                     Gindex = Gindex+1
                     IF (Gindex .ge. Pindex) THEN
                         Gindex = Gindex-1
                         ierr = 3
                         call dabort(A, lda, m1, n, step-1)
                         GOTO 3000
                     ENDIF
                     QG(1,Gindex) = cx
                     QG(2,Gindex) = sx
                     Gcol(Gindex) = j
c
c                    post multiply A by computed rotation
                     call drot(i-step,A(step,j+1),1,
     &                             A(step,j),1, cx, sx )
c
c                    pre multiply A by computed rotation
                     call drot(n-step+1,A(j+1,step),lda,
     &                             A(j,step),lda, cx, sx )
c
c                    premultiply B by computed rotation
                     call drot(m0-Bfree,B(j+1,Bfree1),ldb,
     &                             B(j,Bfree+1),ldb, cx, sx )
 1020             CONTINUE
c
c
c                 P2: dummy Householder
                  Hindex = Hindex+1
                  IF (Hindex .gt. colqh) THEN
                      Hindex = Hindex-1
                      ierr = 4
                      call dabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  Hcol(Hindex) = 0
c
c                 compute F10
                  IF( Bfree+2 .LE. m0 ) then
                      call dtinvb( B(step+2,Bfree+2),ldb,q-1, 
     &                             A(step+2,step),lda,2, 
     &                             Iwork, Rwork, tol, infot)
                      IF(infot .NE. ok) then
                         ierr = 1
                         call dabort(A, lda, m1, n, step-1)
                         GOTO 3000
                      ENDIF
c
c                     compute A10 - B01*F10
                      i=step
                      j=Bfree+2
                      A(i,i) = A(i,i) - ddot(q-1, B(i,j),ldb,
     &                                              A(i+2,i),1 )
                      A(i+1,i) = A(i+1,i) - ddot(q-1, B(i+1,j),ldb,
     &                                              A(i+2,i),1 )
                      A(i+1,i+1) = A(i+1,i+1) - ddot(q-1, B(i+1,j),ldb,
     &                                              A(i+2,i+1),1 )
                      A(i,i+1) = A(i,i+1) - ddot(q-1, B(i,j),ldb,
     &                                              A(i+2,i+1),1 )
                  ENDIF
c
                  step1 = step+1
                  IF ( (abs(B(step,Bfree1)) .LT. tol) .OR.
     &                 (abs(A(step1,step)) .LT. tol)      ) then
                          ierr = 1
                          call dabort(A, lda, m1, n, step-1)
                          GOTO 3000
                  ENDIF
c
c                 compute f1'
                  IF ( ncmplx .GT. 0 ) then
                      lsum = l(step) + l(step)
                      lprod= l(step)*l(step) + l(step1)*l(step1)
                  ELSE
                      lsum = l(step) + l(step1)
                      lprod= l(step)*l(step1)
                  ENDIF
c
                  atmp = A(step1,step1)
c
                  f11 = ( A(step,step)+atmp-lsum ) / B(step,Bfree1)
c
                  f12 = ( (atmp*(atmp-lsum)+lprod)/A(step1,step)
     &                  + A(step,step1) ) / B(step,Bfree1)
c
c                 relocate computed columns of F into A(1:m,:)
                  IF (free .LT. step) then
c                     free+2 < step+2
                      call dcopy(q-1, A(step+2,step), 1, 
     &                                   A(free+2,step), 1)
                      call dcopy(q-1, A(step+2,step1), 1, 
     &                                   A(free+2,step1), 1)
                  ELSE IF (free+2 .GT. step+2) then
                      call dcopy(q-1, A(step+2,step), -1, 
     &                                   A(free+2,step), -1)
                      call dcopy(q-1, A(step+2,step1), -1, 
     &                                   A(free+2,step1), -1)
                  ENDIF
                  A(free1,step)=f11
                  A(free1,step1)=f12
                  call dcopy(free, zero, 0, A(1,step), 1)
                  call dcopy(free, zero, 0, A(1,step1), 1)
c
c                 end CASE r=2 with nn(1) = nn(2)
c
                ELSE
c                 begin 3b SUB CASE  r=2 with nn(1) = nn(2)+1   (s=1)
c                 -------------------------------------------
c
c                 P1: q-1 rotations   { q = nn(2) }
c
                  IF (q .LE. 1) then
c                     dummy rotation if q-1 .LE. 0
                      Gindex = Gindex+1
                      IF (Gindex .ge. Pindex) THEN
                          Gindex = Gindex-1
                          ierr = 3
                          call dabort(A, lda, m1, n, step-1)
                          GOTO 3000
                      ENDIF
                      Gcol(Gindex) = 0
                  ELSE
                      DO 1120 j=step+q,step+2,-1
                          i=j+q
c
c                         compute rotation eliminating A(i,j) into A(i,j+1)
                          call drotg( A(i,j+1), A(i,j), cx, sx)
                          A(i,j)=zero
                          Gindex = Gindex+1
                          IF (Gindex .ge. Pindex) THEN
                              Gindex = Gindex-1
                              ierr = 3
                              call dabort(A, lda, m1, n, step-1)
                              GOTO 3000
                          ENDIF
                          QG(1,Gindex) = cx
                          QG(2,Gindex) = sx
                          Gcol(Gindex) = j
c
c                         post multiply A by computed rotation
                          call drot(i-step,A(step,j+1),1,
     &                             A(step,j),1, cx, sx )
c
c                         pre multiply A by computed rotation
                          call drot(n-step+1,A(j+1,step),lda,
     &                                       A(j,step),lda, cx, sx )
c
c                         premultiply B by computed rotation
                          call drot(m0-Bfree,B(j+1,Bfree1),ldb,
     &                                       B(j,Bfree1),ldb, cx, sx )
 1120                 CONTINUE
                  ENDIF
c
c
c                 P2: Householder interchanging cols step, step+2
c
                  Hindex=Hindex+1
                  IF (Hindex .gt. colqh) THEN
                      Hindex = Hindex-1
                      ierr = 4
                      call dabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  QH(1,Hindex) = -one
                  QH(2,Hindex) = zero
                  QH(3,Hindex) = one
                  Hcol(Hindex) = step
c
c                 post multiply A by permuting Householder
                  call dswap(n-step+1,A(step,step),1,A(step,step+2),1)
c
c                 pre multiply A by permuting Householder
                  call dswap(n-step+1, A(step,step),lda, 
     &                                   A(step+2,step),lda)
c
c                 pre multiply B by permuting Householder 
                  call dswap(m0-Bfree, B(step,Bfree1),ldb,
     &                                   B(step+2,Bfree1),ldb)
c
c                 compute P: rotation to eliminate B(3,1) into B(3,2)
                  i=step+2
                  j=Bfree1
                  Pindex = Pindex-1
                  IF (Pindex .le. Gindex) THEN
                      Pindex = Pindex+1
                      ierr = 3
                      call dabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  call drotg( B(i,j+1), B(i,j), cx, sx )
                  B(i,j) = zero
                  QG(1,Pindex) = cx
                  QG(2,Pindex) = sx
                  Gcol(Pindex) = j
                  Findex = Findex+1
                  Fcol(Findex) = step
c
c                 post multiply B by P
                  call drot( 2, B(step,j+1),1, B(step,j),1, cx, sx )
c
c                 compute F10
                  call dtinvb( B(step+2,Bfree+2),ldb,q, 
     &                  A(step+2,step),lda,2, Iwork, Rwork, tol, infot)
c
                  IF (infot .NE. ok) then
                      ierr = 1
                      call dabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
c
c                 compute A10 - B01*F10
                  i=step
                  j=Bfree+2
                  A(i,i) = A(i,i) - ddot(q, B(i,j),ldb, A(i+2,i),1)
                  A(i+1,i) = A(i+1,i) - ddot(q, B(i+1,j),ldb,
     &                                               A(i+2,i),1   )
                  A(i+1,i+1) = A(i+1,i+1) - ddot(q, B(i+1,j),ldb,
     &                                               A(i+2,i+1),1 )
                  A(i,i+1) = A(i,i+1) - ddot(q, B(i,j),ldb,
     &                                               A(i+2,i+1),1 )
c
                  step1 = step+1
                  IF ( (abs(B(step1,Bfree1)) .LT. tol) .OR.
     &                 (abs(A(step,step1)) .LT. tol)      ) then
                          ierr = 1
                          call dabort(A, lda, m1, n, step-1)
                          GOTO 3000
                  ENDIF
c
c                 compute f1'
                  IF ( ncmplx .GT. 0 ) then
                      lsum = l(step) + l(step)
                      lprod= l(step)*l(step) + l(step1)*l(step1)
                  ELSE
                      lsum = l(step) + l(step1)
                      lprod= l(step)*l(step1)
                  ENDIF
c
                  atmp = A(step,step)
c
                  f11 = ( (atmp*(atmp-lsum)+lprod)/A(step,step1) +
     &                    A(step1,step) ) / B(step1,Bfree1)
c                  
                  f12 = ( atmp+A(step1,step1)-lsum ) / B(step1,Bfree1)
c
c                 relocate computed columns of F into A(1:m,:)
                  IF (free .LT. step) then
c                     { free+2 < step+2 }
                      call dcopy(q, A(step+2,step), 1, 
     &                                   A(free+2,step), 1)
                      call dcopy(q, A(step+2,step1), 1, 
     &                                   A(free+2,step1), 1)
                  ELSE IF (free .GT. step) then
                      call dcopy(q, A(step+2,step), -1, 
     &                                   A(free+2,step), -1)
                      call dcopy(q, A(step+2,step1), -1, 
     &                                   A(free+2,step1), -1)
                  ENDIF
                  A(free1,step)=f11
                  A(free1,step1)=f12
                  call dcopy(free, zero, 0, A(1,step), 1)
                  call dcopy(free, zero, 0, A(1,step1), 1)
c
c                 end CASE r=2 with nn(1) = nn(2)+1   (s=1)
c
                ENDIF
c               (3b r=2 subcase s=0, or subcase s=1)
c
c               update for case r=2
                free = free+1
                free1 = free+1
                Bfree = Bfree+1
                Bfree1 = Bfree+1
c
             ENDIF
c            (case 3a or 3b)
c
c            updates for case 3
             status = status+2
             IF (ncmplx .GT. 0) ncmplx=ncmplx-2
             Gcol(Gindex) = -Gcol(Gindex)
             Hcol(Hindex) = -Hcol(Hindex)
             nn(r-1) = nn(r-1) - 1
             nn(r) = nn(r) - 1
             step = step+2
c
c            end CASE 3: cases (s=0) OR (s=1 and n even)
c
          ENDIF
c         (case 1 or 2 or 3)
c
          goto 200
      ENDIF
c     end do !while (step .LE. nm2)  (end deflationary loop)
c
c  FINAL ALLOCATIONS
c  *****************
c
      step1 = step+1
      free1 = free+1
      Bfree1 = Bfree+1
c
      IF (nn(2) .EQ. 0) then
c         case resulting k=1   # of inputs = # of states
c
          IF ( nn(1) .EQ. 2 ) then
c             nn = [2,0,...,0]  Two eigenvalues remaining
c
             IF (ncmplx .GT. 0) then
                A(step,step) = A(step,step)-l(step)
                A(step1,step) = A(step1,step)+l(step1)
                A(step1,step1) = A(step1,step1)-l(step)
                A(step,step1) = A(step,step1)-l(step1)
             ELSE
                A(step,step) = A(step,step)-l(step)
                A(step1,step1) = A(step1,step1)-l(step1)
             ENDIF
c
             call dtinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 2, Iwork, Rwork, tol, infot )
c
             IF (infot .NE. ok) then
                 ierr = 1
                 call dabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate computed columns of F into A(1:m,:)
             IF (free1 .LT. step) then
                 call dcopy(nn(1), A(step,step), 1, A(free1,step), 1)
                 call dcopy(nn(1), A(step,step1), 1, A(free1,step1), 1)
             ELSE IF (free1 .GT. step) then
                 call dcopy(nn(1), A(step,step),-1, A(free1,step),-1)
                 call dcopy(nn(1), A(step,step1),-1, A(free1,step1),-1)
             ENDIF
                 call dcopy(free, zero, 0, A(1,step), 1)
                 call dcopy(free, zero, 0, A(1,step1), 1)
c
             status = status+2
             IF (ncmplx .GT. 0) then
                 ncmplx = ncmplx-2
             ENDIF
c
          ELSE IF ( nn(1) .eq. 1  .and.  ncmplx .eq. 0 ) then
c            nn = [1,0,...,0]
c            procede to allocate one real eigenvalue
c
             A(step,step)=A(step,step)-l(step)
             call dtinvb( B(step,Bfree+1), ldb, nn(1), 
     &             A(step,step), lda, 1, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call dabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate computed column of F into A(1:m,:)
             call dcopy(free, zero, 0, A(1,step), 1)
c            A(m,n) = A(n,n)
             A(m1,step) = A(step,step)
c
             status = status+1
c
c         otherwise
c            nn = [1,0,...,0] with 2 complex eigenvalues to be allocated, or
c            nn = [0,0,...,0]  
c            In either case the system is uncontrollable and no more 
c            allocations are possible. (recall we use only real arithmetic)
c            this is taken care of later
c
          ENDIF
c         (end case k=1)
c
      ELSE
c
c         case resulting k=2   one input, two states
c         nn = [1,1,0,...,0]
c
          step1 = step+1
          IF ( ncmplx .GT. 0 ) then
              lsum = l(step) + l(step)
              lprod= l(step)*l(step) + l(step1)*l(step1)
          ELSE
              lsum = l(step) + l(step1)
              lprod= l(step)*l(step1)
          ENDIF
c
          IF ( (abs(B(step,Bfree+1)) .LT. tol) .OR.
     &         (abs(A(step1,step)) .LT. tol)      ) then
                 ierr = 1
                 call dabort(A, lda, m1, n, step-1)
                 GOTO 3000
          ENDIF
c
          atmp = A(step1,step1)
c
          f11 = ( A(step,step)+atmp-lsum ) / B(step,Bfree+1)
c
          f12 = ( (atmp*(atmp-lsum)+lprod)/A(step1,step)
     &                  + A(step,step1) ) / B(step,Bfree+1)
c
c         relocate last two columns of F
          call dcopy( free, zero, 0, A(1,step), 1)
          call dcopy( free, zero, 0, A(1,step1), 1)
          A(m1,n-1)=f11
          A(m1,n) = f12
c
          status = status+2
          IF (ncmplx .GT. 0) then
             ncmplx = ncmplx - 2
          ENDIF
c
c         (end case k=2)       
      ENDIF
c     (end final allocations)
c
c     check if there were more eigenvalues in the given data
c     in that case system is uncontrollable
c     (some possibilities are
c        nn = [1,0,...,0] with 2 complex eigenvalues to be allocated, or
c        nn = [0,0,...,0]  
c        In either case the system is uncontrollable and no more 
c        allocations are possible. (recall we use only real arithmetic)
      IF ( status .ne. n ) THEN
         ierr = 2
         call dabort(A, lda, m1, n, step)
         GOTO 3000
      ENDIF
c
c
c  BACK TRANSFORMATION
c  *******************
c
 3000 CONTINUE
c
c     Apply P
c     -------
c     do while (Pindex .LT. Pstart) 
 3050 IF (Pindex .LT. Pstart) then
c         Apply transpose of rotation stored in QG(1,Pindex) to
c         rows Gcol(Pindex), Gcol(Pindex)+1  from cols Fcol(Findex) to n
          i = Gcol(Pindex)
          j = Fcol(Findex)
          cx = QG(1,Pindex)
          sx = QG(2,Pindex)
          call drot(n, A(i+1,j), lda, A(i,j), lda, cx, -sx)
          Findex = Findex-1
          Pindex = Pindex+1
          GOTO 3050
      ENDIF
c     end do !while (Pindex .LT. Pstart) 
c
c  Apply Q-inverse
c  ---------------
c     do while (Gindex .NE. 0)
 3100 IF (Gindex .NE. 0) then
c 
c        1. Apply inverse Householders for one step
c
         IF ( Hcol(Hindex) .EQ. 0 ) then
c            ignore dummy Householder
             Hindex = Hindex-1
         ELSE
c            apply (inverse of) Householders for one step
             IF (Hcol(Hindex) .LT. 0)  Hcol(Hindex) = -Hcol(Hindex)
c            do while (Hcol(Hindex) .GT. 0)
 3200        IF ((Hindex .GT. 0) .AND.(Hcol(Hindex) .GT. 0)) then
                 DO 3250 k=1,m1
                    call dhhrfl( A(k,Hcol(Hindex)), lda, QH(1,Hindex))
 3250            CONTINUE
                 Hindex = Hindex-1
                 GOTO 3200
             ENDIF
c            end do !while Hcol(Hindex) .GT. 0)
         ENDIF
c
c        2. Apply inverse Rotations for one step
c
         IF ( Gcol(Gindex) .EQ. 0 ) then
c            ignore dummy rotation
             Gindex = Gindex-1
         ELSE
c            transform
             IF (Gcol(Gindex) .LT. 0)  Gcol(Gindex) = -Gcol(Gindex)
c            do while (Gindex .GT. 0) .AND. (Gcol(Gindex) .GT. 0)
 3400        IF ((Gindex .GT. 0) .AND. (Gcol(Gindex) .GT. 0)) then
                 j = Gcol(Gindex)
                 cx = QG(1,Gindex)
                 sx = QG(2,Gindex)
                 call drot(m1, A(1,j+1), 1, A(1,j), 1, cx, -sx)
                 Gindex = Gindex-1
                 GOTO 3400
             ENDIF
c            end do !while (Gcol(Gindex) .GT. 0)
         ENDIF
c
      GOTO 3100
      ENDIF
c     end do !while (Gindex .NE. 0)
c
 9000 CONTINUE
c  Copy matrix F in array A to array F
      if (m .lt. n) then
         do 9050  j=1,n
             call dcopy(m,A(1,j),1,F(1,j),1)
 9050    continue
      else
c        m is greater than n. First m-n rows will be zeros.
         m0 = m-n
         m1 = m-n+1 
         do 9070  j=1,n
             call dcopy(m0, zero,0, F(1,j),1)
             call dcopy(n, A(1,j),1, F(m1,j),1)
 9070    continue
      end if
c
 9900 CONTINUE
c
c  TERMINATION
c  ***********
      info(1) = status
      info(2) = lnpos
      return
c
c ** last line of subroutine dmvs1 **
      end
c==========================================================
c==========================================================
c
        subroutine dabort(A, lda, m, n, allocd)
c
c       Purpose
c       =======
c       To zero the sub-matrix of A contained in 
c       rows 1 to M, columns ALLOCD+1 to N
c       That is to set  A(I,J) = 0.0  whenever
c       I is in the set {1,..,M}  AND  J is in the set {ALLOCD+1,..,N}
c       
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c
c       A      DOUBLE PRECISION array of DIMENSION(LDA,N)
c              The leading M by N part of this array must contain
c              the matrix with elements to be zeroed.
c              Note: this array is overwritten.   (See Purpose)
c
c       LDA    INTEGER
c              Leading dimension of the array A, as declared in the
c              calling program.
c
c       M      INTEGER
c              The last row of A that will have elements set to zero
c              M .LE. LDA
c
c       N      INTEGER
c              The last column of matrix A that will have elements
c              set to zero.
c
c       ALLOCD INTEGER
c              The last column of matrix A that will NOT be changed, ie
c              columns 1 to ALLOCD are left unchanged.
c
c       Arguments Out
c       -------------
c
c       A      DOUBLE PRECISION array of DIMENSION(LDA,N)
c              The matrix A with  A(I,J)=0.0  whenever
c              I is in {1,...,M}  and  J is in {ALLOCD+1,...,N}
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       Successive calls to BLAS routine DCOPY overwrite, column by column,
c       the designated column elements with zero-vectors of length M
c
c       References
c       ==========
c       C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c       Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c       pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c
c  arguments
c       implicit none
        integer lda, m, n, allocd
        double precision A(lda,*)
c
c  parameters
        double precision   zero
        parameter (zero=0.0d0)
c  external subroutines
        external DCOPY
c
c  local variables
        integer j
c
        DO 100 j=allocd+1,n
            call dcopy(m, zero, 0, A(1,j), 1)
  100   continue
c
c
        return
        end
c
c
c==========================================================
c==========================================================
c
      subroutine dhhldr(x,incx,tol,v)
c
c       Purpose
c       =======
c       To compute 3-vector v, with v(3)=1.0, so that 
c       the Householder reflector H, where  H = I-2*v*v'/v'*v 
c       is such that for the given vector x, of dimension 3,
c       H*x = [0 0 -s]'
c       where  s = sign(x(3)) * norm2(x)
c       In addition
c           v'*v/2.0 is computed and returned in v(3)
c           v is contiguous in memory
c           x(i) is overwritten with zero, i=1,2
c           x(3) is overwritten with -s 
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       X      DOUBLE PRECISION array of DIMENSION (at least 3)
c              The 3 elements  X(1), X(1+INCX), X(1+2*INCX)
c              must contain the vector whose two leading elements
c              will be overwritten with zero when multiplied from
c              the left by the computed Householder.
c              Note: This array is overwritten.
c
c       INCX   The stride for elements of the vector X
c
c
c       Arguments Out
c       -------------
c
c       X      DOUBLE PRECISION array of DIMENSION (at least 3)
c              X(1) is overwritten with zero.
c              X(1+INCX) is overwritten with zero.
c              X(1+2*INCX) is overwritten with -s, where
c                          s = sign(x(3)) * norm2(x), where
c                          x = (X(1), X(1+INCX), X(1+2*INCX))'
c
c       V      DOUBLE PRECISION array of DIMENSION (at least 3)
c              v is computed so that v(3)=1.0 and, for the given vector x,
c              H*x = [0 0 -s]', where  H = I-2*v*v'/v'*v 
c              Instead of the known value 1.0, v'*v/2.0 is returned in V(3)
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       TOL    The magnitude below which matrix elements are
c              considered to be zero.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       sigma = sign(x(3))*norm2(x)
c       beta = x(3) + sigma
c       v(1)=x(1)/beta,  beta .ne. zero
c       v(2)=x(2)/beta,  beta .ne. zero
c       v(3)=1.0
c
c       References
c       ==========
c       Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, pp. 195-199.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c     implicit none
      integer  incx
      double precision x(*), v(*), tol
c
c  parameters
      double precision zero, one, two
      parameter (zero=0.0d0, one=1.0d0, two=2.0d0)
c
c  functions
      double precision dnrm2
      external dnrm2
      intrinsic sign
c
c  local variables
      integer inc1, inc2
      double precision nrmx, b, s
c
      nrmx = dnrm2(3,x,incx)
      IF (nrmx .le. tol) then
             v(1)=zero
             v(2)=zero
             v(3)=zero
             x(1)=zero
             x(2)=zero
             x(3)= zero
             goto 999
c 
      else IF (incx .EQ. 1) then
             s = sign(nrmx, x(3))
             b = x(3) + s
             v(1)=x(1)/b
             v(2)=x(2)/b
             v(3) = (one-(x(3)-s)/b)/two
             x(1) = zero
             x(2) = zero
             x(3) = -s
c 
      else   
             inc1 = 1+incx
             inc2 = 1+2*incx
             s = sign(nrmx, x(inc2))
             b = x(inc2)+s
             v(1) = x(1)/b
             v(2) = x(inc1)/b
             v(3) = (one-(x(inc2)-s)/b)/two
             x(1) = zero
             x(inc1) = zero
             x(inc2) = -s
      endif
c 
  999 continue
      return
      end
c
c
c==========================================================
c==========================================================
c
      subroutine dhhrfl(x,incx,v)
c
c       Purpose
c       =======
c       Overwrite x with H*x where 
c       H is the Householder reflector (I-2vv'/v'v), where
c       v is computed by subroutine DHHLDR (with v(3) restored to 1.0)
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       X      DOUBLE PRECISION array of DIMENSION (at least 3)
c              The 3-element vector x to be overwritten by H*x must 
c              be contained in X(1), X(1+INCX), X(1+2*INCX).
c              Note: This array is overwritten.
c
c       INCX   The stride for elements of the vector X
c
c       V      DOUBLE PRECISION array of DIMENSION (3)
c              A 3-element vector computed by DHHLDR
c
c
c       Arguments Out
c       -------------
c       X      DOUBLE PRECISION array of DIMENSION (at least 3)
c              Let
c              x = (X(1), X(1+INCX), X(1+2*INCX))' and y=H*x, 
c              where
c              H is the Householder reflector (I-2vv'/v'v), where
c                v is computed by subroutine DHHLDR, so that
c                v(3) is assumed equal to 1.0 and stores v'v/2.
c              Then
c              X(1) is overwritten with y(1).
c              X(1+INCX) is overwritten with y(2).
c              X(1+2*INCX) is overwritten with y(3).
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       x = (I-2vv'/v'v)x 
c         = x-2vv'x/v'v
c         = x-v'x(2v/v'v)
c
c       References
c       ==========
c       Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, pp. 195-199.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c     implicit none
      integer  incx
      double precision x(*), v(*)
c
c  parameters
      double precision zero, one
      parameter (zero=0.0d0, one=1.0d0)
c
c  external functions
      double precision ddot
      external ddot
c
c  local variables
      double precision t,tmp
      integer inc1, inc2
c
c     don't do anything if the Householder was computed
c     for a vector with norm less than tol
      if (v(3) .eq. zero) goto 999
c
c     otherwise...
      tmp = v(3)
      v(3) = one
      t = ddot(3,v,1,x,incx)/tmp
c
      IF (incx .EQ. 1) then
          x(1)=x(1)-t*v(1)
          x(2)=x(2)-t*v(2)
          x(3)=x(3)-t
      else
          inc1 = 1+incx
          inc2 = 1+2*incx
          x(1) = x(1)-t*v(1)
          x(inc1) = x(inc1)-t*v(2)
          x(inc2) = x(inc2)-t
      endif
c 
      v(3) = tmp
c
  999 continue
      return
      end
c
c
c==========================================================
c==========================================================
c
      subroutine dtinvb( T,ldt,n, B,ldb,p, Iwork, Rwork, tol,infot )
c
c     Purpose
c     =======
c     Overwrite B (NxP) with solution to TX=B where T (NxN) is
c     upper triangular.  If T is numerically singular then no
c     attempt is made to compute X.
c
c     Arguments in
c     ============
c
c     T      DOUBLE PRECISION array of DIMENSION (LDT,N)
c            The matrix T must occupy the leading N rows by N columns 
c            of the array T
c
c     LDT    INTEGER
c            row dimension of array T, as declared in the calling program
c
c     N      INTEGER        
c            row and column dimension of matrix T
c            row dimension of matrix B
c            N .LE. LDT
c
c     B      DOUBLE PRECISION array of DIMENSION (LDB,P)
c            the matrix B must occupy the leading N rows by P columns of 
c            the array T
c
c     LDB    INTEGER
c            row dimension of array B, as declared in the calling program
c
c     P      INTEGER
c            column dimension of matrix B
c
c     Arguments Out
c     -------------
c
c     B      DOUBLE PRECISION array of DIMENSION (LDB,P)
c            leading N rows by P columns contains solution X of TX=B,
c            if T is nonsingular. Otherwise, B is unchanged from B on entry.
c
c     IWORK  INTEGER array of DIMENSION (N)  
c            work space required for condition estimator
c
c     RWORK  DOUBLE PRECISION array of DIMENSION (3*N)
c            work space required for condition estimator
c
c     Tolerances
c     ----------
c     TOL    DOUBLE PRECISION
c            Matrix elements with magnitude < TOL are considered zero
c
c     Warning Indicator
c     -----------------
c     INFOT  INTEGER
c            Unless T is non-singular "to working precision", 
c            INFOT contains 0 on exit
c
c     Error Indicator
c     ---------------
c     None.
c
c
c     Warnings and Errors detected by the routine
c     ===========================================
c     INFOT > 0 :  T is non-singular to working precision.
c
c     Method
c     ======
c     The LApack routine DTRCON is used to obtain a condition estimate for T
c     If the system is estimated to be "sufficiently well conditioned", the
c     right hand side matrix is solved column by column via repeated calls
c     to the LApack routine DTRTRS
c
c     References
c     ==========
c     Coleman, T.F. and Van Loan, C.F., Handbook for Matrix Computations,
c     SIAM, Philadelphia, 1988, pp. 144-145.
c
c     Contributors
c     ============
c     G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c     Revisions
c     =========
c     1994 Feb 03
c
c  ARGUMENTS
c     implicit none
      integer ldt, n, ldb, p, Iwork(*), infot
      double precision T(ldt,*), B(ldb,*), Rwork(*), tol
c
c  EXTERNAL SUBPROGRAMS
      external dtrtrs, dtrcon
c
c  LOCAL VARIABLES
      double precision rcond
c
      call dtrcon( '1', 'U', 'N', n, T, ldt, rcond, Rwork, Iwork, infot)
c
      IF ( rcond .lt. tol ) then
           infot = 1
      ELSE IF (n .eq. 1 .and. abs(T(1,1)) .le. tol) then
           infot = 1
      ELSE
           infot = 0
           call dtrtrs( 'U', 'N', 'N', n, p, T, ldt, B, ldb, infot )
      ENDIF
      return
      end
c
c
c==========================================================
c==========================================================
c
        double precision function d1nrmU( U, ldu, n)
c
c       Purpose
c       =======
c       To compute 1-norm of order N upper-triangular matrix U
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       U      DOUBLE PRECISION array of DIMENSION (LDU,N)
c              The leading N by N part of this array must contain
c              the upper triangular matrix U.
c              Elements outside the upper triangular part of matrix U
c              are not referenced.
c
c       LDU    INTEGER
c              Leading dimension of the array U, as declared in the
c              calling program.
c
c       N      INTEGER
c              Order of the matrix U.
c
c       Arguments Out
c       -------------
c       None.
c       The FUNCTION returns the 1-norm of the matrix U.
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       The 1-norm of the upper triangular part of each column is 
c       computed using BLAS routine DASUM. The maximum of these
c       is returned as the matrix 1-norm.
c
c       References
c       ==========
c       1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c          Johns Hopkins University Press, Baltimore, 1989, pp. 53-57.
c
c       2. C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c          Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c          pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c       implicit none
        integer ldu, n
        double precision U(ldu,*)
c
c    local variables
        integer j
        double precision tnrm
c
c    external functions blas dasum
        double precision dasum
        external dasum
c
c    intrinsic functions
        intrinsic max
c
        tnrm = U(1,1)
        DO 100 j=2,n
            tnrm = max( dasum(j,U(1,j),1), tnrm )
  100   CONTINUE
c
        d1nrmU = tnrm
c
        return
        end
c
c
c==========================================================
c==========================================================
c
        double precision function d1nrmA( A, lda, n )
c
c       Purpose
c       =======
c       To compute 1-norm of order N general matrix A
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       A      DOUBLE PRECISION array of DIMENSION (LDA,N)
c              The leading N by N part of this array must contain
c              the matrix A.
c
c       LDA    INTEGER
c              Leading dimension of the array A, as declared in the
c              calling program.
c
c       N      INTEGER
c              Order of the matrix A.
c
c       Arguments Out
c       -------------
c       None.
c       The FUNCTION returns the 1-norm of the matrix A.
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       The 1-norm of of each column of A is computed using 
c       BLAS routine DASUM. The maximum of these is returned
c       as the matrix 1-norm.
c
c       References
c       ==========
c       1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c          Johns Hopkins University Press, Baltimore, 1989, pp. 53-57.
c
c       2. C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c          Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c          pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c    arguments
c       implicit none
        integer lda, n
        double precision A(lda,*)
c
c    local variables
        integer j
        double precision tnrm
c
c    external functions blas dasum
        double precision dasum
        external dasum
c
c    intrinsic functions
        intrinsic max
c
        tnrm = dasum( n, A(1,1), 1 )
        DO 100 j=2,n
            tnrm = max( dasum(n,A(1,j),1), tnrm )
  100   CONTINUE
c
        d1nrmA = tnrm
c
        return
        end
C*** dstair.f
c
c FILE: dstair.f
c
c  == ==================================================================
c
        subroutine dstair(n,m, A,lda, B,ldb, kmax, kstair,
     &                    itrnsf, rtrnsf, iwork, rwork,
     &                    tol, iwarn, ierr)
c
c  == ==================================================================
c
c    Purpose
c    =======
c
c    To transform real matrices A and B such that the system (B,A) 
c    is in "upper staircase" (or "controllability") form, with
c    staircase blocks in upper triangular form.
c    This routine is a driver for dstr1.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           N .ge. 1
c
c    M      INTEGER.
c           Column dimension of matrix B.
c           M .ge. 1
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the 
c           real matrix A that is to be converted to upper staircase form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the
c           real matrix B that is to be converted to upper staircase form.
c           Note: this array is overwritten.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c
c    Arguments Out
c    -------------
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           The leading N by N part of this array contains the converted 
c           staircase form of the given matrix A.
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array contains the converted 
c           staircase form of the given matrix B.
c
c    Kmax   INTEGER.
c           The number of staircase blocks.
c
c    Kstair INTEGER array of DIMENSION (N+1).
c           This array stores the ranks of the staircase blocks of the
c           system [B,A].
c           Kstair(Kmax+1) is set to zero.
c
c    Itrnsf INTEGER array of Dimension (max(M,N)(M+1)/2 + M+2N+3)
c           This array contains integer information pertaining to the
c           transformations performed on A and B, as required for DBKTRN.
c
c    Rtrnsf DOUBLE PRECISION array of Dimension (N(N+1)/2 + max(M,N)(M+1)/2)
c           This array contains floating point information pertaining to the
c           transformations performed on A and B, as required for DBKTRN.
c
c
c    Work Space
c    ----------
c
c    Iwork  INTEGER array of DIMENSION (N*4)
c
c    Rwork  DOUBLE PRECISION array of DIMENSION (N*2)
c
c
c    Tolerances
c    ----------
c
c    TOL    DOUBLE PRECISION.
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER.
c           Unless a staircase block has rank zero, IWARN contains 0 on exit. 
c           (See Warnings and Errors below).
c
c
c    Error Indicator
c    ---------------
c
c    Ierr   INTEGER
c           Unless the routine detects an error (see next section),
c           Ierr contains 0 on exit.
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    Iwarn = 1  The rank of B or the rank of a staircase block of A is 0.
c               The system is therefore uncontrollable.
c
c    IERR < 0   IERR = -j indicates a problem with the j-th argument
c               on entry.  Specifically:
c               IERR = -1   On entry,  N < 1
c               IERR = -2   On entry,  M < 1
c               IERR = -4   On entry,  LDA < N
c               IERR = -6   On entry,  LDB < N
c
c
c    Method
c    ======
c
c    Compute orthogonal transformations T and U so that
c
c              [B1,A1] = T'[B,A]|U |
c                               | T|
c
c    is in upper staircase form.
c
c    References
c    ==========
c
c    G.S. Miminis and C.C.Paige, 'An algorithm for pole assignment of
c    time-invariant multi-input linear systems', Proc. 21st IEEE Conf.
c    on Decision and Control, Orlando, Florida, V.1, pp. 62-67, 1982.
c
c    Contributors
c    ============
c
c    R. Bouzane, G. Miminis, H. Roth
c    (Memorial University of Newfoundland, Canada)
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c
c       implicit none
        integer           n, m, lda, ldb
        double precision  A(lda, *), B(ldb, *)
        integer           kmax, kstair(*), itrnsf(*), iwork(*)
        double precision  rtrnsf(*), rwork(*), tol
        integer           iwarn, ierr

        external          dstr1

c  initialize
        iwarn = 0
        ierr  = 0
c
c  check some input arguments
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, A, lda, B, ldb, 
c         kmax, kstair, itrnsf, rtrnsf, iwork, rwork, tol, iwarn, ierr)
      IF( ldb .lt. n ) ierr = -6
      IF( lda .lt. n ) ierr = -4
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  Partition itrnsf, rtrnsf
c     Arot   starts at itrnsf(1)        has length  1
c     Brot   starts at itrnsf(2)        has length  1
c     Mcol   starts at itrnsf(3)        has length  m+n+1
c     Cnum   starts at itrnsf(m+n+4)    has length  n
c     Pos    starts at itrnsf(m+2n+4)   has length  (max(m,n))(m+1)/2
c
c     Hhold  starts at rtrnsf(1)           has length  n(n+1)/2
c     CosSin starts at rtrnsf(1+n(n+1)/2)  has length  (max(m,n))(m+1)/2
c
c  do the job
      call dstr1(n,m, A,lda, B,ldb, kmax,kstair, itrnsf(1),
     &           itrnsf(2), itrnsf(3), itrnsf(m+n+4),
     &           itrnsf(m+2*n+4), rtrnsf(1), rtrnsf(1+n*(n+1)/2),
     &           Iwork, Rwork, tol, iwarn)
c
c  make sure kstair(kmax+1) = 0:
      kstair(kmax+1)=0
c
 9000 continue
      return
c     last line of subroutine dstair follows
      end
c
C  == ==================================================================
C
        subroutine dstr1(n,m,A,lda,B,ldb,kmax,ranks,Arot,Brot,
     &                    Mcol,Cnum,Pos,Hhold,CosSin,Swork,
     &                    Vwork,Utol,Error)

C  == ==================================================================
C
C    Purpose
C    =======
C
C    To transform real matrices A and B such that the system (B,A)
C    is in "upper staircase" (or "controllability") form, with
C    staircase blocks in upper triangular form.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER.
C           Row and column dimension of matrix A,
C           row dimension of matrix B,
C           N .ge. 1
C
C    M      INTEGER.
C           Column dimension of matrix B.
C           M .ge. 1
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
C           The leading N by N part of this array must contain the
C           real matrix A that is to be converted to upper staircase form.
C           Note: this array is overwritten.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the
c           real matrix B that is to be converted to upper staircase form.
C           Note: this array is overwritten.
C
C    LDB    INTEGER.
C           Row dimension of array B, as declared in the calling program
C           LDB .ge. N.
C
C
C    Arguments Out
C    -------------
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
C           The leading N by N part of this array contains the converted 
C           staircase form of the given matrix A.
C
C    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
C           The leading N by M part of this array contains the converted 
C           staircase form of the given matrix B.
C
C    Kmax   INTEGER.
C           The number of staircase blocks.
C
C    Ranks  INTEGER array of DIMENSION (N+1).
C           This array stores the ranks of the staircase blocks of [B,A].
C           Ranks(kmax+1)=0.
C
C    Arot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix A.
C
C    Brot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix B.
C
C    Mcol   INTEGER array of DIMENSION (M+N+1).
C           The leading N+M part of this array contains the order of the 
C           column pivoting.
C
C    Cnum   INTEGER array of DIMENSION (N).
C           This array stores the Householders sizes for the Householder
C           vectors.
C
C    Pos    INTEGER array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the positions of the rotations on
C           A and B.
C
C    Hhold  DOUBLE PRECISION array of DIMENSION (N(N+1)/2).
C           This array stores the Householder vectors applied on A
C           and B.
C
C    CosSin DOUBLE PRECISION array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the values used in the rotations on
C           A and B.
C
C
C    Work Space
C    ----------
C
C    Swork  INTEGER array of DIMENSION (N*4)
C
C    Vwork  DOUBLE PRECISION array of DIMENSION (N*2)
C
C
c    Tolerances
c    ----------
c
c    UTOL    DOUBLE PRECISION.
c           Matrix elements with magnitudes less than UTOL are considered zero.
c           If on entry UTOL is less than the relative machine precision "eps",
c           it is reset to
c           UTOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
C
C
C    Error Indicator
C    ---------------
C
C    Error  INTEGER
C           Unless the routine detects an error (see next section),
C           Error contains 0 on exit.
C
C
C    Errors detected by the Routine
C    ==============================
C
C    Error = 1  The rank of B or the rank of a subblock of A
C               is 0.  If this happens,  the system is uncontrollable.
C
C
C    Method
C    ======
C
C    Compute orthogonal transformations T and U so that
C
C              [B1,A1] = T'[B,A]|U |
C                               | T|
C
C    is in upper staircase form.
C    Store the transformations in factored form.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n, m, lda, ldb, Error, Kmax
        double precision A(lda, *), B(ldb, *), CosSin(*)
        double precision Vwork(*), Hhold(*), mu
        double precision cx, sx, eps, tol, Utol
        integer Swork(*), Ranks(*)
        integer Pos(*), Cnum(*), Mcol(*)
        integer crow, nrank, endcol, sn,sm,offset
        integer i, j, k, nextcl, rank, col,bm
        integer hh, cc, begin, pc, row,ccol
        integer brank, pp, Arot, Brot, nopre
C
C       External procedures that will be used in this procedure.
        double precision dlamch
        double precision donorm
        integer dcnorm
        external dcnorm, dlamch, donorm
        external drot, drotg, dswap
C
        pp = 1
        pc = 1
        hh = 1
        cc = 1
        Kmax = 1
        Error = 0
        rank = 0
        mu = 0.0d0
C
C       Calculate tolerance
        eps = dlamch('E')
        if (Utol .lt. eps) then
            tol = donorm(n, m, A, lda, B, ldb)
            tol = tol*eps
            Utol = tol
        end if
C
        bm = m
        do 30 j = 1, bm
C
C       Do column pivoting and store to apply to F.
            nextcl = dcnorm(j, m, B, ldb, n, j)
            Mcol(j) = nextcl
            if (nextcl .ne. j) then
                call dswap(n, B(1,j), 1, B(1,nextcl), 1)
                Mcol(j+1) = 0
            end if
C
C       This procedure calculates the house holder vector Vwork for the 
C       column starting from B(rank+1, j) down to B(n-rank, j).
C
            call dhh(B(rank+1, j), 1, Vwork, n-rank, mu, Utol)
C
C       Store house vector so it can be used on F later
C
            nopre = 1
            do 26 i = 2, n-rank
                if (dabs(Vwork(i)) .ge. Utol) then
                    nopre = 0
                end if
26          continue
            if ((nopre .lt. 1) .and. (mu .ge. Utol)) then
                do 20 i = 2, n-rank
                    Hhold(hh) = Vwork(i)
                    hh = hh + 1
20              continue
                Cnum(cc) = n-rank-1
                cc = cc + 1
C
C       Do pre-multipication on B starting at position (rank+1, rank+1)
C
                call dprehh(B,ldb,n,m,Vwork,Vwork(n+1),rank+1,rank+1)
C
C       Do pre-multiplication and post-multiplication on A starting 
C       at position (rank+1, rank+1)
C
                call dprehh(A,lda,n,n,Vwork,Vwork(n+1),rank+1,1)
                call dpthh(A,lda,n,n,Vwork,Vwork(n+1),1,rank+1)
            end if
C
C       Check to see if rank needs to be updated.  If diagonal is 0.
            if (dabs(B(rank+1,j)) .gt. Utol) then
                rank = rank + 1
            end if
30      continue
        if (rank .eq. 0) then
            Error = 1
            goto 9000
        endif
        brank = rank
        Ranks(Kmax) = rank
        Kmax = Kmax + 1
C
C       Do house holders on (if any) elements of matrix A
        crow = rank+1
        col = 1
        endcol = rank
C
C       This is a while loop to process rows in A.
1000    if (crow .gt. n) goto 2000
            nrank = 0
            begin = crow
            do 60 j = col, endcol
                nextcl = dcnorm(j, endcol, A, lda, n, crow)
                Mcol(j+m) = nextcl
                if (nextcl .ne. j) then
C
C       Must swap the columns and rows of A,  the rows of B, and 
C       the columns of F.
C
                    call dswap(n, A(1,j), 1, A(1,nextcl), 1)
                    call dswap(n, A(j,1), lda, A(nextcl, 1), lda)
                    call dswap(m, B(j,1), ldb, B(nextcl, 1), ldb)
                    Mcol(j+m+1) = 0
                end if
C
C       This procedure calculates the house holder vector Vwork for the 
C       column starting from A(crow,j) down to A(n-crow+1, j)
                call dhh(A(crow, j), 1, Vwork, n-crow+1, mu, Utol)
C
C       Store house vector so it can be used on F later
C
                nopre = 1
                do 56 i = 2,  n-crow+1
                    if (dabs(Vwork(i)) .ge. Utol) then
                        nopre = 0
                    end if
56              continue
                if ((nopre .lt. 1) .and. (mu .ge. Utol)) then
                    do 50 i = 2,  n-crow+1
                        Hhold(hh) = Vwork(i)
                        hh = hh + 1
50                  continue
                    Cnum(cc) = n-crow
                    cc = cc + 1
C
C       Do pre and post multiplication on matrix A.
                    if (Cnum(cc-1) .ne. 0) then
                        call dprehh(A,lda,n,n,Vwork,Vwork(n+1),crow,j)
                        call dpthh(A,lda,n,n,Vwork,Vwork(n+1),1,crow)
                    endif
                end if
C
                if (dabs(A(crow, j)) .gt. Utol) then 
                    nrank = nrank + 1
                    crow = crow + 1
                    if (crow .gt. n) then
C
C       Saving sub-matrix for rotations
                        Swork(pc) = begin
                        Swork(pc+1) = col
                        Swork(pc+2) = rank
                        Swork(pc+3) = nrank
                        pc = pc + 4
                        if (rank .eq. 0) then
                            Error = 1
                            goto 2000
                        endif
                        Ranks(Kmax) = nrank
                        Kmax = Kmax + 1
                        goto 2000
                    end if
                end if
60          continue
C
C       Saving sub-matrix for rotations
            Swork(pc) = begin
            Swork(pc+1) = col
            Swork(pc+2) = rank
            Swork(pc+3) = nrank
            pc = pc + 4
            Ranks(Kmax) = nrank
            Kmax = Kmax + 1
            col = col + rank
            rank = nrank
            if (rank .eq. 0) then
                Error = 1
                goto 2000
            endif
            endcol = endcol + rank
        goto 1000
C
C       Do rotations on all sub blocks on matrix A.
2000    pc = pc - 1
        Cnum(cc) = 0
        Ranks(Kmax) = 0
        Kmax = Kmax - 1
        do 90 k = pc, 2, -4
C
C       Poping sub-matrix off the stack
            sm = Swork(k)
            sn = Swork(k-1)
            col = Swork(k-2)
            row = Swork(k-3)
            offset = 1
            do 80 i = row+sm-1, row, -1
                ccol = col+sn-offset
                do 70 j = col, ccol-1
                    if (dabs(A(i, j)) .gt. Utol) then
C
C       Find values for the rotations
                        call drotg(A(i, ccol), A(i, j), cx, sx)
                        A(i, j) = 0.0
C
C       Apply the rotations to row and columns of A and rows of B
                        call drot(i-1,A(1, ccol),1,A(1, j),1, cx, sx)
                        call drot(n,A(ccol,1),lda,A(j, 1),lda,cx,sx)
                        call drot(m,B(ccol,1),ldb,B(j, 1),ldb,cx, sx)
                        Pos(pp) = ccol
                        Pos(pp+1) = j
                        CosSin(pp) = cx
                        CosSin(pp+1) = sx
                        pp = pp + 2
                    end if
70              continue
                offset = offset + 1
80          continue
90      continue
C
        row = 1
        col = 1
        sn = m
        sm = brank
C
        Arot = pp
        offset = 1
        do 110 i = row+sm-1, row, -1
            ccol = col+sn-offset
            do 100 j = col, ccol-1
                if (dabs(B(i, j)) .gt. Utol) then
C
C       Calculate the rotations needed in B
                    call drotg(B(i, ccol), B(i, j), cx, sx)
                    B(i, j) = 0.0
C
C       Apply the rotation on B
                    call drot(i-1, B(1, ccol), 1, B(1, j), 1, cx, sx)
                    Pos(pp) = ccol
                    Pos(pp+1) = j
                    CosSin(pp) = cx
                    CosSin(pp+1) = sx
                    pp = pp + 2
                end if
100         continue
            offset = offset + 1
110     continue
        Brot = pp
C                
9000    return
C
        end
C
C
C==== =================================================================
C
        subroutine dbktrn(n,m,F,ldf,itrnsf, rtrnsf, rwork, ierr)
C
C==== =================================================================
C
C    Purpose
C    =======
C
C    To compute matrix F from F1 = U'FT as computed by DMEVAS, where T and U
C    are computed by DSTAIR.
C    This routine is a driver for dbktr1.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER
C           Column dimension of matrix F
C           N .ge. 1
C
C    M      INTEGER
C           Row dimension of matrix F
C           M .ge. 1
C
C    F      DOUBLE PRECISION array of DIMENSION (LDF, N)
C           The leading M by N part of this array must contain the matrix F1.
C           Note: this array is overwritten.
C
C    LDF    INTEGER
C           Row dimension of array F, as declared in the calling program
C           LDF .ge. M
C
C    Itrnsf INTEGER array of Dimension (max(M,N)(M+1)/2 + M+2N+3)
C           This array contains integer information pertaining to the
C           transformations performed on A and B, as computed by DSTAIR.
C
C    Rtrnsf DOUBLE PRECISION array of Dimension (max(M,N)(M+1)/2 + N(N+1)/2)
C           This array contains floating point information pertaining to the
C           transformations performed on A and B, as computed by DSTAIR.
C
C
C    Arguments Out
C    -------------
C
C    F      DOUBLE PRECISION array of DIMENSION (LDF, N)
C           The leading M by N part of this array contains the matrix F.
C
C
C    Work Space
C    ----------
C
C    Rwork  DOUBLE PRECISION array of DIMENSION (N*2)
C
C
c    Error Indicator
C    ---------------
C
C    Ierr   INTEGER
C           Unless the routine detects an error (see next section),
C           Ierr contains 0 on exit.
C
C
C    Errors detected by the Routine
C    ==============================
C
C    IERR < 0   IERR = -j indicates a problem with the j-th argument
C               on entry.  Specifically:
C               IERR = -1   On entry,  N < 1
C               IERR = -2   On entry,  M < 1
C               IERR = -4   On entry,  LDF < M
C
C    Method
C    ======
C
C    Compute F = U*F1*T' using the factored form of the orthogonal
C    transformations U and T computed by DSTAIR, where F1 is the output
C    from DMEVAS.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer           n, m, ldf
        double precision  F(ldf, *), rtrnsf(*), rwork(*)
        integer           itrnsf(*), ierr
c
c  external subroutines
c       external dbktr1
c
c  initialize
        ierr  = 0
c
c  check some input arguments
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, F, ldf, itrnsf, rtrnsf, rwork, ierr)
      IF( ldf .lt. m ) ierr = -4
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  Partition itrnsf, rtrnsf
c     Arot   goes into itrnsf(1)               (length 1)
c     Brot   goes into itrnsf(2)               (length 1)
c     Mcol   goes into itrnsf(3:2+m+n+1)       (length m+n+1
c     Cnum   goes into itrnsf(m+n+4:m+n+3+n)   (length n)
c     Pos    goes into itrnsf(m+2n+4:end)      (length max(m,n)(m+1)/2)
c
c     Hhold  goes into rtrnsf(1:n(n+1)/2)    length n(n+1)/2
c     CosSin goes into rtrnsf(1+n(n+1)/2)    length max(m,n)(m+1)/2
c
c  do the job
      call dbktr1(n,m, F,ldf, itrnsf(1), itrnsf(2), itrnsf(3),
     &            itrnsf(m+n+4), itrnsf(m+2*n+4), rtrnsf(1),
     &            rtrnsf(1+n*(n+1)/2), Rwork)
c
 9000   continue
        return
C       last line of dbktrn follows
        end
C
C==== =================================================================
C
        subroutine dbktr1(n,m,F,ldf, Arot, Brot, Mcol, Cnum, Pos,
     &                   Hhold, CosSin, Vwork)
C
C==== =================================================================
C
C    Purpose
C    =======
C
C    To compute matrix F from F1 = U'FT as computed by DMEVAS, where T and U
C    are computed by DSTAIR.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER
C           Column dimension of matrix F
C           N .ge. 1
C
C    M      INTEGER
C           Row dimension of matrix F
C           N .ge. 1
C
C    F      DOUBLE PRECISION array of DIMENSION (LDF, N)
C           The leading M by N part of this array must contain the matrix F1.
C           Note: this array is overwritten.
C
C    LDF    INTEGER
C           Row dimension of array F, as declared in the calling program
C           LDF .ge. M
C
C    Arot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix A, as computed by dstr1.
C
C    Brot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix B, as computed by dstr1.
C
C    Mcol   INTEGER array of DIMENSION (M+N).
C           The leading N+M part of this array contains the order of the 
C           column pivoting, as computed by dstr1.
C
C    Cnum   INTEGER array of DIMENSION (N).
C           This array stores the Householders sizes for the Householder
C           vectors, as computed by dstr1.
C
C    Pos    INTEGER array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the positions of the rotations on
C           A and B, as computed by dstr1.
C
C    Hhold  DOUBLE PRECISION array of DIMENSION (N(N+1)/2).
C           This array stores the Householder vectors applied on A
C           and B, as computed by dstr1.
C
C    CosSin DOUBLE PRECISION array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the values used in the rotations on
C           A and B, as computed by dstr1.
C
C
C    Arguments Out
C    -------------
C
C    F      DOUBLE PRECISION array of DIMENSION (LDF, N)
C           The leading M by N part of this array contains the matrix F
C
C    Work Space
C    ----------
C
C    Vwork  DOUBLE PRECISION array of DIMENSION (N*2)
C
C    Method
C    ======
C
C    Compute F = U*F1*T' using the factored form of the orthogonal
C    transformations U and T computed by DSTAIR, where F1 is the output
C    from DMEVAS.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n, m, ldf
        double precision F(ldf,*), Hhold(*)
        double precision Vwork(*), CosSin(*)
        double precision sx, cx
        integer Mcol(*), Cnum(*), Pos(*)
        integer i, cc, hh, num
        integer Arot, Brot
C
C       A list of all external functions used in this subroutine
        external drot, dcopy, dswap
C
C       Do all rotations (in reverse order) done on matrix B
C       Doing the transpose of the rotations in reverse order.
C
        do 505 i = Brot-1, Arot, -2
            sx = CosSin(i)
            cx = CosSin(i-1)
            call drot(n, F(Pos(i-1),1), ldf, F(Pos(i),1),ldf,cx, -sx)
505     continue
C
C       Do all rotations (in reverse order) done on matrix B
        do 160 i = Arot-1, 2, -2
            sx = CosSin(i)
            cx = CosSin(i-1)
            call drot(m, F(1,Pos(i-1)),1, F(1, Pos(i)),1,cx, -sx)
160     continue
C
C       Find the end of the Cnum array and Hhold array.
        cc = 1
        hh = 0
171     if (Cnum(cc) .eq. 0) goto 131
            hh = hh + Cnum(cc)
            cc = cc + 1
            goto 171
131     num = 1
141     if (Mcol(num) .eq. 0) goto 271
            num = num + 1
            goto 141
271     cc = cc - 1
        num = num - 1
        do 281 i = num, cc+1, -1
            if (i .gt. m) then
                call dswap(m, F(1, i-m), 1, F(1, Mcol(i)), 1)
            else
                call dswap(n, F(i, 1), ldf, F(Mcol(i),1), ldf)
            endif
281     continue
        do 191 i = cc, 1, -1
C
C       Extract the Householder vector
            Vwork(1) = 1.0
            call dcopy(Cnum(i), Hhold(hh-Cnum(i)+1), 1, Vwork(2), 1)
C
C       Apply the house holder vector
            call dpthh(F, ldf, m, n, Vwork, Vwork(n+1), 1, n-Cnum(i))
C
C       If i is greater than m the do the pivot done
C       in A.  Else do the pivot done in B.
            if (i .gt. m) then
                call dswap(m, F(1, i-m), 1, F(1, Mcol(i)), 1)
            else
                call dswap(n, F(i, 1), ldf, F(Mcol(i),1), ldf)
            endif
C
C       Update the start of the next house holder vector.
            hh = hh - Cnum(i)
191     continue
C
        return 
C
        end
C
C
C==== ============================================================
        subroutine dhh(X, incx, V, N, mu, tol)
C
C    Purpose
C    =======
C
C    This computes a Householder Vector V from the given vector X.
C    Given the N-vector x, this subroutine computes N-vector v
C    with v(1) = 1 such that  (I - 2vv'/v'v)x  is zero in all 
C    but the first component.  (Here v' is v transposed).
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    X      DOUBLE PRECISION array of DIMENSION (N)
C           The given vector.  The householder vector is computed 
C           from this vector.
C
C    incx   INTEGER 
C           The stride for the vector X.
C
C    N      INTEGER
C           The number of array elements to use in computing the
C           householder vector.
C
C    tol    DOUBLE PRECISION
C           The tolerance.
C
C    Arguments Out
C    -------------
C
C    V      DOUBLE PRECISION array of DIMENSION (N)
C           This stores the computed householder vector.
C
C    mu     DOUBLE PRECISION
C           The two norm of the given vector.
C
C    Method
C    ======
C
C    Given an N-vector x, this subroutine computes an N-vector
C    V with V(1) = 1 such that (I - 2vv'/v'v)x is zero in all 
C    but the first component.  (Here v' is v transposed).
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer N, incx
        double precision X(*), V(*)
        double precision mu, beta, tol
        integer i
C
        double precision dnrm2
        external dnrm2, dcopy
C
C       Compute the 2 norm of column X
        mu = dnrm2(N, X, incx)
C
C       Copy column X into column V
        call dcopy(N, X, incx, V, 1)
C
        V(1) = 1.0
C
C       Calculate householder vector V
        if (mu .ge. tol) then
            if (X(1) .lt. 0.0d0) then
                beta = X(1) - mu
            else
                beta = X(1) + mu
            end if
C
            do 16 i = 2, N
                V(i) = V(i)/beta
16          continue
        end if
C
        return
C
        end
C
C==== =============================================================
C
        subroutine dprehh(A, lda, N, M, V, W, StartN, StartM)
C        
C    Purpose
C    =======
C
C    To do pre-multiplication with the householder vector compute in
C    subroutine dhh() on a matrix A
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that is premultiplied by the reflector determined by vector V.
C
C    lda    INTEGER
C           The leading dimension of array A.
C
C    N      INTEGER
C           Row dimension of matrix A.
C           N .gt. 1
C
C    M      INTEGER
C           Column dimension of matrix A.
C           M .gt. 1
C
C    V      DOUBLE PRECISION array of DIMENSION (N-StartN)
C           This is the householder vector calculated in subroutine
C           dhh().
C
C    StartN INTEGER
C           What row of the matrix to start applying the householder vector.
C           StartN .gt 1 .and. StartN .le. N
C
C    StartM INTEGER
C           What column of the matrix to start applying the householder vector.
C           StartM .gt 1 .and. StartM .le. M
C    
C    Arguments Out
C    -------------
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that was changed by vector V.
C
C    Work Space
C    ----------
C
C    W      DOUBLE PRECSION array of DIMENSION (N)
C
C    Method
C    ======
C
C    Given an N by M matrix A and a nonzero m-vector V with V(1) = 1,
C    the following algorithm overwrites A with PA where P=I-2VV'/V'V.
C    Where V' is V transposed.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer lda, N, M, StartN, StartM
        double precision A(lda, *), V(*), W(*)
        double precision beta
        integer i,j, k
C
C
C       External functions used in this procedure.
C
        double precision ddot
        external ddot
C
C       Calculate Beta -> beta = -2/v'v
        beta = ddot(N-StartN+1, V, 1, V, 1)
        beta = -2/beta
C
C       Calculate W -> W = Beta * a'v
        do 36 i = StartM, M
           W(i) = 0.0
           k = 1
           do 26 j = StartN, N
               W(i) = W(i) + A(j,i)*V(k)
               k = k + 1
26         continue
           W(i) = W(i)*beta
36      continue
C
C        Re-calculate A -> A = A + vw'
C
        k = 1
        do 56 i = StartN, N
            do 46 j = StartM, M
                A(i, j) = A(i,j) + W(j)*V(k)
46          continue
            k = k + 1
56       continue
C                    
        return
C
        end
C
C
C==== =============================================================
C
        subroutine dpthh(A, lda, N, M, V, W, StartN, StartM)
C
C    Purpose
C    =======
C
C    To do post-multiplication on matrix A using the householder
C    vector V.
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that is postmultiplied by the reflector determined by vector V.
C
C    lda    INTEGER
C           The leading dimension of array A.
C
C    N      INTEGER
C           Row dimension of matrix A.
C           N .gt. 1
C
C    M      INTEGER
C           Column dimension of matrix A.
C           M .gt. 1
C
C    V      DOUBLE PRECISION array of DIMENSION (M-StartM)
C           This is the householder vector calculated in subroutine
C           dhh().
C
C    StartN INTEGER
C           What row of the matrix to start applying the householder vector.
C           StartN .gt 1 .and. StartN .le. N
C
C    StartM INTEGER
C           What column of the matrix to start applying the householder vector.
C           StartM .gt 1 .and. StartM .le. M
C    
C    Arguments Out
C    -------------
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that was changed by vector V.
C
C    Work Space
C    ----------
C
C    W      DOUBLE PRECSION array of DIMENSION (N)
C
C
C    Method
C    ======
C
C    Given an N by M matrix A and an N-vector V with V(1) = 1, the 
C    following algorithm overwrites A with AP where P=I-2VV'/V'V.
C    Where V' is V transposed.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C
C       implicit none
        integer lda, N, M, StartN, StartM
        double precision A(lda, *), V(*), W(*)
        double precision beta
        integer i,j, k
C
C        External functions used in this procedure.
        double precision ddot
        external ddot
C
C       Calculate Beta -> beta = -2/v'v
        beta = ddot(M-StartM+1, V, 1, V, 1)
        beta = -2/beta
C
C       Calculate W -> W = Beta * AV
        do 76 i = StartN, N
           W(i) = 0.0
           k = 1
           do 66 j = StartM, M
               W(i) = W(i) + A(i,j)*V(k)
               k = k + 1
66          continue
           W(i) = W(i)*beta
76      continue
C
C       Re-calculate A -> A = A + wv'
        do 96 i = StartN, N
            k = 1
            do 86 j = StartM, M
                A(i, j) = A(i,j) + W(i)*V(k)
                k = k + 1
86          continue
96       continue
C                    
        return
C
        end
C
C
C==== =============================================================
C
        integer function dcnorm(Begin, End, A, lda, n, Row)
C
C    Purpose
C    =======
C
C    Find the next column with with the highest norm.
C    The next column is between (and including) Begin and End.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    Begin  INTEGER
C           What column to start finding the highest norm.
C
C    End    INTEGER
C           What column to stop looking for the highest norm.
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA,*).
C           The leading N by * part of this array is the real matrix A.
C           This is used to find the next column.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    N      INTEGER.
C           Row dimension of matrix A,
C           N .ge. 1
C
C    Row    INTEGER
C           Start at this row when calculating the norm.
C
C    Arguments Out
C    -------------
C
C    dcnrom INTEGER
C           This will be the column with the highest norm.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer lda, Begin, End, n, Row
        double precision A(lda, *)
C
        double precision mu, great
        integer i
C
        double precision dnrm2
        external dnrm2
C
        dcnorm = Begin
        great = 0.0
C
        do 21 i = Begin, End
            mu = dnrm2(n-Row+1, A(Row,i), 1)
            if (mu .gt. great) then
                great = mu
                dcnorm = i
            end if
21      continue
C
        return 
C
        end
C
C
C==== =============================================================
C
        double precision function donorm(n, m, A, lda, B, ldb)
C
C    Purpose
C    =======
C
C    To find the greatest one norm of matrix (B,A).  That is
C    sum all the columns in B and A, the one with the largest
C    sum is the one norm.  The sum must be with absolute values.
C        
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C    
C    N      INTEGER.
C           Row and column dimension of matrix A,
C           N .ge. 1
C
C    M      INTEGER.
C           Column dimension of matrix B.
C           M .ge. 1
C
C    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
C           The leading N by N part of this array must contain the matrix A.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
C           The leading N by M part of this array must contain the matrix B.
C
C    LDB    INTEGER.
C           Row dimension of array B, as declared in the calling program
C           LDB .ge. N
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n,m, lda, ldb
        double precision A(lda, *), B(ldb, *)
        double precision sum
        integer i, j
C
        donorm = 0.0
        do 41 j = 1, m
            sum = 0.0
            do 31 i = 1, n
                sum = sum + dabs(B(i, j))
31          continue
            if (sum .gt. donorm) then
                donorm = sum
            end if
41      continue
C
C       Sum columns in Matrix A
        do 61 j = 1, n
            sum = 0.0
            do 51 i = 1, n
                sum = sum + dabs(A(i, j))
51          continue
            if (sum .gt. donorm) then
                donorm = sum
            end if
61      continue
C
        return 
C
        end
C*** eispk.f
c
c FILE: Eispk.f
c
c===================================================================
c===================================================================

c  The following subroutines from EISPACK
c
c Careful! Anything free comes with no guarantee.
c *** from netlib, Wed Mar 20 07:57:52 EST 1991 ***
c
c===================================================================
c===================================================================
c
      subroutine balanc(nm,n,a,low,igh,scale)
c
c Careful! Anything free comes with no guarantee.
c *** from netlib, Wed Mar 20 07:57:52 EST 1991 ***
c
      integer i,j,k,l,m,n,jj,nm,igh,low,iexc
      double precision a(nm,n),scale(n)
      double precision c,f,g,r,s,b2,radix
      logical noconv
c
c     this subroutine is a translation of the algol procedure balance,
c     num. math. 13, 293-304(1969) by parlett and reinsch.
c     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
c
c     this subroutine balances a real matrix and isolates
c     eigenvalues whenever possible.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the input matrix to be balanced.
c
c     on output
c
c        a contains the balanced matrix.
c
c        low and igh are two integers such that a(i,j)
c          is equal to zero if
c           (1) i is greater than j and
c           (2) j=1,...,low-1 or i=igh+1,...,n.
c
c        scale contains information determining the
c           permutations and scaling factors used.
c
c     suppose that the principal submatrix in rows low through igh
c     has been balanced, that p(j) denotes the index interchanged
c     with j during the permutation step, and that the elements
c     of the diagonal matrix used are denoted by d(i,j).  then
c        scale(j) = p(j),    for j = 1,...,low-1
c                 = d(j,j),      j = low,...,igh
c                 = p(j)         j = igh+1,...,n.
c     the order in which the interchanges are made is n to igh+1,
c     then 1 to low-1.
c
c     note that 1 is returned for igh if igh is zero formally.
c
c     the algol procedure exc contained in balance appears in
c     balanc  in line.  (note that the algol roles of identifiers
c     k,l have been reversed.)
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      radix = 16.0d0
c
      b2 = radix * radix
      k = 1
      l = n
      go to 100
c     .......... in-line procedure for row and
c                column exchange ..........
   20 scale(m) = j
      if (j .eq. m) go to 50
c
      do 30 i = 1, l
         f = a(i,j)
         a(i,j) = a(i,m)
         a(i,m) = f
   30 continue
c
      do 40 i = k, n
         f = a(j,i)
         a(j,i) = a(m,i)
         a(m,i) = f
   40 continue
c
   50 go to (80,130), iexc
c     .......... search for rows isolating an eigenvalue
c                and push them down ..........
   80 if (l .eq. 1) go to 280
      l = l - 1
c     .......... for j=l step -1 until 1 do -- ..........
  100 do 120 jj = 1, l
         j = l + 1 - jj
c
         do 110 i = 1, l
            if (i .eq. j) go to 110
            if (a(j,i) .ne. 0.0d0) go to 120
  110    continue
c
         m = l
         iexc = 1
         go to 20
  120 continue
c
      go to 140
c     .......... search for columns isolating an eigenvalue
c                and push them left ..........
  130 k = k + 1
c
  140 do 170 j = k, l
c
         do 150 i = k, l
            if (i .eq. j) go to 150
            if (a(i,j) .ne. 0.0d0) go to 170
  150    continue
c
         m = k
         iexc = 2
         go to 20
  170 continue
c     .......... now balance the submatrix in rows k to l ..........
      do 180 i = k, l
  180 scale(i) = 1.0d0
c     .......... iterative loop for norm reduction ..........
  190 noconv = .false.
c
      do 270 i = k, l
         c = 0.0d0
         r = 0.0d0
c
         do 200 j = k, l
            if (j .eq. i) go to 200
            c = c + dabs(a(j,i))
            r = r + dabs(a(i,j))
  200    continue
c     .......... guard against zero c or r due to underflow ..........
         if (c .eq. 0.0d0 .or. r .eq. 0.0d0) go to 270
         g = r / radix
         f = 1.0d0
         s = c + r
  210    if (c .ge. g) go to 220
         f = f * radix
         c = c * b2
         go to 210
  220    g = r * radix
  230    if (c .lt. g) go to 240
         f = f / radix
         c = c / b2
         go to 230
c     .......... now balance ..........
  240    if ((c + r) / f .ge. 0.95d0 * s) go to 270
         g = 1.0d0 / f
         scale(i) = scale(i) * f
         noconv = .true.
c
         do 250 j = k, n
  250    a(i,j) = a(i,j) * g
c
         do 260 j = 1, l
  260    a(j,i) = a(j,i) * f
c
  270 continue
c
      if (noconv) go to 190
c
  280 low = k
      igh = l
      return
      end

c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine elmhes(nm,n,low,igh,a,int)
c
c Careful! Anything free comes with no guarantee.
c *** from netlib, Tue Mar 19 12:19:40 EST 1991 ***
c
      integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1
      double precision a(nm,n)
      double precision x,y
      integer int(igh)
c
c     this subroutine is a translation of the algol procedure elmhes,
c     num. math. 12, 349-368(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
c
c     given a real general matrix, this subroutine
c     reduces a submatrix situated in rows and columns
c     low through igh to upper hessenberg form by
c     stabilized elementary similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        a contains the input matrix.
c
c     on output
c
c        a contains the hessenberg matrix.  the multipliers
c          which were used in the reduction are stored in the
c          remaining triangle under the hessenberg matrix.
c
c        int contains information on the rows and columns
c          interchanged in the reduction.
c          only elements low through igh are used.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      la = igh - 1
      kp1 = low + 1
      if (la .lt. kp1) go to 200
c
      do 180 m = kp1, la
         mm1 = m - 1
         x = 0.0d0
         i = m
c
         do 100 j = m, igh
            if (dabs(a(j,mm1)) .le. dabs(x)) go to 100
            x = a(j,mm1)
            i = j
  100    continue
c
         int(m) = i
         if (i .eq. m) go to 130
c     .......... interchange rows and columns of a ..........
         do 110 j = mm1, n
            y = a(i,j)
            a(i,j) = a(m,j)
            a(m,j) = y
  110    continue
c
         do 120 j = 1, igh
            y = a(j,i)
            a(j,i) = a(j,m)
            a(j,m) = y
  120    continue
c     .......... end interchange ..........
  130    if (x .eq. 0.0d0) go to 180
         mp1 = m + 1
c
         do 160 i = mp1, igh
            y = a(i,mm1)
            if (y .eq. 0.0d0) go to 160
            y = y / x
            a(i,mm1) = y
c
            do 140 j = m, n
  140       a(i,j) = a(i,j) - y * a(m,j)
c
            do 150 j = 1, igh
  150       a(j,m) = a(j,m) + y * a(j,i)
c
  160    continue
c
  180 continue
c
  200 return
      end

c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine hqr(nm,n,low,igh,h,wr,wi,ierr)
C  RESTORED CORRECT INDICES OF LOOPS (200,210,230,240). (9/29/89 BSG)
c
c Careful! Anything free comes with no guarantee.
c *** from netlib, Tue Mar 19 12:19:41 EST 1991 ***
c
      integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr
      double precision h(nm,n),wr(n),wi(n)
      double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2
      logical notlas
c
c     this subroutine is a translation of the algol procedure hqr,
c     num. math. 14, 219-231(1970) by martin, peters, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 359-371(1971).
c
c     this subroutine finds the eigenvalues of a real
c     upper hessenberg matrix by the qr method.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        h contains the upper hessenberg matrix.  information about
c          the transformations used in the reduction to hessenberg
c          form by  elmhes  or  orthes, if performed, is stored
c          in the remaining triangle under the hessenberg matrix.
c
c     on output
c
c        h has been destroyed.  therefore, it must be saved
c          before calling  hqr  if subsequent calculation and
c          back transformation of eigenvectors is to be performed.
c
c        wr and wi contain the real and imaginary parts,
c          respectively, of the eigenvalues.  the eigenvalues
c          are unordered except that complex conjugate pairs
c          of values appear consecutively with the eigenvalue
c          having the positive imaginary part first.  if an
c          error exit is made, the eigenvalues should be correct
c          for indices ierr+1,...,n.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the limit of 30*n iterations is exhausted
c                     while the j-th eigenvalue is being sought.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated september 1989.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      norm = 0.0d0
      k = 1
c     .......... store roots isolated by balanc
c                and compute matrix norm ..........
      do 50 i = 1, n
c
         do 40 j = k, n
   40    norm = norm + dabs(h(i,j))
c
         k = i
         if (i .ge. low .and. i .le. igh) go to 50
         wr(i) = h(i,i)
         wi(i) = 0.0d0
   50 continue
c
      en = igh
      t = 0.0d0
      itn = 30*n
c     .......... search for next eigenvalues ..........
   60 if (en .lt. low) go to 1001
      its = 0
      na = en - 1
      enm2 = na - 1
c     .......... look for single small sub-diagonal element
c                for l=en step -1 until low do -- ..........
   70 do 80 ll = low, en
         l = en + low - ll
         if (l .eq. low) go to 100
         s = dabs(h(l-1,l-1)) + dabs(h(l,l))
         if (s .eq. 0.0d0) s = norm
         tst1 = s
         tst2 = tst1 + dabs(h(l,l-1))
         if (tst2 .eq. tst1) go to 100
   80 continue
c     .......... form shift ..........
  100 x = h(en,en)
      if (l .eq. en) go to 270
      y = h(na,na)
      w = h(en,na) * h(na,en)
      if (l .eq. na) go to 280
      if (itn .eq. 0) go to 1000
      if (its .ne. 10 .and. its .ne. 20) go to 130
c     .......... form exceptional shift ..........
      t = t + x
c
      do 120 i = low, en
  120 h(i,i) = h(i,i) - x
c
      s = dabs(h(en,na)) + dabs(h(na,enm2))
      x = 0.75d0 * s
      y = x
      w = -0.4375d0 * s * s
  130 its = its + 1
      itn = itn - 1
c     .......... look for two consecutive small
c                sub-diagonal elements.
c                for m=en-2 step -1 until l do -- ..........
      do 140 mm = l, enm2
         m = enm2 + l - mm
         zz = h(m,m)
         r = x - zz
         s = y - zz
         p = (r * s - w) / h(m+1,m) + h(m,m+1)
         q = h(m+1,m+1) - zz - r - s
         r = h(m+2,m+1)
         s = dabs(p) + dabs(q) + dabs(r)
         p = p / s
         q = q / s
         r = r / s
         if (m .eq. l) go to 150
         tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))
         tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r))
         if (tst2 .eq. tst1) go to 150
  140 continue
c
  150 mp2 = m + 2
c
      do 160 i = mp2, en
         h(i,i-2) = 0.0d0
         if (i .eq. mp2) go to 160
         h(i,i-3) = 0.0d0
  160 continue
c     .......... double qr step involving rows l to en and
c                columns m to en ..........
      do 260 k = m, na
         notlas = k .ne. na
         if (k .eq. m) go to 170
         p = h(k,k-1)
         q = h(k+1,k-1)
         r = 0.0d0
         if (notlas) r = h(k+2,k-1)
         x = dabs(p) + dabs(q) + dabs(r)
         if (x .eq. 0.0d0) go to 260
         p = p / x
         q = q / x
         r = r / x
  170    s = dsign(dsqrt(p*p+q*q+r*r),p)
         if (k .eq. m) go to 180
         h(k,k-1) = -s * x
         go to 190
  180    if (l .ne. m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
         x = p / s
         y = q / s
         zz = r / s
         q = q / p
         r = r / p
         if (notlas) go to 225
c     .......... row modification ..........
         do 200 j = k, EN
            p = h(k,j) + q * h(k+1,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
  200    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 210 i = L, j
            p = x * h(i,k) + y * h(i,k+1)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
  210    continue
         go to 255
  225    continue
c     .......... row modification ..........
         do 230 j = k, EN
            p = h(k,j) + q * h(k+1,j) + r * h(k+2,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
            h(k+2,j) = h(k+2,j) - p * zz
  230    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 240 i = L, j
            p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
            h(i,k+2) = h(i,k+2) - p * r
  240    continue
  255    continue
c
  260 continue
c
      go to 70
c     .......... one root found ..........
  270 wr(en) = x + t
      wi(en) = 0.0d0
      en = na
      go to 60
c     .......... two roots found ..........
  280 p = (y - x) / 2.0d0
      q = p * p + w
      zz = dsqrt(dabs(q))
      x = x + t
      if (q .lt. 0.0d0) go to 320
c     .......... real pair ..........
      zz = p + dsign(zz,p)
      wr(na) = x + zz
      wr(en) = wr(na)
      if (zz .ne. 0.0d0) wr(en) = x - w / zz
      wi(na) = 0.0d0
      wi(en) = 0.0d0
      go to 330
c     .......... complex pair ..........
  320 wr(na) = x + p
      wr(en) = x + p
      wi(na) = zz
      wi(en) = -zz
  330 en = enm2
      go to 60
c     .......... set error -- all eigenvalues have not
c                converged after 30*n iterations ..........
 1000 ierr = en
 1001 return
      end

C*** lapack.f
c
c FILE: Lapack.f
c
c==== =================================================================
c
      SUBROUTINE DLABAD( SMALL, LARGE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   LARGE, SMALL
*     ..
*
*  Purpose
*  =======
*
*  DLABAD takes as input the values computed by DLAMCH for underflow and
*  overflow, and returns the square root of each of these values if the
*  log of LARGE is sufficiently large.  This subroutine is intended to
*  identify machines with a large exponent range, such as the Crays, and
*  redefine the underflow and overflow limits to be the square roots of
*  the values computed by DLAMCH.  This subroutine is needed because
*  DLAMCH does not compensate for poor arithmetic in the upper half of
*  the exponent range, as is found on a Cray.
*
*  Arguments
*  =========
*
*  SMALL   (input/output) DOUBLE PRECISION
*          On entry, the underflow threshold as computed by DLAMCH.
*          On exit, if LOG10(LARGE) is sufficiently large, the square
*          root of SMALL, otherwise unchanged.
*
*  LARGE   (input/output) DOUBLE PRECISION
*          On entry, the overflow threshold as computed by DLAMCH.
*          On exit, if LOG10(LARGE) is sufficiently large, the square
*          root of LARGE, otherwise unchanged.
*
*     .. Intrinsic Functions ..
      INTRINSIC          LOG10, SQRT
*     ..
*     .. Executable Statements ..
*
*     If it looks like we're on a Cray, take the square root of
*     SMALL and LARGE to avoid overflow and underflow problems.
*
      IF( LOG10( LARGE ).GT.2000.D0 ) THEN
         SMALL = SQRT( SMALL )
         LARGE = SQRT( LARGE )
      END IF
*
      RETURN
*
*     End of DLABAD
*
      END
      SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            KASE, N
      DOUBLE PRECISION   EST
*     ..
*     .. Array Arguments ..
      INTEGER            ISGN( * )
      DOUBLE PRECISION   V( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DLACON estimates the 1-norm of a square, real matrix A.
*  Reverse communication is used for evaluating matrix-vector products.
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         The order of the matrix.  N >= 1.
*
*  V      (workspace) DOUBLE PRECISION array, dimension (N)
*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
*         (W is not returned).
*
*  X      (input/output) DOUBLE PRECISION array, dimension (N)
*         On an intermediate return, X should be overwritten by
*               A * X,   if KASE=1,
*               A' * X,  if KASE=2,
*         and DLACON must be re-called with all the other parameters
*         unchanged.
*
*  ISGN   (workspace) INTEGER array, dimension (N)
*
*  EST    (output) DOUBLE PRECISION
*         An estimate (a lower bound) for norm(A).
*
*  KASE   (input/output) INTEGER
*         On the initial call to DLACON, KASE should be 0.
*         On an intermediate return, KASE will be 1 or 2, indicating
*         whether X should be overwritten by A * X  or A' * X.
*         On the final return from DLACON, KASE will again be 0.
*
*  Further Details
*  ======= =======
*
*  Contributed by Nick Higham, University of Manchester.
*  Originally named SONEST, dated March 16, 1988.
*
*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
*  a real or complex matrix, with applications to condition estimation",
*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ITER, J, JLAST, JUMP
      DOUBLE PRECISION   ALTSGN, ESTOLD, TEMP
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM
      EXTERNAL           IDAMAX, DASUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, NINT, SIGN
*     ..
*     .. Save statement ..
      SAVE
*     ..
*     .. Executable Statements ..
*
      IF( KASE.EQ.0 ) THEN
         DO 10 I = 1, N
            X( I ) = ONE / DBLE( N )
   10    CONTINUE
         KASE = 1
         JUMP = 1
         RETURN
      END IF
*
      GO TO ( 20, 40, 70, 110, 140 )JUMP
*
*     ................ ENTRY   (JUMP = 1)
*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
*
   20 CONTINUE
      IF( N.EQ.1 ) THEN
         V( 1 ) = X( 1 )
         EST = ABS( V( 1 ) )
*        ... QUIT
         GO TO 150
      END IF
      EST = DASUM( N, X, 1 )
*
      DO 30 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
   30 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
*
*     ................ ENTRY   (JUMP = 2)
*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
*
   40 CONTINUE
      J = IDAMAX( N, X, 1 )
      ITER = 2
*
*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
   50 CONTINUE
      DO 60 I = 1, N
         X( I ) = ZERO
   60 CONTINUE
      X( J ) = ONE
      KASE = 1
      JUMP = 3
      RETURN
*
*     ................ ENTRY   (JUMP = 3)
*     X HAS BEEN OVERWRITTEN BY A*X.
*
   70 CONTINUE
      CALL DCOPY( N, X, 1, V, 1 )
      ESTOLD = EST
      EST = DASUM( N, V, 1 )
      DO 80 I = 1, N
         IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
     $      GO TO 90
   80 CONTINUE
*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
      GO TO 120
*
   90 CONTINUE
*     TEST FOR CYCLING.
      IF( EST.LE.ESTOLD )
     $   GO TO 120
*
      DO 100 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
  100 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
*
*     ................ ENTRY   (JUMP = 4)
*     X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
*
  110 CONTINUE
      JLAST = J
      J = IDAMAX( N, X, 1 )
      IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
         ITER = ITER + 1
         GO TO 50
      END IF
*
*     ITERATION COMPLETE.  FINAL STAGE.
*
  120 CONTINUE
      ALTSGN = ONE
      DO 130 I = 1, N
         X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
         ALTSGN = -ALTSGN
  130 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
*
*     ................ ENTRY   (JUMP = 5)
*     X HAS BEEN OVERWRITTEN BY A*X.
*
  140 CONTINUE
      TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
      IF( TEMP.GT.EST ) THEN
         CALL DCOPY( N, X, 1, V, 1 )
         EST = TEMP
      END IF
*
  150 CONTINUE
      KASE = 0
      RETURN
*
*     End of DLACON
*
      END
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          CMACH
*     ..
*
*  Purpose
*  =======
*
*  DLAMCH determines double precision machine parameters.
*
*  Arguments
*  =========
*
*  CMACH   (input) CHARACTER*1
*          Specifies the value to be returned by DLAMCH:
*          = 'E' or 'e',   DLAMCH := eps
*          = 'S' or 's ,   DLAMCH := sfmin
*          = 'B' or 'b',   DLAMCH := base
*          = 'P' or 'p',   DLAMCH := eps*base
*          = 'N' or 'n',   DLAMCH := t
*          = 'R' or 'r',   DLAMCH := rnd
*          = 'M' or 'm',   DLAMCH := emin
*          = 'U' or 'u',   DLAMCH := rmin
*          = 'L' or 'l',   DLAMCH := emax
*          = 'O' or 'o',   DLAMCH := rmax
*
*          where
*
*          eps   = relative machine precision
*          sfmin = safe minimum, such that 1/sfmin does not overflow
*          base  = base of the machine
*          prec  = eps*base
*          t     = number of (base) digits in the mantissa
*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*          emin  = minimum exponent before (gradual) underflow
*          rmin  = underflow threshold - base**(emin-1)
*          emax  = largest exponent before overflow
*          rmax  = overflow threshold  - (base**emax)*(1-eps)
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
     $                   RND, SFMIN, SMALL, T
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMC2
*     ..
*     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
     $                   EMAX, RMAX, PREC
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
*
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
*
      DLAMCH = RMACH
      RETURN
*
*     End of DLAMCH
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
*     ..
*
*  Purpose
*  =======
*
*  DLAMC1 determines the machine parameters given by BETA, T, RND, and
*  IEEE1.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  IEEE1   (output) LOGICAL
*          Specifies whether rounding appears to be done in the IEEE
*          'round to nearest' style.
*
*  Further Details
*  ===============
*
*  The routine is based on the routine  ENVRON  by Malcolm and
*  incorporates suggestions by Gentleman and Marovich. See
*
*     Malcolm M. A. (1972) Algorithms to reveal properties of
*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
*        that reveal properties of floating point arithmetic units.
*        Comms. of the ACM, 17, 276-277.
*
*
*     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
*
*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
*        IEEE1, T and RND.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are  stored and not held in registers,  or
*        are not affected by optimizers.
*
*        Compute  a = 2.0**m  with the  smallest positive integer m such
*        that
*
*           fl( a + 1.0 ) = a.
*
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 10
         END IF
*+       END WHILE
*
*        Now compute  b = 2.0**m  with the smallest positive integer m
*        such that
*
*           fl( a + b ) .gt. a.
*
         B = 1
         C = DLAMC3( A, B )
*
*+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
*+       END WHILE
*
*        Now compute the base.  a and c  are neighbouring floating point
*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
*        their difference is beta. Adding 0.25 to c is to ensure that it
*        is truncated to beta and not ( beta - 1 ).
*
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
*
*        Now determine whether rounding or chopping occurs,  by adding a
*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
*
         B = LBETA
         F = DLAMC3( B / 2, -B / 100 )
         C = DLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = DLAMC3( B / 2, B / 100 )
         C = DLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )
     $      LRND = .FALSE.
*
*        Try and decide whether rounding is done in the  IEEE  'round to
*        nearest' style. B/2 is half a unit in the last place of the two
*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
*        A, but adding B/2 to SAVEC should change SAVEC.
*
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
*        Now find  the  mantissa, t.  It should  be the  integer part of
*        log to the base beta of a,  however it is safer to determine  t
*        by powering.  So we find t as the smallest positive integer for
*        which
*
*           fl( beta**t + 1.0 ) = 1.0.
*
         LT = 0
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 30
         END IF
*+       END WHILE
*
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
*
*     End of DLAMC1
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      DOUBLE PRECISION   EPS, RMAX, RMIN
*     ..
*
*  Purpose
*  =======
*
*  DLAMC2 determines the machine parameters specified in its argument
*  list.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  EPS     (output) DOUBLE PRECISION
*          The smallest positive number such that
*
*             fl( 1.0 - EPS ) .LT. 1.0,
*
*          where fl denotes the computed value.
*
*  EMIN    (output) INTEGER
*          The minimum exponent before (gradual) underflow occurs.
*
*  RMIN    (output) DOUBLE PRECISION
*          The smallest normalized number for the machine, given by
*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
*          of BETA.
*
*  EMAX    (output) INTEGER
*          The maximum exponent before overflow occurs.
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest positive number for the machine, given by
*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
*          value of BETA.
*
*  Further Details
*  ===============
*
*  The computation of  EPS  is based on a routine PARANOIA by
*  W. Kahan of the University of California at Berkeley.
*
*
*     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
*
*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
*        BETA, T, RND, EPS, EMIN and RMIN.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are stored  and not held in registers,  or
*        are not affected by optimizers.
*
*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
*
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
*        Start to find EPS.
*
         B = LBETA
         A = B**( -LT )
         LEPS = A
*
*        Try some tricks to see whether or not this is the correct  EPS.
*
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = DLAMC3( B, -HALF )
         THIRD = DLAMC3( SIXTH, SIXTH )
         B = DLAMC3( THIRD, -HALF )
         B = DLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )
     $      B = LEPS
*
         LEPS = 1
*
*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = DLAMC3( HALF, -C )
            B = DLAMC3( HALF, C )
            C = DLAMC3( HALF, -B )
            B = DLAMC3( HALF, C )
            GO TO 10
         END IF
*+       END WHILE
*
         IF( A.LT.LEPS )
     $      LEPS = A
*
*        Computation of EPS complete.
*
*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
*        Keep dividing  A by BETA until (gradual) underflow occurs. This
*        is detected when we cannot recover the previous A.
*
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = DLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = DLAMC3( ONE, SMALL )
         CALL DLAMC4( NGPMIN, ONE, LBETA )
         CALL DLAMC4( NGNMIN, -ONE, LBETA )
         CALL DLAMC4( GPMIN, A, LBETA )
         CALL DLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
*
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
*            ( Non twos-complement machines, no gradual underflow;
*              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
*            ( Non twos-complement machines, with gradual underflow;
*              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
*            ( Twos-complement machines, no gradual underflow;
*              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
     $            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
*            ( Twos-complement machines with gradual underflow;
*              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
*         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
***
* Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
***
*
*        Assume IEEE arithmetic if we found denormalised  numbers above,
*        or if arithmetic seems to round in the  IEEE style,  determined
*        in routine DLAMC1. A true IEEE machine should have both  things
*        true; however, faulty machines may have one or the other.
*
         IEEE = IEEE .OR. LIEEE1
*
*        Compute  RMIN by successive division by  BETA. We could compute
*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
*        this computation.
*
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
*
*        Finally, call DLAMC5 to compute EMAX and RMAX.
*
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
*
      RETURN
*
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', I8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
*     End of DLAMC2
*
      END
*
************************************************************************
*
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
*     ..
*
*  Purpose
*  =======
*
*  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
*  the addition of  A  and  B ,  for use in situations where optimizers
*  might hold one of these in a register.
*
*  Arguments
*  =========
*
*  A, B    (input) DOUBLE PRECISION
*          The values A and B.
*
*
*     .. Executable Statements ..
*
      DLAMC3 = A + B
*
      RETURN
*
*     End of DLAMC3
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC4( EMIN, START, BASE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      DOUBLE PRECISION   START
*     ..
*
*  Purpose
*  =======
*
*  DLAMC4 is a service routine for DLAMC2.
*
*  Arguments
*  =========
*
*  EMIN    (output) EMIN
*          The minimum exponent before (gradual) underflow, computed by
*          setting A = START and dividing by BASE until the previous A
*          can not be recovered.
*
*  START   (input) DOUBLE PRECISION
*          The starting point for determining EMIN.
*
*  BASE    (input) INTEGER
*          The base of the machine.
*
*
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Executable Statements ..
*
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
     $    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = DLAMC3( A / BASE, ZERO )
         C1 = DLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = DLAMC3( A*RBASE, ZERO )
         C2 = DLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
*+    END WHILE
*
      RETURN
*
*     End of DLAMC4
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      DOUBLE PRECISION   RMAX
*     ..
*
*  Purpose
*  =======
*
*  DLAMC5 attempts to compute RMAX, the largest machine floating-point
*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
*  approximately to a power of 2.  It will fail on machines where this
*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
*  too large (i.e. too close to zero), probably with overflow.
*
*  Arguments
*  =========
*
*  BETA    (input) INTEGER
*          The base of floating-point arithmetic.
*
*  P       (input) INTEGER
*          The number of base BETA digits in the mantissa of a
*          floating-point value.
*
*  EMIN    (input) INTEGER
*          The minimum exponent before (gradual) underflow.
*
*  IEEE    (input) LOGICAL
*          A logical flag specifying whether or not the arithmetic
*          system is thought to comply with the IEEE standard.
*
*  EMAX    (output) INTEGER
*          The largest exponent before overflow
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest machine floating-point number.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     First compute LEXP and UEXP, two powers of 2 that bound
*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
*     approximately to the bound that is closest to abs(EMIN).
*     (EMAX is the exponent of the required number RMAX).
*
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
*
*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
*     than or equal to EMIN. EXBITS is the number of bits needed to
*     store the exponent.
*
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
*
*     EXPSUM is the exponent range, approximately equal to
*     EMAX - EMIN + 1 .
*
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
*
*     NBITS is the total number of bits needed to store a
*     floating-point number.
*
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
*        Either there are an odd number of bits used to store a
*        floating-point number, which is unlikely, or some bits are
*        not used in the representation of numbers, which is possible,
*        (e.g. Cray machines) or the mantissa has an implicit bit,
*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*        most likely. We have to assume the last alternative.
*        If this is true, then we need to reduce EMAX by one because
*        there must be some way of representing zero in an implicit-bit
*        system. On machines like Cray, we are reducing EMAX by one
*        unnecessarily.
*
         EMAX = EMAX - 1
      END IF
*
      IF( IEEE ) THEN
*
*        Assume we are on an IEEE machine which reserves one exponent
*        for infinity and NaN.
*
         EMAX = EMAX - 1
      END IF
*
*     Now create RMAX, the largest machine number, which should
*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
*     First compute 1.0 - BETA**(-P), being careful that the
*     result is less than 1.0 .
*
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )
     $      OLDY = Y
         Y = DLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )
     $   Y = OLDY
*
*     Now multiply by BETA**EMAX to get RMAX.
*
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
*
      RMAX = Y
      RETURN
*
*     End of DLAMC5
*
      END
      DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
     $                 WORK )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLANTR  returns the value of the one norm,  or the Frobenius norm, or
*  the  infinity norm,  or the  element of  largest absolute value  of a
*  trapezoidal or triangular matrix A.
*
*  Description
*  ===========
*
*  DLANTR returns the value
*
*     DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*              (
*              ( norm1(A),         NORM = '1', 'O' or 'o'
*              (
*              ( normI(A),         NORM = 'I' or 'i'
*              (
*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
*
*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
*
*  Arguments
*  =========
*
*  NORM    (input) CHARACTER*1
*          Specifies the value to be returned in DLANTR as described
*          above.
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower trapezoidal.
*          = 'U':  Upper trapezoidal
*          = 'L':  Lower trapezoidal
*          Note that A is triangular instead of trapezoidal if M = N.
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A has unit diagonal.
*          = 'N':  Non-unit diagonal
*          = 'U':  Unit diagonal
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0, and if
*          UPLO = 'U', M <= N.  When M = 0, DLANTR is set to zero.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0, and if
*          UPLO = 'L', N <= M.  When N = 0, DLANTR is set to zero.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The trapezoidal matrix A (A is triangular if M = N).
*          If UPLO = 'U', the leading m by n upper trapezoidal part of
*          the array A contains the upper trapezoidal matrix, and the
*          strictly lower triangular part of A is not referenced.
*          If UPLO = 'L', the leading m by n lower trapezoidal part of
*          the array A contains the lower trapezoidal matrix, and the
*          strictly upper triangular part of A is not referenced.  Note
*          that when DIAG = 'U', the diagonal elements of A are not
*          referenced and are assumed to be one.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(M,1).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*          referenced.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UDIAG
      INTEGER            I, J
      DOUBLE PRECISION   SCALE, SUM, VALUE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASSQ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
*        Find max(abs(A(i,j))).
*
         IF( LSAME( DIAG, 'U' ) ) THEN
            VALUE = ONE
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = 1, MIN( M, J-1 )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = J + 1, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            VALUE = ZERO
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = 1, MIN( M, J )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  DO 70 I = J, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
*        Find norm1(A).
*
         VALUE = ZERO
         UDIAG = LSAME( DIAG, 'U' )
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 1, N
               IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
                  SUM = ONE
                  DO 90 I = 1, J - 1
                     SUM = SUM + ABS( A( I, J ) )
   90             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 100 I = 1, MIN( M, J )
                     SUM = SUM + ABS( A( I, J ) )
  100             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  110       CONTINUE
         ELSE
            DO 140 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 120 I = J + 1, M
                     SUM = SUM + ABS( A( I, J ) )
  120             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 130 I = J, M
                     SUM = SUM + ABS( A( I, J ) )
  130             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  140       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
*        Find normI(A).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 150 I = 1, M
                  WORK( I ) = ONE
  150          CONTINUE
               DO 170 J = 1, N
                  DO 160 I = 1, MIN( M, J-1 )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  160             CONTINUE
  170          CONTINUE
            ELSE
               DO 180 I = 1, M
                  WORK( I ) = ZERO
  180          CONTINUE
               DO 200 J = 1, N
                  DO 190 I = 1, MIN( M, J )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  190             CONTINUE
  200          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 210 I = 1, N
                  WORK( I ) = ONE
  210          CONTINUE
               DO 220 I = N + 1, M
                  WORK( I ) = ZERO
  220          CONTINUE
               DO 240 J = 1, N
                  DO 230 I = J + 1, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  230             CONTINUE
  240          CONTINUE
            ELSE
               DO 250 I = 1, M
                  WORK( I ) = ZERO
  250          CONTINUE
               DO 270 J = 1, N
                  DO 260 I = J, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  260             CONTINUE
  270          CONTINUE
            END IF
         END IF
         VALUE = ZERO
         DO 280 I = 1, M
            VALUE = MAX( VALUE, WORK( I ) )
  280    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
*        Find normF(A).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 290 J = 2, N
                  CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
  290          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 300 J = 1, N
                  CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
  300          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 310 J = 1, N
                  CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
     $                         SUM )
  310          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 320 J = 1, N
                  CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
  320          CONTINUE
            END IF
         END IF
         VALUE = SCALE*SQRT( SUM )
      END IF
*
      DLANTR = VALUE
      RETURN
*
*     End of DLANTR
*
      END
      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SCALE, SUMSQ
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
*     ..
*
*  Purpose
*  =======
*
*  DLASSQ  returns the values  scl  and  smsq  such that
*
*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
*  assumed to be non-negative and  scl  returns the value
*
*     scl = max( scale, abs( x( i ) ) ).
*
*  scale and sumsq must be supplied in SCALE and SUMSQ and
*  scl and smsq are overwritten on SCALE and SUMSQ respectively.
*
*  The routine makes only one pass through the vector x.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of elements to be used from the vector X.
*
*  X       (input) DOUBLE PRECISION
*          The vector for which a scaled sum of squares is computed.
*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
*  INCX    (input) INTEGER
*          The increment between successive values of the vector X.
*          INCX > 0.
*
*  SCALE   (input/output) DOUBLE PRECISION
*          On entry, the value  scale  in the equation above.
*          On exit, SCALE is overwritten with  scl , the scaling factor
*          for the sum of squares.
*
*  SUMSQ   (input/output) DOUBLE PRECISION
*          On entry, the value  sumsq  in the equation above.
*          On exit, SUMSQ is overwritten with  smsq , the basic sum of
*          squares from which  scl  has been factored out.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IX
      DOUBLE PRECISION   ABSXI
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IF( N.GT.0 ) THEN
         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
            IF( X( IX ).NE.ZERO ) THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
*
*     End of DLASSQ
*
      END
      SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
     $                   CNORM, INFO )
*
*  -- LAPACK auxiliary routine (version 1.0a) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORMIN, TRANS, UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   SCALE
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), CNORM( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DLATRS solves one of the triangular systems
*
*     A *x = s*b  or  A'*x = s*b
*
*  with scaling to prevent overflow.  Here A is an upper or lower
*  triangular matrix, A' denotes the transpose of A, x and b are
*  n-element vectors, and s is a scaling factor, usually less than
*  or equal to 1, chosen so that the components of x will be less than
*  the overflow threshold.  If the unscaled problem will not cause
*  overflow, the Level 2 BLAS routine DTRSV is called.  If the matrix A
*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
*  non-trivial solution to A*x = 0 is returned.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  TRANS   (input) CHARACTER*1
*          Specifies the operation applied to A.
*          = 'N':  Solve A * x = s*b  (No transpose)
*          = 'T':  Solve A'* x = s*b  (Transpose)
*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  NORMIN  (input) CHARACTER*1
*          Specifies whether CNORM has been set or not.
*          = 'Y':  CNORM contains the column norms on entry
*          = 'N':  CNORM is not set on entry.  On exit, the norms will
*                  be computed and stored in CNORM.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max (1,N).
*
*  X       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the right hand side b of the triangular system.
*          On exit, X is overwritten by the solution vector x.
*
*  SCALE   (output) DOUBLE PRECISION
*          The scaling factor s for the triangular system
*             A * x = s*b  or  A'* x = s*b.
*          If SCALE = 0, the matrix A is singular or badly scaled, and
*          the vector x is an exact or approximate solution to A*x = 0.
*
*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
*
*          If NORMIN = 'Y', CNORM is an input variable and CNORM(j)
*          contains the norm of the off-diagonal part of the j-th column
*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
*          must be greater than or equal to the 1-norm.
*
*          If NORMIN = 'N', CNORM is an output variable and CNORM(j)
*          returns the 1-norm of the offdiagonal part of the j-th column
*          of A.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*
*  Further Details
*  ======= =======
*
*  A rough bound on x is computed; if that is less than overflow, DTRSV
*  is called, otherwise, specific code is used which checks for possible
*  overflow or divide-by-zero at every operation.
*
*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
*  if A is lower triangular is
*
*       x[1:n] := b[1:n]
*       for j = 1, ..., n
*            x(j) := x(j) / A(j,j)
*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
*       end
*
*  Define bounds on the components of x after j iterations of the loop:
*     M(j) = bound on x[1:j]
*     G(j) = bound on x[j+1:n]
*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
*  Then for iteration j+1 we have
*     M(j+1) <= G(j) / | A(j+1,j+1) |
*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
*  where CNORM(j+1) is greater than or equal to the infinity-norm of
*  column j+1 of A, not counting the diagonal.  Hence
*
*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
*                  1<=i<=j
*  and
*
*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*                                   1<=i< j
*
*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
*  reciprocal of the largest M(j), j=1,..,n, is larger than
*  max(underflow, 1/overflow).
*
*  The bound on x(j) is also used to determine when a step in the
*  columnwise method can be performed without fear of overflow.  If
*  the computed bound is greater than a large constant, x is scaled to
*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
*  algorithm for A upper triangular is
*
*       for j = 1, ..., n
*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
*       end
*
*  We simultaneously compute two bounds
*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
*       M(j) = bound on x(i), 1<=i<=j
*
*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
*  Then the bound on x(j) is
*
*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
*                      1<=i<=j
*
*  and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
*  than max(underflow, 1/overflow).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DTRSV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Test the input parameters.
*
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $         LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
     $         LSAME( NORMIN, 'N' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLATRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Determine machine dependent parameters to control overflow.
*
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      SCALE = ONE
*
      IF( LSAME( NORMIN, 'N' ) ) THEN
*
*        Compute the 1-norm of each column, not including the diagonal.
*
         IF( UPPER ) THEN
*
*           A is upper triangular.
*
            DO 10 J = 1, N
               CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
   10       CONTINUE
         ELSE
*
*           A is lower triangular.
*
            DO 20 J = 1, N - 1
               CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
   20       CONTINUE
            CNORM( N ) = ZERO
         END IF
      END IF
*
*     Scale the column norms by TSCAL if the maximum entry in CNORM is
*     greater than BIGNUM.
*
      IMAX = IDAMAX( N, CNORM, 1 )
      TMAX = CNORM( IMAX )
      IF( TMAX.LE.BIGNUM ) THEN
         TSCAL = ONE
      ELSE
         TSCAL = ONE / ( SMLNUM*TMAX )
         CALL DSCAL( N, TSCAL, CNORM, 1 )
      END IF
*
*     Compute a bound on the computed solution vector to see if the
*     Level 2 BLAS routine DTRSV can be used.
*
      J = IDAMAX( N, X, 1 )
      XMAX = ABS( X( J ) )
      XBND = XMAX
      IF( NOTRAN ) THEN
*
*        Compute the growth in A * x = b.
*
         IF( UPPER ) THEN
            JFIRST = N
            JLAST = 1
            JINC = -1
         ELSE
            JFIRST = 1
            JLAST = N
            JINC = 1
         END IF
*
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 50
         END IF
*
         IF( NOUNIT ) THEN
*
*           A is non-unit triangular.
*
*           Compute GROW = 1/G(j) and XBND = 1/M(j).
*           Initially, G(0) = max{x(i), i=1,...,n}.
*
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 30 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 50
*
*              M(j) = G(j-1) / abs(A(j,j))
*
               TJJ = ABS( A( J, J ) )
               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
               ELSE
*
*                 G(j) could overflow, set GROW to 0.
*
                  GROW = ZERO
               END IF
   30       CONTINUE
            GROW = XBND
         ELSE
*
*           A is unit triangular.
*
*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 40 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 50
*
*              G(j) = G(j-1)*( 1 + CNORM(j) )
*
               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
   40       CONTINUE
         END IF
   50    CONTINUE
*
      ELSE
*
*        Compute the growth in A' * x = b.
*
         IF( UPPER ) THEN
            JFIRST = 1
            JLAST = N
            JINC = 1
         ELSE
            JFIRST = N
            JLAST = 1
            JINC = -1
         END IF
*
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 80
         END IF
*
         IF( NOUNIT ) THEN
*
*           A is non-unit triangular.
*
*           Compute GROW = 1/G(j) and XBND = 1/M(j).
*           Initially, M(0) = max{x(i), i=1,...,n}.
*
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 60 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 80
*
*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
               XJ = ONE + CNORM( J )
               GROW = MIN( GROW, XBND / XJ )
*
*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
               TJJ = ABS( A( J, J ) )
               IF( XJ.GT.TJJ )
     $            XBND = XBND*( TJJ / XJ )
   60       CONTINUE
            GROW = MIN( GROW, XBND )
         ELSE
*
*           A is unit triangular.
*
*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 70 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 80
*
*              G(j) = ( 1 + CNORM(j) )*G(j-1)
*
               XJ = ONE + CNORM( J )
               GROW = GROW / XJ
   70       CONTINUE
         END IF
   80    CONTINUE
      END IF
*
      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
*        Use the Level 2 BLAS solve if the reciprocal of the bound on
*        elements of X is not too small.
*
         CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
      ELSE
*
*        Use a Level 1 BLAS solve, scaling intermediate results.
*
         IF( XMAX.GT.BIGNUM ) THEN
*
*           Scale X so that its components are less than or equal to
*           BIGNUM in absolute value.
*
            SCALE = BIGNUM / XMAX
            CALL DSCAL( N, SCALE, X, 1 )
            XMAX = BIGNUM
         END IF
*
         IF( NOTRAN ) THEN
*
*           Solve A * x = b
*
            DO 110 J = JFIRST, JLAST, JINC
*
*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
               XJ = ABS( X( J ) )
               IF( NOUNIT ) THEN
                  TJJS = A( J, J )*TSCAL
               ELSE
                  TJJS = TSCAL
                  IF( TSCAL.EQ.ONE )
     $               GO TO 100
               END IF
               TJJ = ABS( TJJS )
               IF( TJJ.GT.SMLNUM ) THEN
*
*                    abs(A(j,j)) > SMLNUM:
*
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                          Scale x by 1/b(j).
*
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE IF( TJJ.GT.ZERO ) THEN
*
*                    0 < abs(A(j,j)) <= SMLNUM:
*
                  IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
*                       to avoid overflow when dividing by A(j,j).
*
                     REC = ( TJJ*BIGNUM ) / XJ
                     IF( CNORM( J ).GT.ONE ) THEN
*
*                          Scale by 1/CNORM(j) to avoid overflow when
*                          multiplying x(j) times column j.
*
                        REC = REC / CNORM( J )
                     END IF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE
*
*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
*                    scale = 0, and compute a solution to A*x = 0.
*
                  DO 90 I = 1, N
                     X( I ) = ZERO
   90             CONTINUE
                  X( J ) = ONE
                  XJ = ONE
                  SCALE = ZERO
                  XMAX = ZERO
               END IF
  100          CONTINUE
*
*              Scale x if necessary to avoid overflow when adding a
*              multiple of column j of A.
*
               IF( XJ.GT.ONE ) THEN
                  REC = ONE / XJ
                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
*                    Scale x by 1/(2*abs(x(j))).
*
                     REC = REC*HALF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                  END IF
               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
*                 Scale x by 1/2.
*
                  CALL DSCAL( N, HALF, X, 1 )
                  SCALE = SCALE*HALF
               END IF
*
               IF( UPPER ) THEN
                  IF( J.GT.1 ) THEN
*
*                    Compute the update
*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
                     CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
     $                           1 )
                     I = IDAMAX( J-1, X, 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               ELSE
                  IF( J.LT.N ) THEN
*
*                    Compute the update
*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
                     CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
     $                           X( J+1 ), 1 )
                     I = J + IDAMAX( N-J, X( J+1 ), 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               END IF
  110       CONTINUE
*
         ELSE
*
*           Solve A' * x = b
*
            DO 160 J = JFIRST, JLAST, JINC
*
*              Compute x(j) = b(j) - sum A(k,j)*x(k).
*                                    k<>j
*
               XJ = ABS( X( J ) )
               USCAL = TSCAL
               REC = ONE / MAX( XMAX, ONE )
               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
*                 If x(j) could overflow, scale x by 1/(2*XMAX).
*
                  REC = REC*HALF
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.ONE ) THEN
*
*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
*
                     REC = MIN( ONE, REC*TJJ )
                     USCAL = USCAL / TJJS
                  END IF
                  IF( REC.LT.ONE ) THEN
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
               END IF
*
               SUMJ = ZERO
               IF( USCAL.EQ.ONE ) THEN
*
*                 If the scaling needed for A in the dot product is 1,
*                 call DDOT to perform the dot product.
*
                  IF( UPPER ) THEN
                     SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
                  ELSE IF( J.LT.N ) THEN
                     SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
                  END IF
               ELSE
*
*                 Otherwise, use in-line code for the dot product.
*
                  IF( UPPER ) THEN
                     DO 120 I = 1, J - 1
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  120                CONTINUE
                  ELSE IF( J.LT.N ) THEN
                     DO 130 I = J + 1, N
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  130                CONTINUE
                  END IF
               END IF
*
               IF( USCAL.EQ.TSCAL ) THEN
*
*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
*                 was not used to scale the dotproduct.
*
                  X( J ) = X( J ) - SUMJ
                  XJ = ABS( X( J ) )
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                     IF( TSCAL.EQ.ONE )
     $                  GO TO 150
                  END IF
*
*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.SMLNUM ) THEN
*
*                       abs(A(j,j)) > SMLNUM:
*
                     IF( TJJ.LT.ONE ) THEN
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                             Scale X by 1/abs(x(j)).
*
                           REC = ONE / XJ
                           CALL DSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE IF( TJJ.GT.ZERO ) THEN
*
*                       0 < abs(A(j,j)) <= SMLNUM:
*
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
                        REC = ( TJJ*BIGNUM ) / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE
*
*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
*                       scale = 0, and compute a solution to A'*x = 0.
*
                     DO 140 I = 1, N
                        X( I ) = ZERO
  140                CONTINUE
                     X( J ) = ONE
                     SCALE = ZERO
                     XMAX = ZERO
                  END IF
  150             CONTINUE
               ELSE
*
*                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
*                 product has already been divided by 1/A(j,j).
*
                  X( J ) = X( J ) / TJJS - SUMJ
               END IF
               XMAX = MAX( XMAX, ABS( X( J ) ) )
  160       CONTINUE
         END IF
         SCALE = SCALE / TSCAL
      END IF
*
*     Scale the column norms by 1/TSCAL for return.
*
      IF( TSCAL.NE.ONE ) THEN
         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
      END IF
*
      RETURN
*
*     End of DLATRS
*
      END
      SUBROUTINE DRSCL( N, SA, SX, INCX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   SX( * )
*     ..
*
*  Purpose
*  =======
*
*  DRSCL multiplies an n-element real vector x by the real scalar 1/a.
*  This is done without overflow or underflow as long as
*  the final result x/a does not overflow or underflow.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of components of the vector x.
*
*  SA      (input) DOUBLE PRECISION
*          The scalar a which is used to divide each component of x.
*          SA must be >= 0, or the subroutine will divide by zero.
*
*  SX      (input/output) DOUBLE PRECISION array, dimension
*                         (1+(N-1)*abs(INCX))
*          The n-element vector x.
*
*  INCX    (input) INTEGER
*          The increment between successive values of the vector SX.
*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
*          < 0:  SX(1) = X(n) and SX(1+(i-1)*INCX) = x(n-i+1), 1< i<= n
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, DSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
*     Get machine parameters
*
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Initialize the denominator to SA and the numerator to 1.
*
      CDEN = SA
      CNUM = ONE
*
   10 CONTINUE
      CDEN1 = CDEN*SMLNUM
      CNUM1 = CNUM / BIGNUM
      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
         MUL = SMLNUM
         DONE = .FALSE.
         CDEN = CDEN1
      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
         MUL = BIGNUM
         DONE = .FALSE.
         CNUM = CNUM1
      ELSE
*
*        Multiply X by CNUM / CDEN and return.
*
         MUL = CNUM / CDEN
         DONE = .TRUE.
      END IF
*
*     Scale the vector X by MUL
*
      CALL DSCAL( N, MUL, SX, INCX )
*
      IF( .NOT.DONE )
     $   GO TO 10
*
      RETURN
*
*     End of DRSCL
*
      END
      SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
     $                   IWORK, INFO )
*
*  -- LAPACK routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DTRCON estimates the reciprocal of the condition number of a
*  triangular matrix A, in either the 1-norm or the infinity-norm.
*
*  The norm of A is computed and an estimate is obtained for
*  norm(inv(A)), then the reciprocal of the condition number is
*  computed as
*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
*  Arguments
*  =========
*
*  NORM    (input) CHARACTER*1
*          Specifies whether the 1-norm condition number or the
*          infinity-norm condition number is required:
*          = '1' or 'O':  1-norm
*          = 'I':         Infinity-norm
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  RCOND   (output) DOUBLE PRECISION
*          The reciprocal of the condition number of the matrix A,
*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, ONENRM, UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTR
      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTR
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLACON, DLATRS, DRSCL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      NOUNIT = LSAME( DIAG, 'N' )
*
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRCON', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
*
      RCOND = ZERO
      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
*
*     Compute the norm of the triangular matrix A.
*
      ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
*
*     Continue only if ANORM > 0.
*
      IF( ANORM.GT.ZERO ) THEN
*
*        Estimate the norm of the inverse of A.
*
         AINVNM = ZERO
         NORMIN = 'N'
         IF( ONENRM ) THEN
            KASE1 = 1
         ELSE
            KASE1 = 2
         END IF
         KASE = 0
   10    CONTINUE
         CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.KASE1 ) THEN
*
*              Multiply by inv(A).
*
               CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
     $                      LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
            ELSE
*
*              Multiply by inv(A').
*
               CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
            END IF
            NORMIN = 'Y'
*
*           Multiply by 1/SCALE if doing so will not cause overflow.
*
            IF( SCALE.NE.ONE ) THEN
               IX = IDAMAX( N, WORK, 1 )
               XNORM = ABS( WORK( IX ) )
               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
     $            GO TO 20
               CALL DRSCL( N, SCALE, WORK, 1 )
            END IF
            GO TO 10
         END IF
*
*        Compute the estimate of the reciprocal condition number.
*
         IF( AINVNM.NE.ZERO )
     $      RCOND = ( ONE / ANORM ) / AINVNM
      END IF
*
   20 CONTINUE
      RETURN
*
*     End of DTRCON
*
      END
      SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
     $                   INFO )
*
*  -- LAPACK routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTRS solves a triangular system of the form
*
*     A * x = b  or  A' * x = b,
*
*  where A is a triangular matrix of order N, A' is the transpose of A,
*  and b is an N by NRHS matrix.  A check is made to verify that A is
*  nonsingular.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  TRANS   (input) CHARACTER*1
*          Specifies the operation applied to A.
*          = 'N':  Solve  A * x = b  (No transpose)
*          = 'T':  Solve  A'* x = b  (Transpose)
*          = 'C':  Solve  A'* x = b  (Conjugate transpose = Transpose)
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the right hand side vectors b for the system of
*          linear equations.
*          On exit, if INFO = 0, the solution vectors x.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, the k-th diagonal element of A is zero,
*               indicating that the matrix is singular and the solutions
*               x have not been computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DTRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Check for singularity.
*
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
      END IF
      INFO = 0
*
*     Solve A * x = b  or  A' * x = b.
*
      CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
     $            LDB )
*
      RETURN
*
*     End of DTRTRS
*
      END
c ------------------------------------------------------------------------
c SINGLE PRECISION ROUTINES
c ========================================================================
      SUBROUTINE SLABAD( SMALL, LARGE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      REAL               LARGE, SMALL
*     ..
*
*  Purpose
*  =======
*
*  SLABAD takes as input the values computed by SLAMCH for underflow and
*  overflow, and returns the square root of each of these values if the
*  log of LARGE is sufficiently large.  This subroutine is intended to
*  identify machines with a large exponent range, such as the Crays, and
*  redefine the underflow and overflow limits to be the square roots of
*  the values computed by SLAMCH.  This subroutine is needed because
*  SLAMCH does not compensate for poor arithmetic in the upper half of
*  the exponent range, as is found on a Cray.
*
*  Arguments
*  =========
*
*  SMALL   (input/output) REAL
*          On entry, the underflow threshold as computed by SLAMCH.
*          On exit, if LOG10(LARGE) is sufficiently large, the square
*          root of SMALL, otherwise unchanged.
*
*  LARGE   (input/output) REAL
*          On entry, the overflow threshold as computed by SLAMCH.
*          On exit, if LOG10(LARGE) is sufficiently large, the square
*          root of LARGE, otherwise unchanged.
*
*     .. Intrinsic Functions ..
      INTRINSIC          LOG10, SQRT
*     ..
*     .. Executable Statements ..
*
*     If it looks like we're on a Cray, take the square root of
*     SMALL and LARGE to avoid overflow and underflow problems.
*
      IF( LOG10( LARGE ).GT.2000. ) THEN
         SMALL = SQRT( SMALL )
         LARGE = SQRT( LARGE )
      END IF
*
      RETURN
*
*     End of SLABAD
*
      END
      SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            KASE, N
      REAL               EST
*     ..
*     .. Array Arguments ..
      INTEGER            ISGN( * )
      REAL               V( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  SLACON estimates the 1-norm of a square, real matrix A.
*  Reverse communication is used for evaluating matrix-vector products.
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         The order of the matrix.  N >= 1.
*
*  V      (workspace) REAL array, dimension (N)
*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
*         (W is not returned).
*
*  X      (input/output) REAL array, dimension (N)
*         On an intermediate return, X should be overwritten by
*               A * X,   if KASE=1,
*               A' * X,  if KASE=2,
*         and SLACON must be re-called with all the other parameters
*         unchanged.
*
*  ISGN   (workspace) INTEGER array, dimension (N)
*
*  EST    (output) REAL
*         An estimate (a lower bound) for norm(A).
*
*  KASE   (input/output) INTEGER
*         On the initial call to SLACON, KASE should be 0.
*         On an intermediate return, KASE will be 1 or 2, indicating
*         whether X should be overwritten by A * X  or A' * X.
*         On the final return from SLACON, KASE will again be 0.
*
*  Further Details
*  ======= =======
*
*  Contributed by Nick Higham, University of Manchester.
*  Originally named SONEST, dated March 16, 1988.
*
*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
*  a real or complex matrix, with applications to condition estimation",
*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ITER, J, JLAST, JUMP
      REAL               ALTSGN, ESTOLD, TEMP
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      REAL               SASUM
      EXTERNAL           ISAMAX, SASUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, NINT, REAL, SIGN
*     ..
*     .. Save statement ..
      SAVE
*     ..
*     .. Executable Statements ..
*
      IF( KASE.EQ.0 ) THEN
         DO 10 I = 1, N
            X( I ) = ONE / REAL( N )
   10    CONTINUE
         KASE = 1
         JUMP = 1
         RETURN
      END IF
*
      GO TO ( 20, 40, 70, 110, 140 )JUMP
*
*     ................ ENTRY   (JUMP = 1)
*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
*
   20 CONTINUE
      IF( N.EQ.1 ) THEN
         V( 1 ) = X( 1 )
         EST = ABS( V( 1 ) )
*        ... QUIT
         GO TO 150
      END IF
      EST = SASUM( N, X, 1 )
*
      DO 30 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
   30 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
*
*     ................ ENTRY   (JUMP = 2)
*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
   40 CONTINUE
      J = ISAMAX( N, X, 1 )
      ITER = 2
*
*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
   50 CONTINUE
      DO 60 I = 1, N
         X( I ) = ZERO
   60 CONTINUE
      X( J ) = ONE
      KASE = 1
      JUMP = 3
      RETURN
*
*     ................ ENTRY   (JUMP = 3)
*     X HAS BEEN OVERWRITTEN BY A*X.
*
   70 CONTINUE
      CALL SCOPY( N, X, 1, V, 1 )
      ESTOLD = EST
      EST = SASUM( N, V, 1 )
      DO 80 I = 1, N
         IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
     $      GO TO 90
   80 CONTINUE
*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
      GO TO 120
*
   90 CONTINUE
*     TEST FOR CYCLING.
      IF( EST.LE.ESTOLD )
     $   GO TO 120
*
      DO 100 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
  100 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
*
*     ................ ENTRY   (JUMP = 4)
*     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
  110 CONTINUE
      JLAST = J
      J = ISAMAX( N, X, 1 )
      IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
         ITER = ITER + 1
         GO TO 50
      END IF
*
*     ITERATION COMPLETE.  FINAL STAGE.
*
  120 CONTINUE
      ALTSGN = ONE
      DO 130 I = 1, N
         X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) )
         ALTSGN = -ALTSGN
  130 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
*
*     ................ ENTRY   (JUMP = 5)
*     X HAS BEEN OVERWRITTEN BY A*X.
*
  140 CONTINUE
      TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) )
      IF( TEMP.GT.EST ) THEN
         CALL SCOPY( N, X, 1, V, 1 )
         EST = TEMP
      END IF
*
  150 CONTINUE
      KASE = 0
      RETURN
*
*     End of SLACON
*
      END
      REAL             FUNCTION SLAMCH( CMACH )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          CMACH
*     ..
*
*  Purpose
*  =======
*
*  SLAMCH determines single precision machine parameters.
*
*  Arguments
*  =========
*
*  CMACH   (input) CHARACTER*1
*          Specifies the value to be returned by SLAMCH:
*          = 'E' or 'e',   SLAMCH := eps
*          = 'S' or 's ,   SLAMCH := sfmin
*          = 'B' or 'b',   SLAMCH := base
*          = 'P' or 'p',   SLAMCH := eps*base
*          = 'N' or 'n',   SLAMCH := t
*          = 'R' or 'r',   SLAMCH := rnd
*          = 'M' or 'm',   SLAMCH := emin
*          = 'U' or 'u',   SLAMCH := rmin
*          = 'L' or 'l',   SLAMCH := emax
*          = 'O' or 'o',   SLAMCH := rmax
*
*          where
*
*          eps   = relative machine precision
*          sfmin = safe minimum, such that 1/sfmin does not overflow
*          base  = base of the machine
*          prec  = eps*base
*          t     = number of (base) digits in the mantissa
*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*          emin  = minimum exponent before (gradual) underflow
*          rmin  = underflow threshold - base**(emin-1)
*          emax  = largest exponent before overflow
*          rmax  = overflow threshold  - (base**emax)*(1-eps)
*
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      REAL               BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
     $                   RND, SFMIN, SMALL, T
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLAMC2
*     ..
*     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
     $                   EMAX, RMAX, PREC
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
*
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
*
      SLAMCH = RMACH
      RETURN
*
*     End of SLAMCH
*
      END
*
************************************************************************
*
      SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
*     ..
*
*  Purpose
*  =======
*
*  SLAMC1 determines the machine parameters given by BETA, T, RND, and
*  IEEE1.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  IEEE1   (output) LOGICAL
*          Specifies whether rounding appears to be done in the IEEE
*          'round to nearest' style.
*
*  Further Details
*  ===============
*
*  The routine is based on the routine  ENVRON  by Malcolm and
*  incorporates suggestions by Gentleman and Marovich. See
*
*     Malcolm M. A. (1972) Algorithms to reveal properties of
*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
*        that reveal properties of floating point arithmetic units.
*        Comms. of the ACM, 17, 276-277.
*
*
*     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      REAL               A, B, C, F, ONE, QTR, SAVEC, T1, T2
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
*     ..
*     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
*
*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
*        IEEE1, T and RND.
*
*        Throughout this routine  we use the function  SLAMC3  to ensure
*        that relevant values are  stored and not held in registers,  or
*        are not affected by optimizers.
*
*        Compute  a = 2.0**m  with the  smallest positive integer m such
*        that
*
*           fl( a + 1.0 ) = a.
*
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 10
         END IF
*+       END WHILE
*
*        Now compute  b = 2.0**m  with the smallest positive integer m
*        such that
*
*           fl( a + b ) .gt. a.
*
         B = 1
         C = SLAMC3( A, B )
*
*+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = SLAMC3( A, B )
            GO TO 20
         END IF
*+       END WHILE
*
*        Now compute the base.  a and c  are neighbouring floating point
*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
*        their difference is beta. Adding 0.25 to c is to ensure that it
*        is truncated to beta and not ( beta - 1 ).
*
         QTR = ONE / 4
         SAVEC = C
         C = SLAMC3( C, -A )
         LBETA = C + QTR
*
*        Now determine whether rounding or chopping occurs,  by adding a
*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
*
         B = LBETA
         F = SLAMC3( B / 2, -B / 100 )
         C = SLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = SLAMC3( B / 2, B / 100 )
         C = SLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )
     $      LRND = .FALSE.
*
*        Try and decide whether rounding is done in the  IEEE  'round to
*        nearest' style. B/2 is half a unit in the last place of the two
*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
*        A, but adding B/2 to SAVEC should change SAVEC.
*
         T1 = SLAMC3( B / 2, A )
         T2 = SLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
*        Now find  the  mantissa, t.  It should  be the  integer part of
*        log to the base beta of a,  however it is safer to determine  t
*        by powering.  So we find t as the smallest positive integer for
*        which
*
*           fl( beta**t + 1.0 ) = 1.0.
*
         LT = 0
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 30
         END IF
*+       END WHILE
*
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
*
*     End of SLAMC1
*
      END
*
************************************************************************
*
      SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      REAL               EPS, RMAX, RMIN
*     ..
*
*  Purpose
*  =======
*
*  SLAMC2 determines the machine parameters specified in its argument
*  list.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  EPS     (output) REAL
*          The smallest positive number such that
*
*             fl( 1.0 - EPS ) .LT. 1.0,
*
*          where fl denotes the computed value.
*
*  EMIN    (output) INTEGER
*          The minimum exponent before (gradual) underflow occurs.
*
*  RMIN    (output) REAL
*          The smallest normalized number for the machine, given by
*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
*          of BETA.
*
*  EMAX    (output) INTEGER
*          The maximum exponent before overflow occurs.
*
*  RMAX    (output) REAL
*          The largest positive number for the machine, given by
*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
*          value of BETA.
*
*  Further Details
*  ===============
*
*  The computation of  EPS  is based on a routine PARANOIA by
*  W. Kahan of the University of California at Berkeley.
*
*
*     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      REAL               A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLAMC1, SLAMC4, SLAMC5
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
*
*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
*        BETA, T, RND, EPS, EMIN and RMIN.
*
*        Throughout this routine  we use the function  SLAMC3  to ensure
*        that relevant values are stored  and not held in registers,  or
*        are not affected by optimizers.
*
*        SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
*
         CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
*
*        Start to find EPS.
*
         B = LBETA
         A = B**( -LT )
         LEPS = A
*
*        Try some tricks to see whether or not this is the correct  EPS.
*
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = SLAMC3( B, -HALF )
         THIRD = SLAMC3( SIXTH, SIXTH )
         B = SLAMC3( THIRD, -HALF )
         B = SLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )
     $      B = LEPS
*
         LEPS = 1
*
*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = SLAMC3( HALF, -C )
            B = SLAMC3( HALF, C )
            C = SLAMC3( HALF, -B )
            B = SLAMC3( HALF, C )
            GO TO 10
         END IF
*+       END WHILE
*
         IF( A.LT.LEPS )
     $      LEPS = A
*
*        Computation of EPS complete.
*
*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
*        Keep dividing  A by BETA until (gradual) underflow occurs. This
*        is detected when we cannot recover the previous A.
*
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = SLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = SLAMC3( ONE, SMALL )
         CALL SLAMC4( NGPMIN, ONE, LBETA )
         CALL SLAMC4( NGNMIN, -ONE, LBETA )
         CALL SLAMC4( GPMIN, A, LBETA )
         CALL SLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
*
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
*            ( Non twos-complement machines, no gradual underflow;
*              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
*            ( Non twos-complement machines, with gradual underflow;
*              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
*            ( Twos-complement machines, no gradual underflow;
*              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
     $            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
*            ( Twos-complement machines with gradual underflow;
*              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
*         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
***
* Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
***
*
*        Assume IEEE arithmetic if we found denormalised  numbers above,
*        or if arithmetic seems to round in the  IEEE style,  determined
*        in routine SLAMC1. A true IEEE machine should have both  things
*        true; however, faulty machines may have one or the other.
*
         IEEE = IEEE .OR. LIEEE1
*
*        Compute  RMIN by successive division by  BETA. We could compute
*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
*        this computation.
*
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
*
*        Finally, call SLAMC5 to compute EMAX and RMAX.
*
         CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
*
      RETURN
*
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', I8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
*     End of SLAMC2
*
      END
*
************************************************************************
*
      REAL             FUNCTION SLAMC3( A, B )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      REAL               A, B
*     ..
*
*  Purpose
*  =======
*
*  SLAMC3  is intended to force  A  and  B  to be stored prior to doing
*  the addition of  A  and  B ,  for use in situations where optimizers
*  might hold one of these in a register.
*
*  Arguments
*  =========
*
*  A, B    (input) REAL
*          The values A and B.
*
*
*     .. Executable Statements ..
*
      SLAMC3 = A + B
*
      RETURN
*
*     End of SLAMC3
*
      END
*
************************************************************************
*
      SUBROUTINE SLAMC4( EMIN, START, BASE )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      REAL               START
*     ..
*
*  Purpose
*  =======
*
*  SLAMC4 is a service routine for SLAMC2.
*
*  Arguments
*  =========
*
*  EMIN    (output) EMIN
*          The minimum exponent before (gradual) underflow, computed by
*          setting A = START and dividing by BASE until the previous A
*          can not be recovered.
*
*  START   (input) REAL
*          The starting point for determining EMIN.
*
*  BASE    (input) INTEGER
*          The base of the machine.
*
*
*     .. Local Scalars ..
      INTEGER            I
      REAL               A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
*     ..
*     .. Executable Statements ..
*
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = SLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
     $    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = SLAMC3( A / BASE, ZERO )
         C1 = SLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = SLAMC3( A*RBASE, ZERO )
         C2 = SLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
*+    END WHILE
*
      RETURN
*
*     End of SLAMC4
*
      END
*
************************************************************************
*
      SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      REAL               RMAX
*     ..
*
*  Purpose
*  =======
*
*  SLAMC5 attempts to compute RMAX, the largest machine floating-point
*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
*  approximately to a power of 2.  It will fail on machines where this
*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
*  too large (i.e. too close to zero), probably with overflow.
*
*  Arguments
*  =========
*
*  BETA    (input) INTEGER
*          The base of floating-point arithmetic.
*
*  P       (input) INTEGER
*          The number of base BETA digits in the mantissa of a
*          floating-point value.
*
*  EMIN    (input) INTEGER
*          The minimum exponent before (gradual) underflow.
*
*  IEEE    (input) LOGICAL
*          A logical flag specifying whether or not the arithmetic
*          system is thought to comply with the IEEE standard.
*
*  EMAX    (output) INTEGER
*          The largest exponent before overflow
*
*  RMAX    (output) REAL
*          The largest machine floating-point number.
*
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      REAL               OLDY, RECBAS, Y, Z
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     First compute LEXP and UEXP, two powers of 2 that bound
*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
*     approximately to the bound that is closest to abs(EMIN).
*     (EMAX is the exponent of the required number RMAX).
*
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
*
*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
*     than or equal to EMIN. EXBITS is the number of bits needed to
*     store the exponent.
*
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
*
*     EXPSUM is the exponent range, approximately equal to
*     EMAX - EMIN + 1 .
*
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
*
*     NBITS is the total number of bits needed to store a
*     floating-point number.
*
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
*        Either there are an odd number of bits used to store a
*        floating-point number, which is unlikely, or some bits are
*        not used in the representation of numbers, which is possible,
*        (e.g. Cray machines) or the mantissa has an implicit bit,
*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*        most likely. We have to assume the last alternative.
*        If this is true, then we need to reduce EMAX by one because
*        there must be some way of representing zero in an implicit-bit
*        system. On machines like Cray, we are reducing EMAX by one
*        unnecessarily.
*
         EMAX = EMAX - 1
      END IF
*
      IF( IEEE ) THEN
*
*        Assume we are on an IEEE machine which reserves one exponent
*        for infinity and NaN.
*
         EMAX = EMAX - 1
      END IF
*
*     Now create RMAX, the largest machine number, which should
*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
*     First compute 1.0 - BETA**(-P), being careful that the
*     result is less than 1.0 .
*
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )
     $      OLDY = Y
         Y = SLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )
     $   Y = OLDY
*
*     Now multiply by BETA**EMAX to get RMAX.
*
      DO 30 I = 1, EMAX
         Y = SLAMC3( Y*BETA, ZERO )
   30 CONTINUE
*
      RMAX = Y
      RETURN
*
*     End of SLAMC5
*
      END
      REAL             FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
     $                 WORK )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SLANTR  returns the value of the one norm,  or the Frobenius norm, or
*  the  infinity norm,  or the  element of  largest absolute value  of a
*  trapezoidal or triangular matrix A.
*
*  Description
*  ===========
*
*  SLANTR returns the value
*
*     SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*              (
*              ( norm1(A),         NORM = '1', 'O' or 'o'
*              (
*              ( normI(A),         NORM = 'I' or 'i'
*              (
*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
*
*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
*
*  Arguments
*  =========
*
*  NORM    (input) CHARACTER*1
*          Specifies the value to be returned in SLANTR as described
*          above.
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower trapezoidal.
*          = 'U':  Upper trapezoidal
*          = 'L':  Lower trapezoidal
*          Note that A is triangular instead of trapezoidal if M = N.
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A has unit diagonal.
*          = 'N':  Non-unit diagonal
*          = 'U':  Unit diagonal
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0, and if
*          UPLO = 'U', M <= N.  When M = 0, SLANTR is set to zero.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0, and if
*          UPLO = 'L', N <= M.  When N = 0, SLANTR is set to zero.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The trapezoidal matrix A (A is triangular if M = N).
*          If UPLO = 'U', the leading m by n upper trapezoidal part of
*          the array A contains the upper trapezoidal matrix, and the
*          strictly lower triangular part of A is not referenced.
*          If UPLO = 'L', the leading m by n lower trapezoidal part of
*          the array A contains the lower trapezoidal matrix, and the
*          strictly upper triangular part of A is not referenced.  Note
*          that when DIAG = 'U', the diagonal elements of A are not
*          referenced and are assumed to be one.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(M,1).
*
*  WORK    (workspace) REAL array, dimension (LWORK),
*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*          referenced.
*
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UDIAG
      INTEGER            I, J
      REAL               SCALE, SUM, VALUE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASSQ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
*        Find max(abs(A(i,j))).
*
         IF( LSAME( DIAG, 'U' ) ) THEN
            VALUE = ONE
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = 1, MIN( M, J-1 )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = J + 1, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            VALUE = ZERO
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = 1, MIN( M, J )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  DO 70 I = J, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
*        Find norm1(A).
*
         VALUE = ZERO
         UDIAG = LSAME( DIAG, 'U' )
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 1, N
               IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
                  SUM = ONE
                  DO 90 I = 1, J - 1
                     SUM = SUM + ABS( A( I, J ) )
   90             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 100 I = 1, MIN( M, J )
                     SUM = SUM + ABS( A( I, J ) )
  100             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  110       CONTINUE
         ELSE
            DO 140 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 120 I = J + 1, M
                     SUM = SUM + ABS( A( I, J ) )
  120             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 130 I = J, M
                     SUM = SUM + ABS( A( I, J ) )
  130             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  140       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
*        Find normI(A).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 150 I = 1, M
                  WORK( I ) = ONE
  150          CONTINUE
               DO 170 J = 1, N
                  DO 160 I = 1, MIN( M, J-1 )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  160             CONTINUE
  170          CONTINUE
            ELSE
               DO 180 I = 1, M
                  WORK( I ) = ZERO
  180          CONTINUE
               DO 200 J = 1, N
                  DO 190 I = 1, MIN( M, J )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  190             CONTINUE
  200          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 210 I = 1, N
                  WORK( I ) = ONE
  210          CONTINUE
               DO 220 I = N + 1, M
                  WORK( I ) = ZERO
  220          CONTINUE
               DO 240 J = 1, N
                  DO 230 I = J + 1, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  230             CONTINUE
  240          CONTINUE
            ELSE
               DO 250 I = 1, M
                  WORK( I ) = ZERO
  250          CONTINUE
               DO 270 J = 1, N
                  DO 260 I = J, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  260             CONTINUE
  270          CONTINUE
            END IF
         END IF
         VALUE = ZERO
         DO 280 I = 1, M
            VALUE = MAX( VALUE, WORK( I ) )
  280    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
*        Find normF(A).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 290 J = 2, N
                  CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
  290          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 300 J = 1, N
                  CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
  300          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 310 J = 1, N
                  CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
     $                         SUM )
  310          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 320 J = 1, N
                  CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
  320          CONTINUE
            END IF
         END IF
         VALUE = SCALE*SQRT( SUM )
      END IF
*
      SLANTR = VALUE
      RETURN
*
*     End of SLANTR
*
      END
      SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      REAL               SCALE, SUMSQ
*     ..
*     .. Array Arguments ..
      REAL               X( * )
*     ..
*
*  Purpose
*  =======
*
*  SLASSQ  returns the values  scl  and  smsq  such that
*
*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
*  assumed to be non-negative and  scl  returns the value
*
*     scl = max( scale, abs( x( i ) ) ).
*
*  scale and sumsq must be supplied in SCALE and SUMSQ and
*  scl and smsq are overwritten on SCALE and SUMSQ respectively.
*
*  The routine makes only one pass through the vector x.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of elements to be used from the vector X.
*
*  X       (input) REAL
*          The vector for which a scaled sum of squares is computed.
*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
*  INCX    (input) INTEGER
*          The increment between successive values of the vector X.
*          INCX > 0.
*
*  SCALE   (input/output) REAL
*          On entry, the value  scale  in the equation above.
*          On exit, SCALE is overwritten with  scl , the scaling factor
*          for the sum of squares.
*
*  SUMSQ   (input/output) REAL
*          On entry, the value  sumsq  in the equation above.
*          On exit, SUMSQ is overwritten with  smsq , the basic sum of
*          squares from which  scl  has been factored out.
*
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IX
      REAL               ABSXI
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IF( N.GT.0 ) THEN
         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
            IF( X( IX ).NE.ZERO ) THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
*
*     End of SLASSQ
*
      END
      SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
     $                   CNORM, INFO )
*
*  -- LAPACK auxiliary routine (version 1.0a) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORMIN, TRANS, UPLO
      INTEGER            INFO, LDA, N
      REAL               SCALE
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), CNORM( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  SLATRS solves one of the triangular systems
*
*     A *x = s*b  or  A'*x = s*b
*
*  with scaling to prevent overflow.  Here A is an upper or lower
*  triangular matrix, A' denotes the transpose of A, x and b are
*  n-element vectors, and s is a scaling factor, usually less than
*  or equal to 1, chosen so that the components of x will be less than
*  the overflow threshold.  If the unscaled problem will not cause
*  overflow, the Level 2 BLAS routine STRSV is called.  If the matrix A
*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
*  non-trivial solution to A*x = 0 is returned.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  TRANS   (input) CHARACTER*1
*          Specifies the operation applied to A.
*          = 'N':  Solve A * x = s*b  (No transpose)
*          = 'T':  Solve A'* x = s*b  (Transpose)
*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  NORMIN  (input) CHARACTER*1
*          Specifies whether CNORM has been set or not.
*          = 'Y':  CNORM contains the column norms on entry
*          = 'N':  CNORM is not set on entry.  On exit, the norms will
*                  be computed and stored in CNORM.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max (1,N).
*
*  X       (input/output) REAL array, dimension (N)
*          On entry, the right hand side b of the triangular system.
*          On exit, X is overwritten by the solution vector x.
*
*  SCALE   (output) REAL
*          The scaling factor s for the triangular system
*             A * x = s*b  or  A'* x = s*b.
*          If SCALE = 0, the matrix A is singular or badly scaled, and
*          the vector x is an exact or approximate solution to A*x = 0.
*
*  CNORM   (input or output) REAL array, dimension (N)
*
*          If NORMIN = 'Y', CNORM is an input variable and CNORM(j)
*          contains the norm of the off-diagonal part of the j-th column
*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
*          must be greater than or equal to the 1-norm.
*
*          If NORMIN = 'N', CNORM is an output variable and CNORM(j)
*          returns the 1-norm of the offdiagonal part of the j-th column
*          of A.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*
*  Further Details
*  ======= =======
*
*  A rough bound on x is computed; if that is less than overflow, STRSV
*  is called, otherwise, specific code is used which checks for possible
*  overflow or divide-by-zero at every operation.
*
*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
*  if A is lower triangular is
*
*       x[1:n] := b[1:n]
*       for j = 1, ..., n
*            x(j) := x(j) / A(j,j)
*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
*       end
*
*  Define bounds on the components of x after j iterations of the loop:
*     M(j) = bound on x[1:j]
*     G(j) = bound on x[j+1:n]
*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
*  Then for iteration j+1 we have
*     M(j+1) <= G(j) / | A(j+1,j+1) |
*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
*  where CNORM(j+1) is greater than or equal to the infinity-norm of
*  column j+1 of A, not counting the diagonal.  Hence
*
*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
*                  1<=i<=j
*  and
*
*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*                                   1<=i< j
*
*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the
*  reciprocal of the largest M(j), j=1,..,n, is larger than
*  max(underflow, 1/overflow).
*
*  The bound on x(j) is also used to determine when a step in the
*  columnwise method can be performed without fear of overflow.  If
*  the computed bound is greater than a large constant, x is scaled to
*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
*  algorithm for A upper triangular is
*
*       for j = 1, ..., n
*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
*       end
*
*  We simultaneously compute two bounds
*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
*       M(j) = bound on x(i), 1<=i<=j
*
*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
*  Then the bound on x(j) is
*
*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
*                      1<=i<=j
*
*  and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater
*  than max(underflow, 1/overflow).
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
      REAL               BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SASUM, SDOT, SLAMCH
      EXTERNAL           LSAME, ISAMAX, SASUM, SDOT, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SSCAL, STRSV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Test the input parameters.
*
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $         LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
     $         LSAME( NORMIN, 'N' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLATRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Determine machine dependent parameters to control overflow.
*
      SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      SCALE = ONE
*
      IF( LSAME( NORMIN, 'N' ) ) THEN
*
*        Compute the 1-norm of each column, not including the diagonal.
*
         IF( UPPER ) THEN
*
*           A is upper triangular.
*
            DO 10 J = 1, N
               CNORM( J ) = SASUM( J-1, A( 1, J ), 1 )
   10       CONTINUE
         ELSE
*
*           A is lower triangular.
*
            DO 20 J = 1, N - 1
               CNORM( J ) = SASUM( N-J, A( J+1, J ), 1 )
   20       CONTINUE
            CNORM( N ) = ZERO
         END IF
      END IF
*
*     Scale the column norms by TSCAL if the maximum entry in CNORM is
*     greater than BIGNUM.
*
      IMAX = ISAMAX( N, CNORM, 1 )
      TMAX = CNORM( IMAX )
      IF( TMAX.LE.BIGNUM ) THEN
         TSCAL = ONE
      ELSE
         TSCAL = ONE / ( SMLNUM*TMAX )
         CALL SSCAL( N, TSCAL, CNORM, 1 )
      END IF
*
*     Compute a bound on the computed solution vector to see if the
*     Level 2 BLAS routine STRSV can be used.
*
      J = ISAMAX( N, X, 1 )
      XMAX = ABS( X( J ) )
      XBND = XMAX
      IF( NOTRAN ) THEN
*
*        Compute the growth in A * x = b.
*
         IF( UPPER ) THEN
            JFIRST = N
            JLAST = 1
            JINC = -1
         ELSE
            JFIRST = 1
            JLAST = N
            JINC = 1
         END IF
*
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 50
         END IF
*
         IF( NOUNIT ) THEN
*
*           A is non-unit triangular.
*
*           Compute GROW = 1/G(j) and XBND = 1/M(j).
*           Initially, G(0) = max{x(i), i=1,...,n}.
*
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 30 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 50
*
*              M(j) = G(j-1) / abs(A(j,j))
*
               TJJ = ABS( A( J, J ) )
               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
               ELSE
*
*                 G(j) could overflow, set GROW to 0.
*
                  GROW = ZERO
               END IF
   30       CONTINUE
            GROW = XBND
         ELSE
*
*           A is unit triangular.
*
*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 40 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 50
*
*              G(j) = G(j-1)*( 1 + CNORM(j) )
*
               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
   40       CONTINUE
         END IF
   50    CONTINUE
*
      ELSE
*
*        Compute the growth in A' * x = b.
*
         IF( UPPER ) THEN
            JFIRST = 1
            JLAST = N
            JINC = 1
         ELSE
            JFIRST = N
            JLAST = 1
            JINC = -1
         END IF
*
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 80
         END IF
*
         IF( NOUNIT ) THEN
*
*           A is non-unit triangular.
*
*           Compute GROW = 1/G(j) and XBND = 1/M(j).
*           Initially, M(0) = max{x(i), i=1,...,n}.
*
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 60 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 80
*
*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
               XJ = ONE + CNORM( J )
               GROW = MIN( GROW, XBND / XJ )
*
*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
               TJJ = ABS( A( J, J ) )
               IF( XJ.GT.TJJ )
     $            XBND = XBND*( TJJ / XJ )
   60       CONTINUE
            GROW = MIN( GROW, XBND )
         ELSE
*
*           A is unit triangular.
*
*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 70 J = JFIRST, JLAST, JINC
*
*              Exit the loop if the growth factor is too small.
*
               IF( GROW.LE.SMLNUM )
     $            GO TO 80
*
*              G(j) = ( 1 + CNORM(j) )*G(j-1)
*
               XJ = ONE + CNORM( J )
               GROW = GROW / XJ
   70       CONTINUE
         END IF
   80    CONTINUE
      END IF
*
      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
*        Use the Level 2 BLAS solve if the reciprocal of the bound on
*        elements of X is not too small.
*
         CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
      ELSE
*
*        Use a Level 1 BLAS solve, scaling intermediate results.
*
         IF( XMAX.GT.BIGNUM ) THEN
*
*           Scale X so that its components are less than or equal to
*           BIGNUM in absolute value.
*
            SCALE = BIGNUM / XMAX
            CALL SSCAL( N, SCALE, X, 1 )
            XMAX = BIGNUM
         END IF
*
         IF( NOTRAN ) THEN
*
*           Solve A * x = b
*
            DO 100 J = JFIRST, JLAST, JINC
*
*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
               XJ = ABS( X( J ) )
               IF( NOUNIT ) THEN
                  TJJS = A( J, J )*TSCAL
               ELSE
                  TJJS = TSCAL
                  IF( TSCAL.EQ.ONE )
     $               GO TO 95
               END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.SMLNUM ) THEN
*
*                    abs(A(j,j)) > SMLNUM:
*
                     IF( TJJ.LT.ONE ) THEN
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                          Scale x by 1/b(j).
*
                           REC = ONE / XJ
                           CALL SSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                     END IF
                     X( J ) = X( J ) / TJJS
                     XJ = ABS( X( J ) )
                  ELSE IF( TJJ.GT.ZERO ) THEN
*
*                    0 < abs(A(j,j)) <= SMLNUM:
*
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
*                       to avoid overflow when dividing by A(j,j).
*
                        REC = ( TJJ*BIGNUM ) / XJ
                        IF( CNORM( J ).GT.ONE ) THEN
*
*                          Scale by 1/CNORM(j) to avoid overflow when
*                          multiplying x(j) times column j.
*
                           REC = REC / CNORM( J )
                        END IF
                        CALL SSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                     X( J ) = X( J ) / TJJS
                     XJ = ABS( X( J ) )
                  ELSE
*
*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
*                    scale = 0, and compute a solution to A*x = 0.
*
                     DO 90 I = 1, N
                        X( I ) = ZERO
   90                CONTINUE
                     X( J ) = ONE
                     XJ = ONE
                     SCALE = ZERO
                     XMAX = ZERO
                  END IF
   95          CONTINUE
*
*              Scale x if necessary to avoid overflow when adding a
*              multiple of column j of A.
*
               IF( XJ.GT.ONE ) THEN
                  REC = ONE / XJ
                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
*                    Scale x by 1/(2*abs(x(j))).
*
                     REC = REC*HALF
                     CALL SSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                  END IF
               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
*                 Scale x by 1/2.
*
                  CALL SSCAL( N, HALF, X, 1 )
                  SCALE = SCALE*HALF
               END IF
*
               IF( UPPER ) THEN
                  IF( J.GT.1 ) THEN
*
*                    Compute the update
*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
                     CALL SAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
     $                           1 )
                     I = ISAMAX( J-1, X, 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               ELSE
                  IF( J.LT.N ) THEN
*
*                    Compute the update
*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
                     CALL SAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
     $                           X( J+1 ), 1 )
                     I = J + ISAMAX( N-J, X( J+1 ), 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               END IF
  100       CONTINUE
*
         ELSE
*
*           Solve A' * x = b
*
            DO 140 J = JFIRST, JLAST, JINC
*
*              Compute x(j) = b(j) - sum A(k,j)*x(k).
*                                    k<>j
*
               XJ = ABS( X( J ) )
               USCAL = TSCAL
               REC = ONE / MAX( XMAX, ONE )
               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
*                 If x(j) could overflow, scale x by 1/(2*XMAX).
*
                  REC = REC*HALF
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                  END IF
                     TJJ = ABS( TJJS )
                     IF( TJJ.GT.ONE ) THEN
*
*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
*
                        REC = MIN( ONE, REC*TJJ )
                        USCAL = USCAL / TJJS
                     END IF
                  IF( REC.LT.ONE ) THEN
                     CALL SSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
               END IF
*
               SUMJ = ZERO
               IF( USCAL.EQ.ONE ) THEN
*
*                 If the scaling needed for A in the dot product is 1,
*                 call SDOT to perform the dot product.
*
                  IF( UPPER ) THEN
                     SUMJ = SDOT( J-1, A( 1, J ), 1, X, 1 )
                  ELSE IF( J.LT.N ) THEN
                     SUMJ = SDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
                  END IF
               ELSE
*
*                 Otherwise, use in-line code for the dot product.
*
                  IF( UPPER ) THEN
                     DO 110 I = 1, J - 1
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  110                CONTINUE
                  ELSE IF( J.LT.N ) THEN
                     DO 120 I = J + 1, N
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  120                CONTINUE
                  END IF
               END IF
*
               IF( USCAL.EQ.TSCAL ) THEN
*
*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
*                 was not used to scale the dotproduct.
*
                  X( J ) = X( J ) - SUMJ
                  XJ = ABS( X( J ) )
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                     IF( TSCAL.EQ.ONE )
     $                  GO TO 135
                  END IF
*
*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
                     TJJ = ABS( TJJS )
                     IF( TJJ.GT.SMLNUM ) THEN
*
*                       abs(A(j,j)) > SMLNUM:
*
                        IF( TJJ.LT.ONE ) THEN
                           IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                             Scale X by 1/abs(x(j)).
*
                              REC = ONE / XJ
                              CALL SSCAL( N, REC, X, 1 )
                              SCALE = SCALE*REC
                              XMAX = XMAX*REC
                           END IF
                        END IF
                        X( J ) = X( J ) / TJJS
                     ELSE IF( TJJ.GT.ZERO ) THEN
*
*                       0 < abs(A(j,j)) <= SMLNUM:
*
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
*
*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
                           REC = ( TJJ*BIGNUM ) / XJ
                           CALL SSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                        X( J ) = X( J ) / TJJS
                     ELSE
*
*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
*                       scale = 0, and compute a solution to A'*x = 0.
*
                        DO 130 I = 1, N
                           X( I ) = ZERO
  130                   CONTINUE
                        X( J ) = ONE
                        SCALE = ZERO
                        XMAX = ZERO
                     END IF
  135             CONTINUE
               ELSE
*
*                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
*                 product has already been divided by 1/A(j,j).
*
                  X( J ) = X( J ) / TJJS - SUMJ
               END IF
               XMAX = MAX( XMAX, ABS( X( J ) ) )
  140       CONTINUE
         END IF
         SCALE = SCALE / TSCAL
      END IF
*
*     Scale the column norms by 1/TSCAL for return.
*
      IF( TSCAL.NE.ONE ) THEN
         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
      END IF
*
      RETURN
*
*     End of SLATRS
*
      END
      SUBROUTINE SRSCL( N, SA, SX, INCX )
*
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      REAL               SA
*     ..
*     .. Array Arguments ..
      REAL               SX( * )
*     ..
*
*  Purpose
*  =======
*
*  SRSCL multiplies an n-element real vector x by the real scalar 1/a.
*  This is done without overflow or underflow as long as
*  the final result x/a does not overflow or underflow.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of components of the vector x.
*
*  SA      (input) REAL
*          The scalar a which is used to divide each component of x.
*          SA must be >= 0, or the subroutine will divide by zero.
*
*  SX      (input/output) REAL array, dimension
*                         (1+(N-1)*abs(INCX))
*          The n-element vector x.
*
*  INCX    (input) INTEGER
*          The increment between successive values of the vector SX.
*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
*          < 0:  SX(1) = X(n) and SX(1+(i-1)*INCX) = x(n-i+1), 1< i<= n
*
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      REAL               BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLABAD, SSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
*     Get machine parameters
*
      SMLNUM = SLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
*
*     Initialize the denominator to SA and the numerator to 1.
*
      CDEN = SA
      CNUM = ONE
*
   10 CONTINUE
      CDEN1 = CDEN*SMLNUM
      CNUM1 = CNUM / BIGNUM
      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
         MUL = SMLNUM
         DONE = .FALSE.
         CDEN = CDEN1
      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
         MUL = BIGNUM
         DONE = .FALSE.
         CNUM = CNUM1
      ELSE
*
*        Multiply X by CNUM / CDEN and return.
*
         MUL = CNUM / CDEN
         DONE = .TRUE.
      END IF
*
*     Scale the vector X by MUL
*
      CALL SSCAL( N, MUL, SX, INCX )
*
      IF( .NOT.DONE )
     $   GO TO 10
*
      RETURN
*
*     End of SRSCL
*
      END
      SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
     $                   IWORK, INFO )
*
*  -- LAPACK routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            INFO, LDA, N
      REAL               RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  STRCON estimates the reciprocal of the condition number of a
*  triangular matrix A, in either the 1-norm or the infinity-norm.
*
*  The norm of A is computed and an estimate is obtained for
*  norm(inv(A)), then the reciprocal of the condition number is
*  computed as
*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
*  Arguments
*  =========
*
*  NORM    (input) CHARACTER*1
*          Specifies whether the 1-norm condition number or the
*          infinity-norm condition number is required:
*          = '1' or 'O':  1-norm
*          = 'I':         Infinity-norm
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  RCOND   (output) REAL
*          The reciprocal of the condition number of the matrix A,
*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
*  WORK    (workspace) REAL array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, ONENRM, UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SLAMCH, SLANTR
      EXTERNAL           LSAME, ISAMAX, SLAMCH, SLANTR
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLACON, SLATRS, SRSCL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, REAL
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      NOUNIT = LSAME( DIAG, 'N' )
*
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STRCON', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
*
      RCOND = ZERO
      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
*
*     Compute the norm of the triangular matrix A.
*
      ANORM = SLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
*
*     Continue only if ANORM > 0.
*
      IF( ANORM.GT.ZERO ) THEN
*
*        Estimate the norm of the inverse of A.
*
         AINVNM = ZERO
         NORMIN = 'N'
         IF( ONENRM ) THEN
            KASE1 = 1
         ELSE
            KASE1 = 2
         END IF
         KASE = 0
   10    CONTINUE
         CALL SLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.KASE1 ) THEN
*
*              Multiply by inv(A).
*
               CALL SLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
     $                      LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
            ELSE
*
*              Multiply by inv(A').
*
               CALL SLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
            END IF
            NORMIN = 'Y'
*
*           Multiply by 1/SCALE if doing so will not cause overflow.
*
            IF( SCALE.NE.ONE ) THEN
               IX = ISAMAX( N, WORK, 1 )
               XNORM = ABS( WORK( IX ) )
               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
     $            GO TO 20
               CALL SRSCL( N, SCALE, WORK, 1 )
            END IF
            GO TO 10
         END IF
*
*        Compute the estimate of the reciprocal condition number.
*
         IF( AINVNM.NE.ZERO )
     $      RCOND = ( ONE / ANORM ) / AINVNM
      END IF
*
   20 CONTINUE
      RETURN
*
*     End of STRCON
*
      END
      SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
     $                   INFO )
*
*  -- LAPACK routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  STRTRS solves a triangular system of the form
*
*     A * x = b  or  A' * x = b,
*
*  where A is a triangular matrix of order N, A' is the transpose of A,
*  and b is an N by NRHS matrix.  A check is made to verify that A is
*  nonsingular.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  TRANS   (input) CHARACTER*1
*          Specifies the operation applied to A.
*          = 'N':  Solve  A * x = b  (No transpose)
*          = 'T':  Solve  A'* x = b  (Transpose)
*          = 'C':  Solve  A'* x = b  (Conjugate transpose = Transpose)
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The triangular matrix A.  If UPLO = 'U', the leading n by n
*          upper triangular part of the array A contains the upper
*          triangular matrix, and the strictly lower triangular part of
*          A is not referenced.  If UPLO = 'L', the leading n by n lower
*          triangular part of the array A contains the lower triangular
*          matrix, and the strictly upper triangular part of A is not
*          referenced.  If DIAG = 'U', the diagonal elements of A are
*          also not referenced and are assumed to be 1.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  B       (input/output) REAL array, dimension (LDB,NRHS)
*          On entry, the right hand side vectors b for the system of
*          linear equations.
*          On exit, if INFO = 0, the solution vectors x.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, the k-th diagonal element of A is zero,
*               indicating that the matrix is singular and the solutions
*               x have not been computed.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           STRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STRTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Check for singularity.
*
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
      END IF
      INFO = 0
*
*     Solve A * x = b  or  A' * x = b.
*
      CALL STRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
     $            LDB )
*
      RETURN
*
*     End of STRTRS
*
      END
C*** makefile
#
# FILE: Makefile
#
CFLAGS= -c -C
GFLAGS= -g
LIBS= -llapack -lblas

OFILES1= ddemo.o
OFILES2= dmevas.o dstair.o

OFILES3= smevas.o sstair.o
OFILES4= sdemo.o

OFILES5= blas.o lapack.o eispk.o
#
#
all : ddemo.log sdemo.log

ddemo.log : ddemo
	sh < ddemo.sh

sdemo.log : sdemo
	sh < sdemo.sh
#
#
ddemo:   $(OFILES1) $(OFILES2) $(OFILES5)
	f77 $(GFLAGS) $(OFILES1) $(OFILES2) $(OFILES5) -o ddemo.x
ddemo.o:
	f77 $(CFLAGS) ddemo.f
dmevas.o:
	f77 $(CFLAGS) dmevas.f
dstair.o:
	f77 $(CFLAGS) dstair.f
blas.o:
	f77 $(CFLAGS) blas.f
lapack.o:
	f77 $(CFLAGS) lapack.f
eispk.o:
	f77 $(CFLAGS) eispk.f
#
#
sdemo:   $(OFILES3) $(OFILES4) $(OFILES5)
	f77 $(GFLAGS) $(OFILES3) $(OFILES4) $(OFILES5) -o sdemo.x
sdemo.o:
	f77 $(CFLAGS) sdemo.f
sstair.o:
	f77 $(CFLAGS) sstair.f
smevas.o:
	f77 $(CFLAGS) smevas.f
#
#
clean :
	rm -f core *.o *.x *.log
C*** readme
#
# FILE: README
#
This directory contains files of:

1.  Fortran source code for the eigenvalue assignment subroutines:
      dmevas  (double precision)  in file  dmevas.f
      smevas  (single precision)  in file  smevas.f
    These files also contain supporting subroutines. 

2.  Fortran source code for the staircase reduction and back 
    transformation subroutines:
      dstair, dbktrn  (double precision)  in file  dstair.f
      sstair, sbktrn  (single precision)  in file  sstair.f

3.  Fortran source code for those routines used from the BLAS,
    LAPACK and EISPACK libraries, in the files blas.f, lapack.f,
    and eispk.f, respectively.  The routines from EISPACK are
    used only in the demonstration programs (see below).

4.  Fortran source code for the demonstration programs in files:
      ddemo.f  (double precision)
      sdemo.f  (single precision)
    The demonstration program _demo calls the user callable routines
    _stair, _mevas, and _bktrn  before computing the eigenvalues of
    the closed loop matrix (A-B*F).  The computed eigenvalues may then
    be compared with the given eigenvalues, bearing in mind that the
    eigenproblem need not be well conditioned.

5.  A  Makefile (for UNIX users) to create executables as follows:
      < make ddemo >  creates double precision executable  ddemo.x
      < make sdemo >  creates single precision executable  sdemo.x
      < make > will also create the double precision executable ddemo.x

    Non-UNIX users should compile and link:
      For the double precision demonstration program:
          ddemo.f, dmevas.f, dstair.f, lapack.f, blas.f eispk.f
      For the single precision demonstration program: 
          sdemo.f, smevas.f, sstair.f, lapack.f, blas.f eispk.f

6.  A suite of test data files:
      test*.dat     (* = 01, 02, ..., 20)
    These are to be used by the demonstration programs.  The test data 
    are designed to execute the major branches of the eigenvalue assignment
    routines. The resulting closed loop matrices are not necessarily well
    conditioned with respect to the eigenvalue problem.  In single precision
    there may then be discrepancies between the allocated eigenvalues and the
    eigenvalues computed from the closed loop matrix, but this should not be
    construed as a problem with the algorithm or with the subroutine. Direct
    comparison of the computed  F  matrices in single and double precision
    should remove any lingering doubts. Brief comments on each test can be
    found in the file test.doc.

7.  Command files  *.sh  of UNIX shell scripts to run each executable:
      ddemo.sh  runs  ddemo.x  with input  test*.dat, (*=01,...,20)
                                  output is directed to file  ddemo.log
      sdemo.sh  runs  sdemo.x  with input  test*.dat, (*=01,...,20)
                                  output is directed to file  sdemo.log

8.  Logs of the output from the demonstration programs run with the above
    shell scripts and data files on an HP 9000/720 computer:
      dlog.ref contains the double precision output.
      slog.ref contains the single precision output.
C*** sdemo.f
c
c FILE: sdemo.f
c
c==== ============================================================
c
        program sdemo
c
c       This program reads in data, calls staircase subroutine DSTAIR
c       if necessary, calls pole placement subroutine DMEVAS, and
c       calls back transformation routine DBKTRN if DSTAIR was called.
c       Computes eigenvalues of closed loop, and writes results.
c
c       .. Parameters ..
c       implicit none
        integer          Nin, Nout
        parameter        (Nin = 5, Nout = 6)
        integer          Nmax, Mmax
        parameter        (Nmax = 40, Mmax = 40)
        integer          lda, ldb, ldf
        parameter        (lda=Nmax, ldb=Nmax, ldf=Mmax)
c       .... for upper bounds on Givens and Householder transformations
c            with N in {1,..,Nmax} and M in {1,..,min(N,Mmax)} 
c                the expressions for gmax and hmax yield
c                greatest gmax = 211 when N=40, M=20
c                greatest hmax = 401 when N=40, M=1
        integer          gmax
        parameter        (gmax = 211)
        integer          hmax
        parameter        (hmax = 401)
c       .... and for the work space bounds
        integer          liwork
c
c       Parameter liwork should normaly be declared as
c
c        parameter        (liwork = max(4*Nmax, Nmax+Nmax/2+gmax+hmax))
c
c       Microsoft's FORTRAN 5.00 compiler however reports a parameter
c       error that seems to be coming from the use of max. We have therefore
c       replace the declaration with the one below which is fine so far
c       as the  test*.dat  are concerned. All UNIX based FORTRAN 
c       compilers had no problem with the above declaration.
c
        parameter        (liwork = Nmax + Nmax/2 + gmax + hmax)
        integer          lrwork
        parameter        (lrwork = 3*Nmax + 2*gmax + 3*hmax)
c
c       .. Local Scalars ..
        real tol
        integer          n, m, kmax, ncmplx, iwarn, ierr, i, j
        character*20     header
c
c       .. Local Arrays ..
        real             A(lda,Nmax), B(ldb,Mmax), F(ldf,Nmax)
        real             eigs(Nmax), rwork(lrwork)
        integer          kstair(Nmax+1), info(2), iwork(liwork)
        integer          itrnsf(nmax*(mmax+1)/2 + mmax+2*nmax+3)
        real             rtrnsf(nmax*(mmax+1)/2 + nmax*(nmax+1)/2)
        double precision AA(lda,Nmax), BB(ldb,Mmax), FF(ldf,Nmax)
        double precision reigs(Nmax), imeigs(Nmax), dwork(Nmax)
c
c       .. External Subroutines ..      
        external smevas, lpeigs
c
c       .. Executable Statements ..
c
c       .. read the headings in the data file
c       .. echo the second heading
        read (Nin,FMT=99990) header
        read (Nin,FMT=99990) header
        write (Nout,FMT=99999)
        write (Nout,FMT=99990) header
c
c       .. read the data ..
        read (Nin,FMT=*) n, m, tol
        if (n.le.0 .or. n.gt.Nmax) then
           write (Nout,FMT=99998) n
        else
           read (Nin,FMT=*) (( A(i,j), j=1,n), i=1,n)
           if (m.le.0 .or. m.gt.Mmax) then
              write (Nout,FMT=99997) m
           else
              read (Nin,FMT=*) (( B(i,j), j=1,m), i=1,n)
              read (Nin,FMT=*) ( eigs(i), i=1,n )
              read (Nin,FMT=*) ncmplx 
c
c             .. make double precision copies of A,B so we can compute
c                eigenvalues of closed loop in double precision
c             .. copy A to AA ..
              do 100 j = 1, n
                  call s2dcpy(n, A(1,j), 1, AA(1,j), 1)
  100         continue
c             .. copy B to BB ..
              do 120 j = 1, m
                  call s2dcpy(n, B(1,j), 1, BB(1,j), 1)
  120         continue
c
c             .. echo the eigenvalues to be allocated
              write(Nout,FMT=80058)
              do 150 i = 1, ncmplx, 2
                  write(Nout,FMT=80054) EIGS(i),EIGS(i+1)           
                  write(Nout,FMT=80055) EIGS(i),EIGS(i+1)           
  150         continue
              do 170 i = ncmplx+1, n
                  write(Nout,FMT=80056) EIGS(I)
  170         continue
c
c             ..compute the staircase form and the ranks of the
c               staircase blocks..
              call sstair(n,m,A,lda,B,ldb, kmax, kstair, itrnsf,
     &                    rtrnsf, iwork, rwork, tol, iwarn, ierr)
c
              if(ierr .lt. 0) then
                 write(Nout,FMT=80000) -ierr
              else
                 if (iwarn .ne. 0) then
                    write (Nout,FMT=80020) iwarn
                 end if
c
c                .. allocate the eigenvalues ..
                 call smevas (n,m, ncmplx, gmax, hmax, A, lda,
     &                          B,ldb, F,ldf, eigs, kmax, kstair,
     &                          info, iwork, rwork, tol, iwarn, ierr)
c
                 write (Nout,FMT='()')
                 if (ierr .lt. 0) then
                    write(Nout,FMT=80000) -ierr
                 else
c                   .. print results ..
                    if (iwarn .ne. 0) then
                       write (Nout,FMT=80020) iwarn
                    end if
                    if (ierr .ne. 0) then
                       write(Nout,FMT=80010) ierr
                    end if
                    write (Nout,FMT=80030) tol
                    if (info(2) .ne. n) then
                       write (Nout,FMT=80040)
                       write (Nout,FMT=80041) info(2)
                    end if
                    if (info(1) .ne. n) then
                       write (Nout,FMT=80050) n, info(1)
c                      .. print UNallocated eigenvalues ..
                       write (Nout,FMT=80052)
                       do 200 i=info(1)+1,info(1)+ncmplx,2
                          write(Nout,FMT=80054) EIGS(i),EIGS(i+1)           
                          write(Nout,FMT=80055) EIGS(i),EIGS(i+1)           
  200                  continue
                       do 220 i = info(1)+1+ncmplx, n
                          write(Nout,FMT=80056) EIGS(I)
  220                  continue
                    end if
c
c                   ..do the back transform on F1
                    call sbktrn(n,m,F,ldf,itrnsf,rtrnsf,rwork,ierr)
c
c                   .. before printing F compute and print eigenvalues
c                         of the closed loop ..
c                   .. to compute eigenvalues in double precision we need
c                      a double precision copy of F
c                   .. copy matrix F1 in array F to array FF ..
                    do 300 j = 1, n
                        call s2dcpy(m, F(1,j), 1, FF(1,j), 1)
  300                continue
c                   .. compute the closed loop and its eigenvalues ..
c                   ! lpeigs will overwrite AA
                    call lpeigs(n,m, AA,lda, BB, ldb, FF,ldf,
     &                             reigs, imeigs, iwork, dwork)
c
c                   .. print computed eigenvalues of closed loop ..
c                   .. imaginary parts with magnitude < tol are set to zero ..
                    write (Nout,FMT=80060)
                    DO 400 i=1,n
                        if ( abs(imeigs(i)) .LE. tol ) then
                           write(Nout,FMT=80056) reigs(i)
                        else if ( imeigs(i) .GE. 0.0 ) then
                           write(Nout,FMT=80054) reigs(i),imeigs(i)           
                        else
                           write(Nout,FMT=80055) reigs(i),-imeigs(i)
                        endif
  400               continue
c
c                   .. print computed F ..
                    write (Nout,FMT='()')
                    write (Nout,FMT=80080)
                    DO 500 i = 1, m
                        write(Nout,FMT=88888) (F(i,j), j=1,n)
  500               continue
c
                 end if
              end if
           end if
        end if
c
80000   FORMAT (' ERROR: error on ENTRY with argument ', I2)
80010   FORMAT (' ERROR: on EXIT ierr  = ', I2)
80020   FORMAT (' WARNING: on exit iwarn = ', I1)
80030   FORMAT (' tolerance used = ', E16.8)
80040   FORMAT (' eigenvalue stored at EIGS(N) on entry')
80041   FORMAT ('   now stored at EIGS(', I2, ')')
80050   FORMAT (' of', I3, ' eigenvalues, the number allocated = ', I2)
80052   FORMAT (' the following eigenvalues were NOT allocated')
80054   FORMAT (F8.4, '  +  i*', F8.4)
80055   FORMAT (F8.4, '  -  i*', F8.4)
80056   FORMAT (F8.4)
80058   FORMAT (' the eigenvalues to be allocated are:')
80060   FORMAT (' the eigenvalues of the closed loop are:')
80080   FORMAT (' computed gain matrix F:')
88888   FORMAT (20(1x,F9.4))
99990   FORMAT (A20)
99996   FORMAT (' kmax is out of range: kmax = ', I2)
99997   FORMAT (' m is out of range: m = ', I2)
99998   FORMAT (' n is out of range: n = ', I2)
99999   FORMAT (' Demonstration Program Results')
c
        stop
        end
c
c===================================================================
c===================================================================
c
        subroutine lpeigs(n, m, A,lda, B,ldb, F,ldf, reig, imeig,
     &                    iwork, rwork)
c
c    Purpose
c    =======
c    To call routines to compute A-BF and the eigenvalues of A-BF.
c
c    Arguments
c    =========

c    Arguments In
c    ------------
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           column dimension of matrix F.
c
c    M      INTEGER.
c           Column dimension of matrix B,
c           row dimension of matrix F.
c
c    A      DOUBLE PRECISION array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the matrix A.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      DOUBLE PRECISION array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the matrix B.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c    F      DOUBLE PRECISION array of DIMENSION (LDF,N).
c           The leading M by N part of this array must contain the matrix F.
c
c    LDF    INTEGER.
c           Row dimension of array F, as declared in the calling program
c           LDB .ge. M.
c
c    Arguments Out
c    -------------
c    REIG   DOUBLE PRECISION array of DIMENSION(N).
c           Contains the real parts of the computed eigenvalues.
c
c    IMEIG  DOUBLE PRECISION array of DIMENSION(N).
c           Contains the imaginary parts of the computed eigenvalues.
c
c    Workspace
c    ---------
c    IWORK  INTEGER array of DIMENSION(N).
c
c    RWORK  DOUBLE PRECISION array of DIMENSION(N).
c
c    Tolerances
c    ----------
c    None.
c
c    Mode Parameters
c    ---------------
c    None.
c    
c    Warning Indicator
c    -----------------
c    None.
c
c    Error Indicator
c    ---------------
c    None.
c
c    Warnings and Errors Detected by the Routine
c    ===========================================
c    None
c
c    Method
c    ======
c    Uses BLAS routine DGEMM to compute B-AF.
c    Subsequent calls to EISPACK routines BALANC, ELMHES, HQR 
c    balance the matrix, reduce it to upper hessenberg form, and
c    compute the eigenvalues via the QR algorithm.
c
c    References
c    ==========
c    1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, Chapter 7.  
c    
c    2. Press, W.H. et al, Numerical Recipes, Cambridge University Press,
c       1986, pp.365-376
c
c
c    Revisions
c    =========
c    1994 Feb 03
c
c    arguments
c       implicit none
        integer n, m, lda, ldb, ldf, iwork(*)
        double precision A(lda,*), B(ldb,*), F(ldf,*)
        double precision reig(*), imeig(*), rwork(*)
c
c    parameters
        character*1 Tran
        parameter(Tran='n')
c
c    local variables
        integer low,igh,ierr
c
c       ..compute closed loop A-B*F and store in A
        call dgemm(Tran,Tran, n,n,m, -1.0d0, B,ldb, F,ldf, 1.0d0, A,lda)
c
c       ..compute eigenvalues of the closed loop (stored in A)
        call balanc( lda, n, A, low, igh, rwork)
        call elmhes( lda, n, low, igh, A, iwork)
        call hqr( lda, n, low, igh, A, reig, imeig, ierr)
c
        return
        end
c
c===================================================================
c===================================================================
c
        subroutine s2dcpy(n, sx, incx, dy, incy)
c
c    Purpose
c    =======
c    To copy single precision vector x to double precision vector y.
c
c    Arguments
c    =========
c    Arguments In
c    ------------
c    N      INTEGER.
c           Dimension of SX, the vector to be copied.
c
c    SX     DOUBLE PRECISION array of DIMENSION (N).
c
c    INCX   INTEGER.
c           The stride for the array SX
c
c    INCY   INTEGER.
c           The stride for the array DY
c
c    Arguments Out
c    -------------
c    DY     DOUBLE PRECISION array of DIMENSION (N).
c
c    Workspace
c    ---------
c    None
c
c    Tolerances
c    ----------
c    None.
c
c    Mode Parameters
c    ---------------
c    None.
c    
c    Warning Indicator
c    -----------------
c    None.
c
c    Error Indicator
c    ---------------
c    None.
c
c    Warnings and Errors Detected by the Routine
c    ===========================================
c    None
c
c    Method
c    ======
c    Modification of BLAS routine DCOPY.
c
c
c    Revisions
c    =========
c    1994 Feb 03
c
c    arguments
c       implicit none
        integer          n, incx, incy
        real             sx(*)
        double precision dy(*)
c
c    local variables
        integer i,ix,iy,m,mp1
c
c    remainder of this subroutine is mildly modified
c    copy of BLAS routine DCOPY. [jack dongarra, linpack, 3/11/78.]
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dble(sx(ix))
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dble(sx(i))
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dble(sx(i))
        dy(i + 1) = dble(sx(i + 1))
        dy(i + 2) = dble(sx(i + 2))
        dy(i + 3) = dble(sx(i + 3))
        dy(i + 4) = dble(sx(i + 4))
        dy(i + 5) = dble(sx(i + 5))
        dy(i + 6) = dble(sx(i + 6))
   50 continue
      return
      end
C*** sdemo.sh
# FILE: sdemo.sh
#
#!/bin/sh
rm -f sdemo.log
for i in test*.dat
	do echo $i
	   sdemo.x < $i >> sdemo.log
done
C*** slog.ref
FILE:  slog.ref

 Demonstration Program Results
   test01           
 the eigenvalues to be allocated are:
   .9544  +  i*   .8513
   .9544  -  i*   .8513
   .2893  +  i*   .5374
   .2893  -  i*   .5374
   .5144  +  i*   .1034
   .5144  -  i*   .1034
   .4140
   .5767
   .8766
   .4400
   .7297

 tolerance used =    .52990913E-06
 eigenvalue stored at EIGS(N) on entry
   now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .9544  +  i*   .8513
   .9544  -  i*   .8513
   .2893  +  i*   .5374
   .2893  -  i*   .5374
   .8766
   .5147  +  i*   .1022
   .5147  -  i*   .1022
   .5732
   .4449
   .4118
   .7301

 computed gain matrix F:
    1.2366    -.0621   -1.1794     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .6030    -.1087    1.2359     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.1042    -.8806    -.3792     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.1902     .6348    -.5265     .1831    -.4240     .1296    -.3876     .2118     .1149     .0152     .0374 
     .5347    -.3346     .1998    -.0448    1.3815    -.1915    1.2044    -.1380    -.4250     .0377    -.0325 
     .1073    -.3782     .1560     .0393     .3933    -.8726     .6780    -.6574    -.6013    -.0181    -.1687 
     .1528    -.0455    -.4707     .0090     .5769     .3959    -.2292     .1545     .2531    -.2305    -.6368 
 Demonstration Program Results
   test02           
 the eigenvalues to be allocated are:
   .1312  +  i*   .8856
   .1312  -  i*   .8856
   .0922  +  i*   .1622
   .0922  -  i*   .1622
   .0711  +  i*   .3653
   .0711  -  i*   .3653
   .2531
   .1351
   .7832
   .4553
   .3495

 tolerance used =    .56962710E-06
 eigenvalue stored at EIGS(N) on entry
   now stored at EIGS( 5)
 the eigenvalues of the closed loop are:
   .1312  +  i*   .8856
   .1312  -  i*   .8856
   .7832
   .0711  +  i*   .3654
   .0711  -  i*   .3654
   .4551
   .0920  +  i*   .1620
   .0920  -  i*   .1620
   .3503
   .2519
   .1360

 computed gain matrix F:
     .1001    1.2141    -.0967     .0711    5.0344     .0000     .0000     .0000     .0000     .0000     .0000 
    -.4456     .3309    -.9465    -.4678     .0858   -1.3265     .5564    -.6209    -.0797    -.2924     .2009 
   -1.1914   -1.3564    2.8527    1.5547    1.6460    2.1313   -1.7744    1.2853    -.1253     .7265    -.4825 
     .6008    -.3938    -.2453   -1.5008    -.2922    -.2535     .2332    -.0025     .0174     .0085    -.2005 
 Demonstration Program Results
   test03           
 the eigenvalues to be allocated are:
   .7297  +  i*   .8693
   .7297  -  i*   .8693
   .7156  +  i*   .8007
   .7156  -  i*   .8007
   .7065  +  i*   .7417
   .7065  -  i*   .7417
   .0191
   .8860
   .5250
   .4633
   .0652
   .7134
   .4889

 tolerance used =    .61202104E-06
 the eigenvalues of the closed loop are:
   .7299  +  i*   .8719
   .7299  -  i*   .8719
   .7134  +  i*   .7927
   .7134  -  i*   .7927
   .7090  +  i*   .7471
   .7090  -  i*   .7471
   .0190
   .8910
   .0653
   .6971
   .5541
   .4668  +  i*   .0169
   .4668  -  i*   .0169

 computed gain matrix F:
    3.8000    2.6996    1.8115  -12.1405   -1.2960  -12.3325   35.2843  -12.7917  -12.3098    6.7445  -46.2238     .0000     .0000 
    -.1299    2.2954    1.3242   -2.0195   -1.3181   -7.1153   12.0254   -6.3949   -5.2201     .1471  -22.7628     .0000     .0000 
     .1054     .7980    -.7706     .1107     .1728     .7289    -.1496     .0750     .0050     .5155    -.1578     .0200    -.1811 
 Demonstration Program Results
   test04           
 the eigenvalues to be allocated are:
   .1236  +  i*   .9733
   .1236  -  i*   .9733
   .0296
   .0804
   .4942
   .7694
   .9340
   .2502
   .3597
   .7691
   .5000
   .7492
   .6719
   .6817
   .7568
   .0364
   .2306
   .2217
   .5626

 tolerance used =    .10489802E-05
 eigenvalue stored at EIGS(N) on entry
   now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .1236  +  i*   .9733
   .1236  -  i*   .9733
   .0152
   .0606  +  i*   .0264
   .0606  -  i*   .0264
   .2268  +  i*   .0664
   .2268  -  i*   .0664
   .9339
   .2166
   .4509  +  i*   .1263
   .4509  -  i*   .1263
   .3692
   .8413
   .8025  +  i*   .0836
   .8025  -  i*   .0836
   .6667  +  i*   .1327
   .6667  -  i*   .1327
   .6734
   .6329

 computed gain matrix F:
     .6844    -.7049    -.8840     .0815     .4088     .2177    -.9352     .6891     .3737    -.0426     .1916     .1751    -.5344     .3431    -.3536    -.0610     .1607     .0000     .0000 
     .5377   -1.2897    -.3693    -.0620   -1.1130     .6192    -.8361   -1.4656    1.1668   -1.0074    -.5434     .1141    -.8746     .4087   -1.5800    -.3427    -.2769     .0000     .0000 
    -.3414    -.1132   -1.1144   -1.0554   -1.0811     .8136     .9407    -.4220    1.7581     .6850     .9596     .4047     .0269   -1.2368   -1.1616     .8826    -.0732     .0000     .0000 
    -.2265    -.0043    -.2213   -1.1224     .3588    -.2094     .4005     .2942     .3240     .0002    -.2662    -.2661     .6789     .0902     .2643     .0241    -.1756     .0000     .0000 
     .2899    -.0107     .0301     .1390     .4738    -.7477     .6664     .2663     .5584     .8707    -.7539    -.1938     .2546     .1765     .4003     .2046    -.0310     .0000     .0000 
     .1126    -.0106     .1036     .4032     .6697    -.8356     .0606     .0181    -.2327     .3014    -.2265     .1679    -.1145     .0397     .0835     .0852    -.1335    -.0229     .1828 
 Demonstration Program Results
   test05           
 the eigenvalues to be allocated are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .1783
   .1537
   .5717
   .8024
   .0331
   .5344

 tolerance used =    .37048642E-06
 the eigenvalues of the closed loop are:
   .0331
   .1536
   .1785
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .8024
   .5716
   .5345

 computed gain matrix F:
    -.3808    -.3672    -.9907   -2.1210    3.0556   -1.1266    -.2946   -1.3675 
     .0657    1.5508    -.9710    -.4255    8.9037   -3.4898     .0508     .2359 
     .3084     .3142     .3307    1.2718     .4935   -1.1860     .2385    1.1073 
    -.8329    -.1707    -.6103     .2794    -.0432     .0798    -.4747    -.6511 
 Demonstration Program Results
   test06           
 the eigenvalues to be allocated are:
   .6216  +  i*   .8031
   .6216  -  i*   .8031
   .2478
   .4764
   .3893
   .2033
   .0284
   .9017
   .4265

 tolerance used =    .47300489E-06
 eigenvalue stored at EIGS(N) on entry
   now stored at EIGS( 7)
 the eigenvalues of the closed loop are:
   .6216  +  i*   .8031
   .6216  -  i*   .8031
   .2478
   .4764
   .3893
   .4265
   .2032
   .9017
   .0284

 computed gain matrix F:
   -2.5724     .6769   -1.2574     .3528    -.4997    -.9656    1.1845     .0000     .0000 
    -.2849    -.5452   -1.2494     .1274    -.5668    -.6412    -.3376     .0000     .0000 
    1.9985     .1808    1.2753     .5530    -.1198    -.8179    1.8712     .0000     .0000 
    -.6681   -1.0619    -.6613     .0059    -.1181     .3824    -.7930     .0000     .0000 
   -1.3325   -1.0313   -1.1417    -.1453    -.6545    -.2722     .0440     .0000     .0000 
    1.9865     .9305    -.2219     .2053    -.6571   -1.4549    1.0235     .0000     .0000 
     .2828    -.3858     .4358     .0333    -.4449     .3022    -.1848     .0000     .0000 
     .0465    -.0552     .7267     .2009    -.3151     .0733     .5488    -.0808    -.6580 
 Demonstration Program Results
   test07           
 the eigenvalues to be allocated are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .1783  +  i*   .1537
   .1783  -  i*   .1537
   .5717
   .8024
   .0331
   .5344

 tolerance used =    .37724732E-06
 the eigenvalues of the closed loop are:
   .4679  +  i*   .2872
   .4679  -  i*   .2872
   .0331
   .1783  +  i*   .1537
   .1783  -  i*   .1537
   .5716
   .5345
   .8024

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .8879     .1303     .1784    -.5409     .0000     .0000     .0000     .0000 
     .6435    1.7507   -2.2184     .2100    1.3477   -6.4379   -2.4985  -23.3845 
     .0380    -.0819    2.0681    -.0602   -2.0816    7.7146    2.8935   26.6307 
 Demonstration Program Results
   test08           
 the eigenvalues to be allocated are:
   .5045  +  i*   .5163
   .5045  -  i*   .5163
   .3190
   .9866
   .4940
   .2661
   .0907

 tolerance used =    .26494263E-06
 the eigenvalues of the closed loop are:
   .9866
   .5045  +  i*   .5163
   .5045  -  i*   .5163
   .4940
   .0907
   .3190
   .2661

 computed gain matrix F:
     .2489   -2.3904    3.2020    -.0094    -.9292    1.9323     .0990 
 Demonstration Program Results
   test09           
 the eigenvalues to be allocated are:
   .3888  +  i*   .9522
   .3888  -  i*   .9522
   .9475  +  i*   .3898
   .9475  -  i*   .3898
   .2692  +  i*   .6922
   .2692  -  i*   .6922
   .2840
   .7769

 tolerance used =    .41927217E-06
 the eigenvalues of the closed loop are:
   .3888  +  i*   .9522
   .3888  -  i*   .9522
   .2692  +  i*   .6922
   .2692  -  i*   .6922
   .9475  +  i*   .3898
   .9475  -  i*   .3898
   .7769
   .2840

 computed gain matrix F:
     .3892     .0044     .5935   -1.0112    -.9976    -.1775     .3247   -1.2121 
   -1.4578     .0233     .2380     .5325     .8624    -.5668    -.1984    -.2923 
    -.6029    -.7545   -2.1290     .0062    1.1338    -.0397    -.7087    2.4381 
     .1572    -.1593    -.5716    1.6414     .6629    -.1088    -.1790    1.1188 
     .3124    -.2093    1.4273    -.8024    -.4689     .7710     .0748   -1.4526 
     .2782     .2652    1.8953    -.1284   -2.0392     .1586    -.0217   -1.6027 
    -.8854     .6067    -.7371     .3861     .3295    -.4005     .7691     .8716 
    -.7646    -.2133   -1.9246     .0416     .0268     .0591    -.3556    2.0463 
 Demonstration Program Results
   test10           
 the eigenvalues to be allocated are:
   .8287  +  i*   .0945
   .8287  -  i*   .0945
   .0817  +  i*   .7640
   .0817  -  i*   .7640
   .6296  +  i*   .2139
   .6296  -  i*   .2139
   .2136
   .0811

 tolerance used =    .40197966E-06
 the eigenvalues of the closed loop are:
   .0817  +  i*   .7640
   .0817  -  i*   .7640
   .8287  +  i*   .0945
   .8287  -  i*   .0945
   .6296  +  i*   .2139
   .6296  -  i*   .2139
   .0811
   .2136

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
    -.0992     .7753    1.2865    1.2901     .0150    -.5475     .0000     .0000 
     .1659    -.4842     .6537    -.0132    -.1184    -.0933     .0000     .0000 
     .3834    -.3197     .2206     .2743     .1338     .1617     .0000     .0000 
     .2288    -.0223    -.0122    -.4309     .6747     .5071     .0000     .0000 
     .1007    -.2591     .0032    -.7122    -.4544     .2169     .0000     .0000 
     .2359     .2166    -.0051    -.2988     .1992    -.7912     .0000     .0000 
    -.3387    -.2734    -.0615     .3452    -.1993    -.2667     .3435    -.3311 
 Demonstration Program Results
   test11           
 the eigenvalues to be allocated are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .1420  +  i*   .9475
   .1420  -  i*   .9475
   .4103  +  i*   .1312
   .4103  -  i*   .1312
   .8856
   .0922

 WARNING: on exit iwarn = 1
 tolerance used =    .42854606E-06
 the eigenvalues of the closed loop are:
   .1420  +  i*   .9475
   .1420  -  i*   .9475
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .8856
   .0922
   .4103  +  i*   .1312
   .4103  -  i*   .1312

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .2648    -.9294     .1674     .2470    -.9065    -.4097    -.1178     .1701 
     .7043     .2260    -.1191    -.1199    -.2421     .2311    -.1223     .0333 
    -.5400     .5475     .6162    -.1538     .6763    -.6769    -.2359     .2566 
     .3207     .0781    -.7164     .1622     .4649    -.7413     .2581    -.0665 
    -.0691     .2863    -.5469    -.8528     .9486    1.2726     .3715    -.6028 
    -.1964     .4532    -.0715    -.3426     .2323    -.0024     .7386     .3585 
     .8049     .5425    -.1440    -.1333    -.2610     .1466     .6978     .1215 
   -1.0747     .0777     .0194    -.5196     .8482    -.3907    -.4436   -1.2912 
 Demonstration Program Results
   test12           
 the eigenvalues to be allocated are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .1420
   .9475
   .4103
   .1312
   .8856
   .0922

 WARNING: on exit iwarn = 1
 tolerance used =    .47871532E-06
 the eigenvalues of the closed loop are:
   .9017  +  i*   .4265
   .9017  -  i*   .4265
   .0921
   .1416
   .1317
   .9475
   .4103
   .8856

 computed gain matrix F:
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .0000     .0000     .0000     .0000     .0000     .0000     .0000     .0000 
     .5939    -.4165    -.5444    -.7489     .0000     .0000     .0000     .0000 
    -.0214    1.1300    -.0313     .7734     .0000     .0000     .0000     .0000 
    -.1453    -.1448    1.2168     .4517     .0000     .0000     .0000     .0000 
    -.2979    -.0431     .3522     .7659     .0000     .0000     .0000     .0000 
    -.1032    -.0728    -.5010    -.2337     .5275     .3007     .9273    -.3155 
    -.3026    -.1632    -.3029     .2156     .1829    -.7744     .0493     .1539 
 Demonstration Program Results
test13              
 the eigenvalues to be allocated are:
   .1234  +  i*   .4321
   .1234  -  i*   .4321
   .6789  +  i*   .9876
   .6789  -  i*   .9876
   .2468  +  i*   .8642
   .2468  -  i*   .8642
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .20265579E-05
 of  6 eigenvalues, the number allocated =  4
 the following eigenvalues were NOT allocated
   .2468  +  i*   .8642
   .2468  -  i*   .8642
 the eigenvalues of the closed loop are:
  1.0010
   .1227  +  i*   .4332
   .1227  -  i*   .4332
   .6791  +  i*   .9877
   .6791  -  i*   .9877
  8.0000

 computed gain matrix F:
    1.3871    -.1798   -1.3884   -1.5106   -1.7360     .0000 
    -.0764     .3491     .5212    1.1550    1.2771     .0000 
   -2.1276     .2688    2.1960    1.8309    2.2450     .0000 
 Demonstration Program Results
   test14           
 the eigenvalues to be allocated are:
   .4645  +  i*   .9410
   .4645  -  i*   .9410
   .0501
   .7615
   .7702
   .8278
   .1254
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .28956396E-06
 of  7 eigenvalues, the number allocated =  6
 the following eigenvalues were NOT allocated
   .1254
 the eigenvalues of the closed loop are:
   .4645  +  i*   .9410
   .4645  -  i*   .9410
   .0501
   .8278
   .7702
   .7615
  -.1122

 computed gain matrix F:
   -1.0843     .0882     .2301     .2246     .0000     .0000     .2557 
    -.2033    1.2802     .0694    -.3091    -.5666     .0000    -.7177 
   -2.0619    -.1116    2.5711   -1.8260    2.1958   -9.5969    -.1839 
 Demonstration Program Results
   test15           
 the eigenvalues to be allocated are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0537
   .4416
   .5192
   .7719
   .0654
   .4428
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .34392716E-06
 of  8 eigenvalues, the number allocated =  7
 the following eigenvalues were NOT allocated
   .4428
 the eigenvalues of the closed loop are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0654
   .0537
   .7719
   .5192
   .4416
  -.3029

 computed gain matrix F:
     .3227    -.5004    -.4283    -.4781     .0902    -.3277    -.1166     .0000 
    -.0068    1.5612   -2.2274   -4.2036     .0341   -9.1466   -4.7626     .0000 
     .0732    -.3890     .1507   -1.1243    -.2800    2.2841    -.3359     .0000 
    -.3282    -.0839     .3472     .1730    -.0922     .2528     .0081     .0000 
 Demonstration Program Results
   test16           
 the eigenvalues to be allocated are:
   .7219  +  i*   .4966
   .7219  -  i*   .4966
   .0537  +  i*   .4416
   .0537  -  i*   .4416
   .5192  +  i*   .7719
   .5192  -  i*   .7719
   .0654  +  i*   .4428
   .0654  -  i*   .4428
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .34392716E-06
 of  8 eigenvalues, the number allocated =  6
 the following eigenvalues were NOT allocated
   .0654  +  i*   .4428
   .0654  -  i*   .4428
 the eigenvalues of the closed loop are:
  1.5847
   .5192  +  i*   .7719
   .5192  -  i*   .7719
   .0537  +  i*   .4416
   .0537  -  i*   .4416
   .7219  +  i*   .4966
   .7219  -  i*   .4966
  -.3029

 computed gain matrix F:
    -.2632    -.4941    -.3114    -.5365     .0647    -.5069     .0518     .0000 
     .2203    1.1585   -2.2792   -4.0142   -3.1412   -8.6576   -3.4432     .0000 
    -.3401    -.4836    -.9029    -.5833    -.3461    3.9367   -1.7233     .0000 
     .1311    -.0904     .2283     .2323    -.0662     .4350    -.1631     .0000 
 Demonstration Program Results
   test17           
 the eigenvalues to be allocated are:
   .1312  +  i*   .8856
   .1312  -  i*   .8856
   .0922
   .1622
   .0711
   .3653
   .2531
   .1351
   .7832
   .4553
   .3495
 WARNING: on exit iwarn = 1

 WARNING: on exit iwarn = 2
 ERROR: on EXIT ierr  =  2
 tolerance used =    .56962710E-06
 of 11 eigenvalues, the number allocated =  8
 the following eigenvalues were NOT allocated
   .7832
   .4553
   .3495
 the eigenvalues of the closed loop are:
   .1312  +  i*   .8856
   .1312  -  i*   .8856
   .3653
   .0702
   .0945
   .1319
   .1640
   .2530
   .4872
   .0551  +  i*   .3677
   .0551  -  i*   .3677

 computed gain matrix F:
     .2857     .9355   -2.4787   -1.0795     .2068   -1.9580    1.4284    -.8409     .1869     .0000     .0000 
    -.3546     .5065     .2770     .3595     .0899    -.1065     .0110    -.0425     .3711     .0000     .0000 
    -.7520     .5500    1.7342    1.5942     .7685     .5034    -.0882    -.2786    -.3631     .0000     .0000 
     .8251    -.4281    -.0957   -1.5130    -.1432    -.0325    -.0890     .0828     .2589     .0000     .0000 
 Demonstration Program Results
   test30           
 the eigenvalues to be allocated are:
  -.0219  +  i*  1.9999
  -.0219  -  i*  1.9999
  -.0865  +  i*  1.9981
  -.0865  -  i*  1.9981
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.3309  +  i*  1.9724
  -.3309  -  i*  1.9724
  -.5000  +  i*  1.9365
  -.5000  -  i*  1.9365
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8955  +  i*  1.7883
  -.8955  -  i*  1.7883
 -1.1045  +  i*  1.6673
 -1.1045  -  i*  1.6673
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.5000  +  i*  1.3229
 -1.5000  -  i*  1.3229
 -1.6691  +  i*  1.1018
 -1.6691  -  i*  1.1018
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.9135  +  i*   .5817
 -1.9135  -  i*   .5817
 -1.9781  +  i*   .2948
 -1.9781  -  i*   .2948
 -2.0000
  2.0000

 ERROR: on EXIT ierr  =  1
 tolerance used =    .27716160E-04
 of 18 eigenvalues, the number allocated = 20
 the following eigenvalues were NOT allocated
 -1.6691  +  i*  1.1018
 -1.6691  -  i*  1.1018
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.9135  +  i*   .5817
 -1.9135  -  i*   .5817
 -1.9781  +  i*   .2948
 -1.9781  -  i*   .2948
 -2.0000
  2.0000
 the eigenvalues of the closed loop are:
  -.0219  +  i*  1.9999
  -.0219  -  i*  1.9999
  -.0865  +  i*  1.9981
  -.0865  -  i*  1.9981
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.3309  +  i*  1.9724
  -.3309  -  i*  1.9724
  -.5000  +  i*  1.9365
  -.5000  -  i*  1.9365
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8955  +  i*  1.7883
  -.8955  -  i*  1.7883
 -1.1045  +  i*  1.6673
 -1.1045  -  i*  1.6673
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.5000  +  i*  1.3229
 -1.5000  -  i*  1.3229
 -1.6691  +  i*  1.1019
 -1.6691  -  i*  1.1019
 -1.8090  +  i*   .8530
 -1.8090  -  i*   .8530
 -1.9134  +  i*   .5817
 -1.9134  -  i*   .5817
 -1.9779  +  i*   .2949
 -1.9779  -  i*   .2949
 -1.9998
  2.0000

 computed gain matrix F:
    -.0011     .0013    -.0023     .0022    -.0031     .0018    -.0020    -.0009     .0005    -.0041     .0010    -.0038    -.0036    -.0013    -.0075    -.0018    -.0021    -.0080    -.0048    -.0147
    -.0222    -.0128    -.0168    -.0127     .0268     .0484     .0214    -.0066    -.0064     .0015 
 Demonstration Program Results
   test19           
 the eigenvalues to be allocated are:
  -.0123  +  i*  2.0000
  -.0123  -  i*  2.0000
  -.0489  +  i*  1.9994
  -.0489  -  i*  1.9994
  -.1090  +  i*  1.9970
  -.1090  -  i*  1.9970
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.2929  +  i*  1.9784
  -.2929  -  i*  1.9784
  -.4122  +  i*  1.9571
  -.4122  -  i*  1.9571
  -.5460  +  i*  1.9240
  -.5460  -  i*  1.9240
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8436  +  i*  1.8134
  -.8436  -  i*  1.8134
 -1.0000  +  i*  1.7321
 -1.0000  -  i*  1.7321
 -1.1564  +  i*  1.6318
 -1.1564  -  i*  1.6318
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.4540  +  i*  1.3733
 -1.4540  -  i*  1.3733
 -1.5878  +  i*  1.2161
 -1.5878  -  i*  1.2161
 -1.7071  +  i*  1.0420
 -1.7071  -  i*  1.0420
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.8910  +  i*   .6512
 -1.8910  -  i*   .6512
 -1.9511  +  i*   .4397
 -1.9511  -  i*   .4397
 -1.9877  +  i*   .2216
 -1.9877  -  i*   .2216
 -2.0000
  2.0000

 ERROR: on EXIT ierr  =  1
 tolerance used =    .48875809E-04
 of 40 eigenvalues, the number allocated = 22
 the following eigenvalues were NOT allocated
 -1.3090  +  i*  1.5121
 -1.3090  -  i*  1.5121
 -1.4540  +  i*  1.3733
 -1.4540  -  i*  1.3733
 -1.5878  +  i*  1.2161
 -1.5878  -  i*  1.2161
 -1.7071  +  i*  1.0420
 -1.7071  -  i*  1.0420
 -1.8090  +  i*   .8529
 -1.8090  -  i*   .8529
 -1.8910  +  i*   .6512
 -1.8910  -  i*   .6512
 -1.9511  +  i*   .4397
 -1.9511  -  i*   .4397
 -1.9877  +  i*   .2216
 -1.9877  -  i*   .2216
 -2.0000
  2.0000
 the eigenvalues of the closed loop are:
  -.0123  +  i*  2.0000
  -.0123  -  i*  2.0000
  -.0489  +  i*  1.9994
  -.0489  -  i*  1.9994
  -.1090  +  i*  1.9970
  -.1090  -  i*  1.9970
  -.1910  +  i*  1.9909
  -.1910  -  i*  1.9909
  -.2929  +  i*  1.9784
  -.2929  -  i*  1.9784
  -.4122  +  i*  1.9571
  -.4122  -  i*  1.9571
  -.5460  +  i*  1.9240
  -.5460  -  i*  1.9240
  -.6910  +  i*  1.8768
  -.6910  -  i*  1.8768
  -.8436  +  i*  1.8134
  -.8436  -  i*  1.8134
 -1.0000  +  i*  1.7321
 -1.0000  -  i*  1.7321
 -1.1564  +  i*  1.6318
 -1.1564  -  i*  1.6318
 -1.5189  +  i*  1.5024
 -1.5189  -  i*  1.5024
 -1.3181  +  i*  1.5003
 -1.3181  -  i*  1.5003
 -1.4835  +  i*  1.2919
 -1.4835  -  i*  1.2919
 -1.5954  +  i*  1.0803
 -1.5954  -  i*  1.0803
 -1.6918  +  i*   .8717
 -1.6918  -  i*   .8717
 -1.7697  +  i*   .6593
 -1.7697  -  i*   .6593
 -1.8265  +  i*   .4423
 -1.8265  -  i*   .4423
 -1.8609  +  i*   .2220
 -1.8609  -  i*   .2220
 -1.8724
  2.0000

 computed gain matrix F:
   -1.3914    2.7615   -5.3933    7.9986  -10.7391   10.9826   -9.1175    3.5476    2.0793   -6.8276    6.1384   -2.2599   -3.9122    5.7567   -3.6915   -2.5286    5.6136   -3.4303   -2.2928    5.6727
   -3.3876   -5.0324    4.7217    -.4896   -4.6872    4.7689    -.7410  -16.2134   -8.2929    6.1341   -3.5885  -13.5137    4.5418   25.7594   19.4544   -1.4531  -10.2431   -5.2276     .1814     .6051
 Demonstration Program Results
test20              
 the eigenvalues to be allocated are:
   .1537  +  i*   .5717
   .1537  -  i*   .5717
   .8024  +  i*   .0331
   .8024  -  i*   .0331
   .5344
   .4985
   .9554
   .7483
   .5546

 tolerance used =    .34803895E-06
 eigenvalue stored at EIGS(N) on entry
   now stored at EIGS( 3)
 the eigenvalues of the closed loop are:
   .1537  +  i*   .5717
   .1537  -  i*   .5717
   .5022
   .5265
   .5585
   .9551
   .8015  +  i*   .0319
   .8015  -  i*   .0319
   .7506

 computed gain matrix F:
   -4.9628   10.3570   -4.3888   20.6881   41.5588  -20.4779    -.5653  -47.2747   29.5062 
    9.8125  -19.5563   10.5495  -37.6124  -81.4071   40.8140    1.4422   92.0327  -58.0661 
   -1.6540    2.4906   -1.4994    4.1485   11.2583   -4.9632    -.3037  -10.0442    7.3495 
C*** smevas.f
c
c FILE: smevas.f
c
c  == ==================================================================
c
      subroutine smevas(n, m, ncmplx, gmax, hmax, A, lda,
     &                     B,ldb, F,ldf, eigs, kmax, kstair,
     &                     info, iwork, rwork, tol, iwarn, ierr)
c
c  == ==================================================================
c
c    Purpose
c    =======
c
c    To compute a real matrix F so that the "closed-loop" matrix (A - B*F)
c    has a specified set of eigenvalues.
c
c    Here A and B are real matrices such that the system (B,A) is in "upper
c    staircase" (or "controllability") form, with
c    staircase blocks in upper triangular form, and
c    the set of specified eigenvalues is self conjugate.
c
c    This routine is a driver for the subroutine SMVS1.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           column dimension of matrix F
c           length of vector of eigenvalues EIGS.
c           N .ge. 1
c
c    M      INTEGER.
c           Column dimension of matrix B,
c           row dimension of matrix F.
c           M .ge. 1
c
c    NCMPLX INTEGER
c           Number of complex eigenvalues in EIGS.
c           0 .le. NCMPLX .le. N, and NCMPLX even.
c
c    GMAX   INTEGER.
c           Maximum number of Givens rotations to be used in the
c           computation.  A sufficient value of  GMAX  may be computed as
c           follows (see also HMAX below):
c           let: q = ifix(N/M) and
c                r = N-q*M  so that  
c                N = q*M+r  where q, r are non-negative integers and r < M
c                rsum = r*(r+1)/2
c                Msum1 = M*(M-1)/2
c           then
c                     |     (q/2)*(1 + Msum1) + M-r,   q even
c              GMAX = |
c                     | ((q-1)/2)*(1 + Msum1) + rsum,  q odd.
c
c    HMAX   INTEGER.
c           Maximum number of Householder transformations to be used in 
c           the computation.  A sufficient value of  HMAX  may be computed
c           as follows:
c           let  q, r, rsum, Msum1 be defined as for GMAX above. In addition,
c           let: Msum = M*(M+1)/2 
c           then
c                     |     (q/2)*(Msum*(q-2)/2 + rsum + 1) + M,   q even
c              HMAX = |
c                     | ((q-1)/2)*(Msum*(q-1)/2 + rsum + M-r) + r, q odd.
c
c
c           The following code computes GMAX and HMAX for given N and M
c
c              INTEGER   N, M
c              INTEGER   Q, Q2, R, RSUM, MSUM, MSUM1, GMAX, HMAX
c              LOGICAL   EVEN
c              .. assume N and M are initialised and carry on ..
c              Q = IFIX(N/M)
c              Q2 = IFIX(Q/2)
c              R = N-Q*M
c              RSUM = R*(R+1)/2
c              MSUM = M*(M+1)/2
c              MSUM1 = M*(M-1)/2
c              EVEN = (Q2*2 .EQ. Q)
c              IF (EVEN) THEN
c                  GMAX = (Q2)*(1 + MSUM1) + M-R
c                  HMAX = (Q2)*(1 + RSUM + (Q2-1)*MSUM) + M
c              ELSE
c                  GMAX = (Q2)*(1 + MSUM1) + RSUM
c                  HMAX = (Q2)*(M-R + RSUM + Q2*MSUM) + R
c              END IF
c
c           and the following declarations define less stringent but simpler
c           values of GMAX and HMAX
c              (Here we set N=M=20 for no particular reason other than
c               supplying a value)
c
c              INTEGER   N, M
c              PARAMETER (N = 20, M = 20)
c              INTEGER   Q, R, RSUM, MSUM, MSUM1
c              PARAMETER (Q = N/M,  R = N-Q*M,  RSUM = R*(R+1)/2)
c              PARAMETER (MSUM = M*(M+1)/2,  MSUM1 = M*(M-1)/2)
c              INTEGER   GMAX
c              PARAMETER (GMAX = (Q/2)*(1 + MSUM1) + M*(R+2)/2)
c              INTEGER   HMAX
c              PARAMETER (HMAX = (Q/2)*(MSUM*Q/2 + RSUM + M-R) + M)
c
c
c    A      REAL array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the state
c           transition matrix A in controllability (upper staircase) form,
c           with staircase blocks in upper triangular form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      REAL array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the input
c           matrix B in controllability (upper staircase) form.
c           Note: this array is overwritten.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c    LDF    INTEGER.
c           Row dimension of array F, as declared in the calling program
c           LDF .ge. M.
c
c    EIGS   REAL array of DIMENSION (N).
c           Vector of eigenvalues to be allocated.
c           The complex eigenvalues (there are NCMPLX of them) must occur as
c           conjugate pairs.  They are stored in EIGS(1:NCMPLX),  and the
c           real eigenvalues (there are N-NCMPLX of them) are stored in
c           EIGS(NCMPLX+1:N)
c           Since the real and imaginary parts of a complex number 
c           also determine its conjugate, only one real part and one
c           imaginary part are stored for each pair of conjugates. These
c           parts are stored in successive elements of EIGS, with the real
c           parts having odd indices.
c
c           EXAMPLE:
c              To store the four complex eigenvalues
c                     (0.1, 0.2), (0.1, -0.2), (0.3, -0.4), (0.3, 0.4)
c              and the two real eigenvalues
c                     0.5, 0.6
c              EIGS may be initialized to
c                     0.1, 0.2, 0.3, -0.4, 0.5, 0.6
c
c           Observe that for odd i < NCMPLX,  EIGS(i) and EIGS(i+1) are the
c           real and imaginary parts, respectively, of either member of a
c           pair of complex conjugate eigenvalues, as required.
c
c           Note: this array is overwritten. (That is, it may be rearranged).
c
c    KMAX   INTEGER.
c           Controllability index of the system [B,A],  
c           i.e. the number of stairs in the staircase form.
c
c    KSTAIR INTEGER array of DIMENSION (1+KMAX).
c           The leading KMAX elements must contain the ranks of B and the
c           staircase blocks of A, so that     
c           KSTAIR (1) = rank of B, 
c           KSTAIR (k) = rank of (k,k-1) block element of A, for k=2:KMAX,
c                        and 
c           KSTAIR (KMAX+1) = 0 is set by the routine.
c           Note: this array is overwritten.
c
c
c    Arguments Out
c    -------------
c
c    NCMPLX INTEGER.
c           Number of complex eigenvalues that were not allocated.
c           Complex eigenvalues are always allocated as conjugate pairs, so 
c           NCMPLX will always be even.
c
c    A      REAL array of DIMENSION (LDA,N).
c           This array contains no useful information.
c
c    B      REAL array of DIMENSION (LDB,M).
c           This array contains no useful information.
c
c    F      REAL array of DIMENSION (LDF,N).
c           The leading M by N part of this array contains the computed
c           gain matrix "F".
c           If the given data has M>N, then the first M-N rows of F
c           are set to zero.
c
c    EIGS   REAL array of DIMENSION (N).
c           Vector of allocated eigenvalues followed by eigenvalues 
c           that were not allocated, if any.
c           The number of successfully allocated eigenvalues is returned
c           in INFO(1).  (See INFO below).
c           Order of eigenvalues in EIGS may differ from the original 
c           insofar as the eigenvalue origially stored as EIGS(N) may
c           be moved to EIGS(I), with I .ne. N.   
c           Then the eigenvalues originally stored in EIGS(I:N-1) will
c           be shifted to EIGS(I+1:N), with no additional re-ordering.
c           This can occur only if N is odd (and hence EIGS(N) is real).
c           The index I is returned to the calling program in INFO(2). 
c           (See INFO below).
c
c    KSTAIR INTEGER array of DIMENSION (KMAX+1).
c           This array contains no useful information.
c
c    INFO   INTEGER array of DIMENSION (2).
c           INFO(1) returns number of successfully allocated eigenvalues.
c           INFO(2) returns index in EIGS of eigenvalue originally stored
c                   as EIGS(N), ie on exit EIGS(INFO(2)) contains the value
c                   that was stored in EIGS(N) on entry. (See also EIGS above).
c
c
c    Work Space
c    ----------
c
c    RWORK  REAL array of DIMENSION (3N + 2*GMAX + 3*HMAX).
c
c    IWORK  INTEGER array of DIMENSION (N + N/2 + GMAX + HMAX).
c
c
c    Tolerances
c    ----------
c
c    TOL    REAL.
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER.
c           Unless M>N, or the ranks of the staircase blocks do not sum to N
c           (see Warnings and Errors below), IWARN comtains 0 on exit.
c           
c
c    Error Indicator
c    ---------------
c
c    IERR   INTEGER.
c           Unless the routine detects an error (see next section),
c           IERR contains 0 on exit.
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    IWARN = 1  On entry, M > N.
c               In this case the first N-M rows of F can be freely
c               chosen and will not be stored.
c
c    IWARN = 2  Sum of ranks of staircase blocks is not equal to N.
c
c    IWARN = 3  On entry, conditions for  iwarn=1  and  iwarn=2 
c               both exist.
c
c
c    IERR < 0   IERR = -j indicates a problem with the j-th argument
c               on entry.  Specifically:
c               IERR = -1   On entry,  N < 1
c               IERR = -2   On entry,  M < 1
c               IERR = -3   On entry,  NCMPLX < 0
c                                 or   NCMPLX > N
c                                 or   NCMPLX is an odd number
c               IERR = -4   On entry,  GMAX < 1
c               IERR = -5   On entry,  HMAX < 1
c               IERR = -7   On entry,  LDA < N
c               IERR = -9   On entry,  LDB < N
c               IERR = -11  On entry,  LDF < M
c               IERR = -13  On entry,  KMAX > N
c                                 or   KMAX < 0
c
c    IERR = 1   Signifies attempt to divide by zero (ie a magnitude
c               less than TOL), or to solve a numerically singular
c               system of equations.
c
c    IERR = 2   During eigenvalue assignment a rank defficiency is
c               discovered in one of the staircase blocks, indicating
c               the system (B,A) is uncontrollable and assignment of
c               eigenvalues can proceed no farther.
c
c    IERR = 3   Signifies insufficient storage space for Givens rotations.
c               The quantity  GMAX  needs to be increased.
c
c    IERR = 4   Signifies insufficient storage space for Householder
c               transformations.  The quantity  HMAX  needs to be increased.
c
c
c    Method
c    ======
c
c    An orthogonal matrix Q is computed along with the feedback matrix F so
c    that  Q'(A-BF)Q is in its real Schur form with specified eigenvalues.
c    The algorithm allocates two eigenvalues at a time in a series of double
c    steps. During the first double step, for example, the algorithm computes
c    orthogonal matrix Q1, say, and the first two columns of F*Q1, so that
c
c                  | a b | * * .. * |
c                  | c d | * * .. * |
c    Q1'(A-BF)Q1 = |-----|----------|
c                  |     | AA-BB*FF |
c
c    with  |a b|
c          |c d|  having two specified eigenvalues, and (BB, AA) being in
c    staircase form.  The orthogonal matrix Q is the product of N/2  or 
c    (N-1)/2 + 1 (depending on whether N is even or odd) orthogonal matrices
c    of the type Q1.
c
c
c    References
c    ==========
c
c    [1]  G. S. Miminis and C.C. Paige,
c         A double step algorithm for pole assignment of time invariant
c         multi-input linear systems using state feedback,
c         Technical Report 8908, Department of Computer Science,
c         Memorial University of Newfoundland, 1989.
c
c
c    Numerical Aspects
c    =================
c     
c    The computation uses only real arithmetic, allocating complex eigenvalues
c    as conjugate pairs in "double steps".
c
c    The algorithm requires O( n(n**2 + m(n-m)) ) operations
c    (see ref [1]).
c
c
c    Contributors
c    ============
c
c    G. Miminis and H. Roth  (Memorial University of Newfoundland, Canada)
c
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c  == ==================================================================
c  == ==================================================================
c
c  declarations
c  ============
c
c     implicit none
c
c  arguments
      integer          n, m, ncmplx, gmax, hmax, lda, ldb, ldf
      real             A(lda,*), B(ldb,*), F(ldf,*), eigs(*)
      integer          kmax, kstair(*), info(*), iwork(*)
      real             rwork(*), tol
      integer          iwarn, ierr
c
c  parameters
      real              rzero
      parameter        (rzero = 0.0e0)
      integer           izero
      parameter        (izero = 0)
c
c  external subroutines
      external scopy, smvs1
c
c  local variables
      integer i, ilen, rlen
c
c
c  code starts here
c  ================
c
c  initialize
c  ==========
        info(1) = 0
        info(2) = 0
        iwarn = 0
        ierr = 0
c
c  check some input arguments 
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, ncmplx, gmax, hmax   A, lda, B, ldb, F,   ldf, eigs, 
c         kmax, kstair, info,   iwork, rwork, tol, iwarn, ierr)
      IF( (kmax .gt. n) .OR. (kmax .lt. 0) ) ierr = -13
      IF( ldf .lt. m ) ierr = -11
      IF( ldb .lt. n ) ierr = -9
      IF( lda .lt. n ) ierr = -7
      IF( hmax .lt. 1 ) ierr = -5
      IF( gmax .lt. 1 ) ierr = -4
      IF( (ncmplx .lt. 0) .OR. ((ncmplx/2)*2 .ne. ncmplx)
     &  .OR. (ncmplx .gt. n) ) ierr = -3
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  set kstair(kmax+1) to zero as required for smvs1
      kstair(kmax+1) = 0
c
c  clear the workspace
c  ===================
      rlen = 2*gmax + 3*hmax + 3*n
      ilen = gmax + hmax + n/2 + n
c
      call scopy( rlen, rzero, 0, rwork, 1 )
c
      do 60 i = 1, ilen
          iwork(i) = izero
   60 continue
c
c  summarize the workspace partitioning
c  ====================================
c     .. QG    starts at rwork(1);                has dimension(2,gmax)
c     .. QH    starts at rwork(1+2*gmax);         has dimension(3,hmax)
c     .. Rwork starts at rwork(1+2*gmax+3*hmax);  has length 3N
c              min length(rwork) = 2*gmax+3*hmax+3*N
c     .. GCOL  starts at iwork(1);                has length gmax
c     .. HCOL  starts at iwork(1+gmax);           has length hmax
c     .. FCOL  starts at iwork(1+gmax+hmax);      has length N/2
c     .. Iwork starts at iwork(1+gmax+hmax+N/2);  has length N
c              min length(iwork) = gmax+hmax+N/2+N
c
c  do the job
c  ==========
      call smvs1 (n,m,ncmplx, A,lda, B,ldb, F, ldf, eigs, kstair,
     &            info, rwork(1), 2, gmax, iwork(1),
     &            rwork(1+2*gmax), 3, hmax, iwork(1+gmax),
     &            iwork(1+gmax+hmax), tol, iwork(1+gmax+hmax+N/2),
     &            rwork(1+2*gmax+3*hmax), iwarn, ierr)
c
 9000 continue
      return
c     last line of smevas follows next
      end
c
c==== ==================================================================
c==== ==================================================================
c
      subroutine smvs1 (n,m,ncmplx, A,lda, B,ldb, F, ldf,
     &                  l, nn, info, QG,ldqg, colqg, Gcol,
     &                  QH,ldqh, colqh, Hcol, Fcol,
     &                  tol, Iwork, Rwork, iwarn, ierr)
c
c
c    Purpose
c    =======
c
c    To compute a real matrix F so that the "closed-loop" matrix (A - B*F)
c    has a specified set of eigenvalues.
c
c    Here A and B are real matrices such that the system (B,A) is in "upper
c    staircase" (or "controllability") form, and
c    the set of specified eigenvalues has the property that the complex
c    conjugate of any complex member is also a member.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER
c           Row and column dimension of matrix A
c           Row dimension of matrix B
c           Column dimension of matrix F
c           Length of vector of eigenvalues L
c           N .ge. 1
c
c    M      INTEGER
c           Column dimension of matrix B
c           Row dimension of matrix F
c           M .ge. 1
c
c    NCMPLX INTEGER
c           (Even) number of complex eigenvalues in L. (See L below)
c           0 .le. NCMPLX .le. N;  NCMPLX even
c
c    A      REAL array of DIMENSION (LDA,N)
c           The leading N by N part of this array must contain the state
c           transition matrix A in controllability (upper staircase) form,
c           with the staircase blocks in upper triangular form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      REAL array of DIMENSION (LDB,M)
c           The leading N by M part of this array must contain the input
c           matrix B in controllability form.
c           Note: this array is overwritten
c
c    LDB    INTEGER
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N
c
c    LDF    INTEGER
c           Row dimension of array F, as declared in the calling program.
c           LDF .ge. M
c
c    L      REAL array of DIMENSION (N)
c           Vector of eigenvalues to be allocated
c           The complex eigenvalues (there are NCMPLX of them) must occur as
c           conjugate pairs.  They are stored in L(1:NCMPLX),  and the
c           real eigenvalues (there are N-NCMPLX of them) are stored in
c           L(NCMPLX+1:N)
c           Since the real and imaginary parts of a complex number 
c           also determine its conjugate, only one real part and one
c           imaginary part are stored for each pair of conjugates. These
c           parts are stored in successive elements of L, with the real
c           parts having odd indices.
c
c           EXAMPLE:
c              To store the four complex eigenvalues
c                     (0.1, 0.2), (0.1, -0.2), (0.3, -0.4), (0.3, 0.4)
c              and the two real eigenvalues
c                     0.5, 0.6
c              L may be initialized to
c                     0.1, 0.2, 0.3, -0.4, 0.5, 0.6
c
c           Observe that for odd i < NCMPLX,  L(i) and L(i+1) are the
c           real and imaginary parts, respectively, of either member of a
c           pair of complex conjugate eigenvalues, as required.
c
c           Note: this array is overwritten  (that is, it may be rearranged)
c
c    NN     INTEGER array of DIMENSION (kp1)
c           where kp1 = (1 + controllability index)  of the system [B,A],  
c           Vector of ranks of B and staircase blocks of A.
c           NN(1) = rank of B
c           NN(k) = rank of (k,k-1) block element of A, for k = 2,...,kp1-1
c           Furthermore, it is important that
c                          NN(kp1) = 0  
c           as the subroutine assumes the existence of this dummy value.
c           Note: this array is overwritten
c
c    LDQG   INTEGER
c           Leading dimension of the array QG, as declared in the calling
c           program. Require  LDQG .GE. 2
c
c    COLQG  INTEGER
c           Number of columns of array QG.
c           A sufficiently large value of COLQG is  g  calculated as follows
c              let: mu = NN(1) = rank(B)
c                   a,b be non-negative integers such that  N = a*mu + b,  b<mu
c                   bsum = b*(b+1)/2,
c                   musum1 = (mu-1)*mu/2
c              then
c                       | ( a/2 )*( 1 + musum1 ) + mu - b ,       a even
c                   g = |
c                       | ( (a-1)/2 )*( 1 + musum1 ) + bsum ,     a odd
c
c    LDQH   INTEGER
c           Leading dimension of the array QH, as declared in the calling
c           program.
c           Require LDQH .GE. 3
c
c    COLQH  INTEGER
c           Number of columns of array QH.
c           A sufficiently large value of COLQH is  h  calculated as follows
c              let: mu, a, b, bsum  be defined as above (see COLQG)
c                   musum = mu*(mu+1)/2
c              then
c                     | ( a/2 )*( musum*(a-2)/2 + bsum + 1 ) + mu,       a even
c                 h = |
c                     | ( (a-1)/2 )*( musum*(a-1)/2 + bsum + mu-b ) + b, a odd
c
c
c    Arguments out
c    -------------
c
c    NCMPLX INTEGER
c           Number of complex eigenvalues that were not allocated.
c
c    A      REAL array of DIMENSION (LDA,N)
c           This array contains no useful information.
c
c    B      REAL array of DIMENSION (LDB,M)
c           This array contains no useful information.
c
c    F      REAL array of DIMENSION (LDF,N)
c           The leading M by N part of this array contains the computed
c           gain matrix "F" 
c           If the given data has M>N, then the first M-N rows of F
c           are set to zero.
c
c    L      REAL array of DIMENSION (N)
c           Vector of allocated eigenvalues followed by eigenvalues 
c           that were not allocated.
c           Order of eigenvalues in L may differ from the original 
c           insofar as the eigenvalue origially stored as L(N) may
c           be moved to L(I), I .ne. N.   
c           Then the eigenvalues originally stored in L(I:N-1) will
c           be shifted to L(I+1:N), with no additional re-ordering.
c           The index I is returned to the calling program in INFO(2)
c
c    NN     INTEGER array of DIMENSION (kp1)
c           This array contains no useful information.
c
c    INFO   INTEGER array of DIMENSION (2)
c           INFO(1) returns number of successfully allocated eigenvalues.
c           INFO(2) returns index in L of eigenvalue originally stored
c                   as L(N)
c
c    QG     REAL array of DIMENSION (LDQG,COLQG)
c           Stores the Givens rotations used in the computation.
c
c    GCOL   INTEGER array of DIMENSION (COLQG)
c           Vector storing index associated with each stored rotation
c
c    QH     REAL array of DIMENSION (LDQH,COLQH)
c           Stores the Householder reflectors used in the computation.
c
c    HCOL   INTEGER array of DIMENSION (COLQH)
c           Vector storing index associated with each stored Householder
c
c    FCOL   INTEGER array of DIMENSION (N/2)
c           Vector of indeces indicating portions of feedback "F" to which
c           rotations comprising "P" have been applied. (see ref[1] for 
c           further details)
c
c
c    Work Space
c    ----------
c
c    IWORK  INTEGER array of DIMENSION (N)
c
c    RWORK  REAL array of DIMENSION (3*N)
c
c
c    Tolerances
c    ----------
c
c    TOL    REAL
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm 
c           See LAPACK routine SLAMCH for details on computation of "eps"
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER
c           Unless M>N or the ranks of the staircase blocks do not sum to N
c           (see Warnings and Errors below), IWARN comtains 0 on exit
c           
c
c    Error Indicator
c    ---------------
c
c    IERR   INTEGER
c           Unless the routine detects an error (see next section),
c           IERR contains 0 on exit
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    IWARN = 1  On entry, M>N
c               In this case the first M-N rows of F can be freely chosen and 
c               will be neither computed nor stored.
c
c    IWARN = 2  Sum of ranks of staircase blocks is not equal to N.
c
c    IWARN = 3  On entry, conditions for  iwarn=1  and  iwarn=2 
c               both exist.
c
c
c    IERR = 1   Attempt to divide by zero or to solve singular system of 
c               equations. Here zero means any magnitude less than TOL
c
c    IERR = 2   Rank of the current deflated matrix is too low, indicating the
c               given system (B,A) is found to be too close (ie within TOL)
c               to an uncontrollable system.
c
c    IERR = 3   On entry, COLQG is too small for the number of Givens
c               transformations required for the computation.
c
c    IERR = 4   On entry, COLQH is too small for the number of Householder
c               transformations required for the computation.
c
c
c    Method
c    ======
c
c    An orthogonal matrix Q is computed along with the feedback matrix F so
c    that  Q'(A-BF)Q is in its real Schur form with specified eigenvalues.
c    The algorithm allocates two eigenvalues at a time in a series of double
c    steps. During the first double step, for example, the algorithm computes
c    orthogonal matrix Q1, say, and the first two columns of F*Q1, so that
c
c                  | a b | * * .. * |
c                  | c d | * * .. * |
c    Q1'(A-BF)Q1 = |-----|----------|
c                  |     | AA-BB*FF |
c
c    with  |a b|
c          |c d|  having two specified eigenvalues, and (BB, AA) being in
c    staircase form.  The orthogonal matrix Q is the product of N/2  or 
c    (N-1)/2 + 1 (depending on whether N is even or odd) orthogonal matrices
c    of the type Q1.
c
c
c    References
c    ==========
c
c    [1]  G. S. Miminis and C.C. Paige,
c         A double step algorithm for pole assignment of time invariant
c         multi-input linear systems using state feedback,
c         Technical Report 8908, Department of Computer Science,
c         Memorial University of Newfoundland, 1989.
c
c
c    Numerical Aspects
c    =================
c
c    The algorithm requires  O( N(N^2 + M(N-M)) )  operations  (see ref [1]).
c    The computation uses only real arithmetic, allocating complex eigenvalues
c    as conjugate pairs in double steps.
c
c
c    Aditional Comments
c    ==================
c
c    In the course of the computation of F, SMVS1 applies a number of
c    Givens rotations and Householder reflectors whose inverses are
c    applied later. 
c
c    Each Householder reflector used in the subroutine is computed to 
c    eliminate the first two elements of a 3-vector into the third.  
c    Thus the reflector can be completely specified by a three-element 
c    vector v:  H = I-2vv'/v'v,  where v' is the transpose of v.
c    In SMVS1, the vector v is computed so that its third element is 
c    normalized to unity.  Since the value of v(3) is known, it need not
c    be stored and v(3) is used to store  v'v/2 instead.
c    The individual vectors are stored in columns of the 3xh matrix QH,
c    where h is the maximum number of Householders that may be expected.
c    Associated with each householder is an index indicating where the 
c    reflector is to be applied to a vector (ie which 3 elements of an
c    n-component vector will be affected).  This index is stored in the
c    corresponding element of Hcol.  Thus if the Householder stored at
c    QH(j) is to be applied to a vector at index i, then Hcol(j) is 
c    assigned the value i.
c    When a householder is computed to eliminate x(1) and x(2) into x(3),
c    not only is the vector v computed as above, but also x is overwritten
c    by Hx.
c
c    Similarly, each Givens rotation can be specified by a two-element
c    vector.  Each such vector is stored in a column of the 2xg matrix QG,
c    where g represents the maximum number of rotations expected.  The
c    associated index is stored in the corresponding element of the
c    vector Gcol.  The Givens rotations are computed and applied by the
c    BLAS routines SROTG and SROT respectively.
c
c    The subprogram first computes P'FQ and then applies P from the left
c    and Q' from the right to extract F.  
c    P' consists entirely of rotations and is stored in QG beginning at
c    high column index and progressing toward lower column indeces.
c    The individual rotations of P' apply to only part of F, the
c    associated index of F being stored in the vector Fcol. 
c    Q consists of both rotations and reflectors computed in each 
c    deflation step.  The rotations and reflectors of Q are both stored
c    by increasing column index beginning at column 1 in QG and QH
c    respectively.  The end of each step is marked in the structures by
c    setting negative in Gcol and Hcol the indeces associated with the
c    last rotation and reflector in that step.
c
c    If in a particular step a Householder but no rotation is required,
c    a dummy rotation is inserted into QG and recognized by its
c    associated index in Gcol, which is given the value zero.  
c    Similarly if a rotation but no Householder is required, a dummy
c    Householder is introduced with associated index equal to zero
c    placed in Hcol.  These manoeuvres facilitate the application of Q'.
c
c
c    Contributors
c    ============
c 
c    G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c  arguments
c     implicit         none
      integer          lda, n, ldb, m, ldf, ncmplx, nn(*)
      real             A(lda,*), B(ldb,*), F(ldf,*), l(*), tol
      integer          ldqg, colqg, Gcol(*)
      integer          ldqh, colqh, Hcol(*), Fcol(*)
      real             QG(ldqg,*), QH(ldqh,*), Rwork(*)
      integer          info(*), Iwork(*), iwarn, ierr
c
c
c  parameters
      real      zero, one, two
      parameter (zero=0.0e0, one=1.0e0, two=2.0e0)
      integer   ok
      parameter (ok=0)
c
c  local variables
      integer status, lnpos
      integer m0, m1, nm2
      integer i, j, j1, k, s, ss, itmp, infot, oddn, step, step1
      integer Bfree, Bfree1, free, free1, r, q, size, row, col
      integer Findex, Gindex, Hindex, Pindex, Pstart
      real    atmp, cx, sx, lsum, lprod, f11, f12
      real    eps
c      
c  intrinsic functions
      intrinsic min, max, abs
c
c  external functions
c   BLAS:     sdot
c   LAPACK:   slamch
c   PACKAGE:  s1nrmU, s1nrmA
      real      sdot, slamch, s1nrmU, s1nrmA
      external  sdot, slamch, s1nrmU, s1nrmA
c
c  external subroutines
c   BLAS:
      external scopy, srotg, srot, sswap
c   PACKAGE
      external stinvb, shhldr, shhrfl, sabort
c     note:
c          stinvb calls LAPACK routines strtrs, strcon
c          s1nrmU, s1nrmA call BLAS routine sasum
c
c
c  INITIALIZATION
c  **************
c
      status = 0
      lnpos = n
      iwarn = 0
      ierr  = 0
c
c  ====================================================================
c  Input arguments are checked by the driver subroutine smevas.
c  Hence the following checks are commented out and not mentioned
c  in the documentation, but may be useful for further development.
c  
c  the arguments to smvs1 are
c     n, m, ncmplx, A, lda,        B, ldb, F, ldf, l,
c     nn, info, QG, ldqg, colqg,   Gcol, QH, ldqh, colqh, Hcol,
c     Fcol, tol Iwork, Rwork, iwarn,    ierr
c
c  check some input arguments
c     IF (colqh .LT. 1) ierr = -19
c     IF (ldqh .LT. 3) ierr = -18
c     IF (colqg .LT. 1) ierr = -15
c     IF (ldqg .LT. 2) ierr = -14
c     IF (ldf .LT. m) ierr = -9
c     IF (ldb .LT. n) ierr = -7
c     IF (lda .LT. n) ierr = -5
c     IF( (ncmplx .LT. 0) .OR. ((ncmplx/2)*2 .NE. ncmplx)
c    &  .OR. (ncmplx .gt. n) ) ierr = -3
c     IF (m .LT. 1) ierr = -2
c     IF (n .LT. 1) ierr = -1
c
c     IF (ierr .lt. 0) THEN
c         GOTO 9900
c     ENDIF
c  ====================================================================
c
c  check that sum of ranks of staircase blocks is equal to N
c  if not set iwarn = 2
      k = 1
      itmp = N
c     do while ((nn(k) .ne. 0) .and. (k .le. N))
   70 IF ((nn(k) .ne. 0) .and. (k .le. N)) then
         itmp = itmp - nn(k)
         k = k + 1
         go to 70
      ENDIF
      IF (itmp .ne. 0) then
         iwarn = 2
      ENDIF
c
c     lnpos indicates position in final l-vector of initial l(n)
c     Bfree initialises to number of leading zero columns in B
c     free keeps number of leading zero rows in current A
c     step: A(step,step) is leading element in current A
c     Gindex is index to current Givens rotation in "Q"
c     Hindex is index to current Householder reflector in "Q"
c     Pindex is index to current Givens rotation in "P"
c     Findex points to first of columns of F which receive application
c          of current rotation in "P"
c     Pstart is index to first rotation (if any) in "P"
c     oddn = 1 if n is odd; 0 otherwise
c     m0 stores initial m and 
c     m1 is initialized to min(m,n). A warning is given if m>n. 
c
      m0 = m
      IF (m .LE. n) then
          m1 = m
      ELSE
          m1 = n
          iwarn = iwarn + 1
      ENDIF
      Bfree = m0-nn(1)
      Bfree1 = Bfree+1
      free = m1-nn(1)
      free1 = free+1
      step=1
      Gindex=0
      Hindex=0
      Findex=0
      Pstart=colqg+1
      Pindex=Pstart
      oddn = n-(n/2)*2
c
c  reset "tol" for numerical singularity, if necessary
c
c     .. calculate machine epsilon and store in "eps"
      eps = slamch('e')
      IF (tol .lt. eps) then
c         .. compute 1-norm of system [B,A] and reset tol
          atmp = max(s1nrmU(B(1,Bfree1),ldb,nn(1)), s1nrmA(A,lda,n) )
          tol = (n+m1) * atmp * eps
      ENDIF
c
c
c  INITIAL IMMEDIATE ALLOCATIONS
c  *****************************
c
      s=nn(1)-nn(2)
      ss=(s/2)*2
      itmp = min(ss, ncmplx)
      IF (ss .GT. 0) then
            DO 110 i=2,itmp,2
               A(i-1,i-1) = A(i-1,i-1) - l(i-1)
               A(i,i-1) = A(i,i-1) + l(i)
               A(i,i) = A(i,i) - l(i-1)
               A(i-1,i) = A(i-1,i) - l(i)
  110       CONTINUE    
            ncmplx = ncmplx-itmp
            DO 120 i=itmp+1,ss
               A(i,i) = A(i,i) - l(i)
  120       CONTINUE
      ENDIF
c
c     If  s  and  n  both odd then allocate a real eigenvalue;
c     in particular allocate  l(n), the last eigenvalue in l,
c     shift l(s:n-1) to l(s+1:n), and set ss=s
c
      IF ((ss .NE. s) .AND. (oddn .NE. 0)) then
          atmp = l(n)
          call scopy (n-s, l(s), -1, l(s+1), -1)
          l(s) = atmp
          A(s,s) = A(s,s) - atmp
          ss = s
          lnpos = s
      ENDIF
c
      IF (ss .GT. 0) then
          call stinvb( B(step,Bfree1), ldb, nn(1), 
     &                 A, lda, ss, Iwork, Rwork, tol, infot )
          IF (infot .NE. ok) then
                   ierr = 1
                   call sabort(A, lda, m1, n, 0)
                   GOTO 9000
          ENDIF
c
c         relocate computed cols if free>0
          IF (free .GT. 0) then
              DO 140 j=1,ss
                  call scopy(nn(1), A(1,j), -1, A(free1,j), -1)
                  call scopy(free, zero, 0, A(1,j), 1)
  140         CONTINUE
          ENDIF
c
          IF (nn(1) .EQ. n) then
              status = n
              GOTO 9000
          ENDIF
      ENDIF
c
c     updates
      status = ss
      free = free+ss
      free1 = free+1
      Bfree = Bfree+ss
      Bfree1 = Bfree+1
      nn(1) = nn(1)-ss
      step = ss+1
c
c
c  DEFLATIONARY LOOP:
c  *****************
c
      nm2 = n-2
c     do while( step .LE. nm2  .AND.  nn(1)+nn(2) .GE. 2)
  200 IF ((step .LE. nm2) .AND. (nn(1)+nn(2) .GE. 2))  then
c               The second clause of the condition handles some 
c               pathological cases that can arise when SUM(nn(i)) < N
c
          s=nn(1)-nn(2)
c
          IF ( (s .EQ. 1) .AND. (oddn .EQ. 1) ) then
c
c            begin CASE 1.  Immediate single allocation of l(n)
c            ************
c
             atmp = l(n)
             call scopy(n-step, l(step), -1, l(step+1), -1)
             l(step) = atmp
             lnpos = step
             A(step,step)=A(step,step)-atmp
c
             free1 = free+1
             Bfree1 = Bfree+1
             call stinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 1, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call sabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate 'F'
             IF (free1 .LT. step) then
                 call scopy(nn(1), A(step,step), 1, A(free1,step), 1)
             ELSE
                 IF (free1 .GT. step) then
                    call scopy(nn(1), A(step,step),-1, A(free1,step),-1)
                 ENDIF
             ENDIF
             call scopy(free, zero, 0, A(1,step), 1)
c
c            updates
             status = status+1
             nn(1) = nn(2)
             step = step+1
             free = free1
             free1 = free+1
             Bfree = Bfree1
             Bfree1 = Bfree+1
             oddn = 0
c            end case 1: immediate single allocation
c
          ELSE IF (s .EQ. 2) then
c
c            begin CASE 2.  Immediate double allocation of l(step), l(step+1)
c            ************ 
c
             free1 = free+1
             Bfree1 = Bfree+1
             step1 = step+1
             IF (ncmplx .GT. 0) then
                A(step,step) = A(step,step)-l(step)
                A(step1,step) = A(step1,step)+l(step1)
                A(step1,step1) = A(step1,step1)-l(step)
                A(step,step1) = A(step,step1)-l(step+1)
             ELSE
                A(step,step) = A(step,step)-l(step)
                A(step1,step1) = A(step1,step1)-l(step1)
             ENDIF
             call stinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 2, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call sabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate 'F'
             IF (free1 .LT. step) then
                 call scopy(nn(1), A(step,step),  1, A(free1,step),  1)
                 call scopy(nn(1), A(step,step1), 1, A(free1,step1), 1)
             ELSE IF (free1 .GT. step) then
                 call scopy(nn(1), A(step,step), -1, A(free1,step), -1)
                 call scopy(nn(1), A(step,step1),-1, A(free1,step1),-1)
             ENDIF
                 call scopy(free, zero, 0, A(1,step),  1)
                 call scopy(free, zero, 0, A(1,step1), 1)

             IF (ncmplx .GT. 0) then
                 ncmplx = ncmplx-2
             ENDIF
c
c            update
             status = status+2
             nn(1) = nn(2)
             free = free+2
             free1 = free+1
             Bfree = Bfree+2
             Bfree1 = Bfree+1
             step = step+2
c
c            end CASE 2.  Immediate double allocation of l(step), l(step+1)
c
          ELSE
c
c            begin CASE 3: cases (s=0) OR (s=1 and n even)
c            ************
c
c            FIND NEXT r
             r=2
  300        CONTINUE
             IF ( nn(r) .EQ. nn(r+1) )  then
                r = r+1
                goto 300
             ENDIF
c
             IF ( r .GT. 2 ) then
c
c               begin CASE 3a.   regular double allocation  ( r>2 )
c               -------------
c
                q=nn(r)
                size = step-1 + nn(1) + (r-1)*q
                row = size-q+1
                col = row-q
c
c               Form row of N, taking advantage of upper Hessenberg structure,
c               and store in Rwork(1:n)
c               First non-zero in row-th row of A is in column col
c               First non-zero in row-th row of N is in column col-q
c               Use contiguous copy of row-th row of A
c
                IF (ncmplx .GT. 0) then
                    lsum = two * l(step)
                    lprod = l(step)**2 + l(step+1)**2
                ELSE 
                    lsum = l(step) + l(step+1)
                    lprod = l(step) * l(step+1)
                ENDIF
c
c               copy row-th row of A to Rwork(n+1:2n)
c               first non zero will be in Rwork(n+col)
                call scopy(n, A(row,1), lda, Rwork(n+1), 1)
c
                ss = n+col
                itmp = col-q
                DO 350 j=itmp,row-1
                    k = j-itmp+1
c                     = # non-zeros in j-th column of A(col:size,col-q:size-q)
                    Rwork(j) = sdot(k, Rwork(ss), 1, A(col,j), 1) 
     &                           - lsum*A(row,j)
  350           CONTINUE
c
                k = 2*q
                Rwork(row) = lprod - lsum*A(row,j) +
     &                         sdot(k, Rwork(ss), 1, A(col,j), 1)
c
                DO 360 j=row+1,size
                    Rwork(j) = sdot(k, Rwork(ss), 1, A(col,j), 1)
     &                           - lsum*A(row,j)
  360           CONTINUE
c
c               P1:  first q-1 rotations
c
                IF (q .EQ. 1) then
c                   dummy rotation (to facilitate back transformation)
                    Gindex = Gindex+1
                    IF (Gindex .ge. Pindex) THEN
                        Gindex = Gindex-1
                        ierr = 3
                        call sabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    Gcol(Gindex) = 0
                ELSE      
                    DO 420 i=size,size-q+2,-1
                        j = i-q
                        j1 = j+1
                        itmp = j-q
c
c                       compute rotation eliminating A(i,j) into A(i,j+1)
                        Gindex = Gindex+1
                        IF (Gindex .ge. Pindex) THEN
                            Gindex = Gindex-1
                            ierr = 3
                            call sabort(A, lda, m1, n, step-1)
                            GOTO 3000
                        ENDIF
                        call srotg( A(i,j1), A(i,j), cx, sx)
                        A(i,j) = zero
                        QG(1,Gindex) = cx 
                        QG(2,Gindex) = sx
                        Gcol(Gindex) = j
c
c                       post multiply A by computed rotation (to row i)
                        call srot( i-step, A(step,j1), 1,
     &                                  A(step,j), 1, cx, sx )
c
c                       pre multiply A by computed rotation (from column j-q)
                        call srot( n-itmp+1, A(j1,itmp), lda,
     &                                     A(j,itmp), lda, cx, sx )
c
c                       post multiply Rwork by computed rotation
                        call srot(1, Rwork(j1), 1, Rwork(j), 1, cx, sx)
  420               CONTINUE
                ENDIF
c
c               P2:  q-1 householders
c
                DO 480 i=row,row-q+2,-1
                    j=i-q-1
c                   compute Householder vector and store in QH(1:3,Hindex)
                    Hindex=Hindex+1
                    IF (Hindex .gt. colqh) THEN
                        Hindex = Hindex-1
                        ierr = 4
                        call sabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    call shhldr( A(i,j), lda, tol, QH(1,Hindex))
                    Hcol(Hindex) = j
c
c                   post multiply A by computed Householder
                    DO 440 k=step,i-1
                        call shhrfl( A(k,j), lda, QH(1,Hindex) )
  440               CONTINUE
c
c                   pre multiply A by computed Householder
                    DO 460 k=step,n
                        call shhrfl( A(j,k), 1, QH(1,Hindex) )
  460               CONTINUE
c
c                   pre multiply B by computed Householder
                    DO 470 k=Bfree1,m0
                        call shhrfl( B(j,k), 1, QH(1,Hindex) )
  470               CONTINUE
c
c                   post multiply Rwork by computed Householder
                    call shhrfl( Rwork(j), 1, QH(1,Hindex) )
c
  480           CONTINUE
c
c               P3:   householder for row of N
c      
                j=col-q
                Hindex=Hindex+1
                IF (Hindex .gt. colqh) THEN
                    Hindex = Hindex-1
                    ierr = 4
                    call sabort(A, lda, m1, n, step-1)
                    GOTO 3000
                ENDIF
                call shhldr (Rwork(j), 1, tol, QH(1,Hindex))
                Hcol(Hindex) = j
c
c               post multiply A by computed Householder
                DO 500 i=step,col+1
                   call shhrfl( A(i,j), lda, QH(1,Hindex))
  500           CONTINUE
c
c               pre multiply A by computed Householder
                DO 510 i=step,n
                   call shhrfl( A(j,i), 1, QH(1,Hindex))
  510           CONTINUE
c
c               pre multiply B by computed Householder
                DO 520 k=Bfree1,m0
                    call shhrfl( B(j,k), 1, QH(1,Hindex) )
  520           CONTINUE
c
c               Compute P4: product of  nn(1)-(r-4)*q  Householders
c
c               P4a: all but the last of P4's Householders:
c
                DO 650 i=row-q+1,step+q+3,-1
                     j=i-q-2
                     Hindex=Hindex+1
                     IF (Hindex .gt. colqh) THEN
                         Hindex = Hindex-1
                         ierr = 4
                         call sabort(A, lda, m1, n, step-1)
                         GOTO 3000
                     ENDIF
                     call shhldr( A(i,j), lda, tol, QH(1,Hindex) )
                     Hcol(Hindex) = j
c
c                    post multiply A by computed Householder
                     DO 600 k=step,i-1
                          call shhrfl( A(k,j), lda, QH(1,Hindex) )
  600                CONTINUE
c
c                    pre multiply A by computed Householder
                     DO 610 k=step,n
                          call shhrfl( A(j,k), 1, QH(1,Hindex) )
  610                CONTINUE
c
c                    pre multiply B by computed Householder 
                     DO 620 k=Bfree1,m0
                          call shhrfl( B(j,k), 1, QH(1,Hindex) )
  620                CONTINUE
  650           CONTINUE
c
c               P4b: last householder if needed
c
                IF ( nn(1)+(r-4)*q .NE. 0 ) then
c
                    Hindex = Hindex+1
                    IF (Hindex .gt. colqh) THEN
                        Hindex = Hindex-1
                        ierr = 4
                        call sabort(A, lda, m1, n, step-1)
                        GOTO 3000
                    ENDIF
                    Hcol(Hindex) = step
c
                    IF ( nn(1) .EQ. q ) then 
c                       case nn(1) = q
                        call shhldr(A(step+q+2,step), lda, tol,
     &                                                   QH(1,Hindex))
c                       post multiply A by computed Householder
                        DO 670 k=step,step+q+1
                            call shhrfl( A(k,step), lda, QH(1,Hindex) )
  670                   CONTINUE
                    ELSE
c                       case nn(1) = q+1
                        QH(1,Hindex) = -one
                        QH(2,Hindex) = zero
                        QH(3,Hindex) = one

c                       post multiply A by permuting Householder
                        call sswap(n-step+1, A(step,step), 1,
     &                                       A(step,step+2), 1)
                    ENDIF
c
c                   pre multiply A by computed Householder
                    DO 690 k=step,n
                        call shhrfl( A(step,k), 1, QH(1,Hindex) )
  690               CONTINUE
c
c                   pre multiply B by  computed Householder 
                    DO 700 k=Bfree1,m0
                        call shhrfl( B(step,k), 1, QH(1,Hindex) )
  700               CONTINUE
                ENDIF
c
                step1 = step+1
                itmp = step+2
                call stinvb( B(itmp,Bfree1),ldb,nn(1), 
     &                A(itmp,step),lda,2, Iwork, Rwork, tol, infot)
c
                IF (infot .NE. ok) then
                    ierr = 1
                    call sabort(A, lda, m1, n, step-1)
                    GOTO 3000
                ENDIF
c
c               relocate computed cols of F to first m rows of A
                IF (free .LT. step1) then
c                   { free1 < itmp }
                    call scopy(nn(1), A(itmp,step), 1, 
     &                                  A(free1,step), 1)
                    call scopy(nn(1), A(itmp,step1), 1, 
     &                                  A(free1,step1), 1)
                ELSE IF (free .GT. step1) then
                    call scopy(nn(1), A(itmp,step), -1, 
     &                                  A(free1,step), -1)
                    call scopy(nn(1), A(itmp,step1), -1, 
     &                                  A(free1,step1), -1)
                ENDIF
                call scopy(free, zero, 0, A(1,step),  1)
                call scopy(free, zero, 0, A(1,step1), 1)
c
c               end CASE 3a.   regular double allocation  ( r>2 )
c
             ELSE
c
c               begin CASE 3b.   Case r=2
c               -------------
c
                q = nn(2)
c
                IF ( s .EQ. 0 ) then
c
c                 begin 3b SUB-CASE  r=2 with nn(1) = nn(2)
c                 -----------------------------------------
c
c                 P1:  q-1 rotations
c      
                  DO 1020 j=step-1+q,step+1,-1
                     i=j+q
c
c                    compute rotation eliminating A(i,j) into A(i,j+1)
                     call srotg( A(i,j+1), A(i,j), cx, sx)
                     A(i,j)=zero
                     Gindex = Gindex+1
                     IF (Gindex .ge. Pindex) THEN
                         Gindex = Gindex-1
                         ierr = 3
                         call sabort(A, lda, m1, n, step-1)
                         GOTO 3000
                     ENDIF
                     QG(1,Gindex) = cx
                     QG(2,Gindex) = sx
                     Gcol(Gindex) = j
c
c                    post multiply A by computed rotation
                     call srot(i-step,A(step,j+1),1,
     &                             A(step,j),1, cx, sx )
c
c                    pre multiply A by computed rotation
                     call srot(n-step+1,A(j+1,step),lda,
     &                             A(j,step),lda, cx, sx )
c
c                    premultiply B by computed rotation
                     call srot(m0-Bfree,B(j+1,Bfree1),ldb,
     &                             B(j,Bfree+1),ldb, cx, sx )
 1020             CONTINUE
c
c
c                 P2: dummy Householder
                  Hindex = Hindex+1
                  IF (Hindex .gt. colqh) THEN
                      Hindex = Hindex-1
                      ierr = 4
                      call sabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  Hcol(Hindex) = 0
c
c                 compute F10
                  IF( Bfree+2 .LE. m0 ) then
                      call stinvb( B(step+2,Bfree+2),ldb,q-1, 
     &                             A(step+2,step),lda,2, 
     &                             Iwork, Rwork, tol, infot)
                      IF(infot .NE. ok) then
                         ierr = 1
                         call sabort(A, lda, m1, n, step-1)
                         GOTO 3000
                      ENDIF
c
c                     compute A10 - B01*F10
                      i=step
                      j=Bfree+2
                      A(i,i) = A(i,i) - sdot(q-1, B(i,j),ldb,
     &                                              A(i+2,i),1 )
                      A(i+1,i) = A(i+1,i) - sdot(q-1, B(i+1,j),ldb,
     &                                              A(i+2,i),1 )
                      A(i+1,i+1) = A(i+1,i+1) - sdot(q-1, B(i+1,j),ldb,
     &                                              A(i+2,i+1),1 )
                      A(i,i+1) = A(i,i+1) - sdot(q-1, B(i,j),ldb,
     &                                              A(i+2,i+1),1 )
                  ENDIF
c
                  step1 = step+1
                  IF ( (abs(B(step,Bfree1)) .LT. tol) .OR.
     &                 (abs(A(step1,step)) .LT. tol)      ) then
                          ierr = 1
                          call sabort(A, lda, m1, n, step-1)
                          GOTO 3000
                  ENDIF
c
c                 compute f1'
                  IF ( ncmplx .GT. 0 ) then
                      lsum = l(step) + l(step)
                      lprod= l(step)*l(step) + l(step1)*l(step1)
                  ELSE
                      lsum = l(step) + l(step1)
                      lprod= l(step)*l(step1)
                  ENDIF
c
                  atmp = A(step1,step1)
c
                  f11 = ( A(step,step)+atmp-lsum ) / B(step,Bfree1)
c
                  f12 = ( (atmp*(atmp-lsum)+lprod)/A(step1,step)
     &                  + A(step,step1) ) / B(step,Bfree1)
c
c                 relocate computed columns of F into A(1:m,:)
                  IF (free .LT. step) then
c                     free+2 < step+2
                      call scopy(q-1, A(step+2,step), 1, 
     &                                   A(free+2,step), 1)
                      call scopy(q-1, A(step+2,step1), 1, 
     &                                   A(free+2,step1), 1)
                  ELSE IF (free+2 .GT. step+2) then
                      call scopy(q-1, A(step+2,step), -1, 
     &                                   A(free+2,step), -1)
                      call scopy(q-1, A(step+2,step1), -1, 
     &                                   A(free+2,step1), -1)
                  ENDIF
                  A(free1,step)=f11
                  A(free1,step1)=f12
                  call scopy(free, zero, 0, A(1,step), 1)
                  call scopy(free, zero, 0, A(1,step1), 1)
c
c                 end CASE r=2 with nn(1) = nn(2)
c
                ELSE
c                 begin 3b SUB CASE  r=2 with nn(1) = nn(2)+1   (s=1)
c                 -------------------------------------------
c
c                 P1: q-1 rotations   { q = nn(2) }
c
                  IF (q .LE. 1) then
c                     dummy rotation if q-1 .LE. 0
                      Gindex = Gindex+1
                      IF (Gindex .ge. Pindex) THEN
                          Gindex = Gindex-1
                          ierr = 3
                          call sabort(A, lda, m1, n, step-1)
                          GOTO 3000
                      ENDIF
                      Gcol(Gindex) = 0
                  ELSE
                      DO 1120 j=step+q,step+2,-1
                          i=j+q
c
c                         compute rotation eliminating A(i,j) into A(i,j+1)
                          call srotg( A(i,j+1), A(i,j), cx, sx)
                          A(i,j)=zero
                          Gindex = Gindex+1
                          IF (Gindex .ge. Pindex) THEN
                              Gindex = Gindex-1
                              ierr = 3
                              call sabort(A, lda, m1, n, step-1)
                              GOTO 3000
                          ENDIF
                          QG(1,Gindex) = cx
                          QG(2,Gindex) = sx
                          Gcol(Gindex) = j
c
c                         post multiply A by computed rotation
                          call srot(i-step,A(step,j+1),1,
     &                             A(step,j),1, cx, sx )
c
c                         pre multiply A by computed rotation
                          call srot(n-step+1,A(j+1,step),lda,
     &                                       A(j,step),lda, cx, sx )
c
c                         premultiply B by computed rotation
                          call srot(m0-Bfree,B(j+1,Bfree1),ldb,
     &                                       B(j,Bfree1),ldb, cx, sx )
 1120                 CONTINUE
                  ENDIF
c
c
c                 P2: Householder interchanging cols step, step+2
c
                  Hindex=Hindex+1
                  IF (Hindex .gt. colqh) THEN
                      Hindex = Hindex-1
                      ierr = 4
                      call sabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  QH(1,Hindex) = -one
                  QH(2,Hindex) = zero
                  QH(3,Hindex) = one
                  Hcol(Hindex) = step
c
c                 post multiply A by permuting Householder
                  call sswap(n-step+1,A(step,step),1,A(step,step+2),1)
c
c                 pre multiply A by permuting Householder
                  call sswap(n-step+1, A(step,step),lda, 
     &                                   A(step+2,step),lda)
c
c                 pre multiply B by permuting Householder 
                  call sswap(m0-Bfree, B(step,Bfree1),ldb,
     &                                   B(step+2,Bfree1),ldb)
c
c                 compute P: rotation to eliminate B(3,1) into B(3,2)
                  i=step+2
                  j=Bfree1
                  Pindex = Pindex-1
                  IF (Pindex .le. Gindex) THEN
                      Pindex = Pindex+1
                      ierr = 3
                      call sabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
                  call srotg( B(i,j+1), B(i,j), cx, sx )
                  B(i,j) = zero
                  QG(1,Pindex) = cx
                  QG(2,Pindex) = sx
                  Gcol(Pindex) = j
                  Findex = Findex+1
                  Fcol(Findex) = step
c
c                 post multiply B by P
                  call srot( 2, B(step,j+1),1, B(step,j),1, cx, sx )
c
c                 compute F10
                  call stinvb( B(step+2,Bfree+2),ldb,q, 
     &                  A(step+2,step),lda,2, Iwork, Rwork, tol, infot)
c
                  IF (infot .NE. ok) then
                      ierr = 1
                      call sabort(A, lda, m1, n, step-1)
                      GOTO 3000
                  ENDIF
c
c                 compute A10 - B01*F10
                  i=step
                  j=Bfree+2
                  A(i,i) = A(i,i) - sdot(q, B(i,j),ldb, A(i+2,i),1)
                  A(i+1,i) = A(i+1,i) - sdot(q, B(i+1,j),ldb,
     &                                               A(i+2,i),1   )
                  A(i+1,i+1) = A(i+1,i+1) - sdot(q, B(i+1,j),ldb,
     &                                               A(i+2,i+1),1 )
                  A(i,i+1) = A(i,i+1) - sdot(q, B(i,j),ldb,
     &                                               A(i+2,i+1),1 )
c
                  step1 = step+1
                  IF ( (abs(B(step1,Bfree1)) .LT. tol) .OR.
     &                 (abs(A(step,step1)) .LT. tol)      ) then
                          ierr = 1
                          call sabort(A, lda, m1, n, step-1)
                          GOTO 3000
                  ENDIF
c
c                 compute f1'
                  IF ( ncmplx .GT. 0 ) then
                      lsum = l(step) + l(step)
                      lprod= l(step)*l(step) + l(step1)*l(step1)
                  ELSE
                      lsum = l(step) + l(step1)
                      lprod= l(step)*l(step1)
                  ENDIF
c
                  atmp = A(step,step)
c
                  f11 = ( (atmp*(atmp-lsum)+lprod)/A(step,step1) +
     &                    A(step1,step) ) / B(step1,Bfree1)
c                  
                  f12 = ( atmp+A(step1,step1)-lsum ) / B(step1,Bfree1)
c
c                 relocate computed columns of F into A(1:m,:)
                  IF (free .LT. step) then
c                     { free+2 < step+2 }
                      call scopy(q, A(step+2,step), 1, 
     &                                   A(free+2,step), 1)
                      call scopy(q, A(step+2,step1), 1, 
     &                                   A(free+2,step1), 1)
                  ELSE IF (free .GT. step) then
                      call scopy(q, A(step+2,step), -1, 
     &                                   A(free+2,step), -1)
                      call scopy(q, A(step+2,step1), -1, 
     &                                   A(free+2,step1), -1)
                  ENDIF
                  A(free1,step)=f11
                  A(free1,step1)=f12
                  call scopy(free, zero, 0, A(1,step), 1)
                  call scopy(free, zero, 0, A(1,step1), 1)
c
c                 end CASE r=2 with nn(1) = nn(2)+1   (s=1)
c
                ENDIF
c               (3b r=2 subcase s=0, or subcase s=1)
c
c               update for case r=2
                free = free+1
                free1 = free+1
                Bfree = Bfree+1
                Bfree1 = Bfree+1
c
             ENDIF
c            (case 3a or 3b)
c
c            updates for case 3
             status = status+2
             IF (ncmplx .GT. 0) ncmplx=ncmplx-2
             Gcol(Gindex) = -Gcol(Gindex)
             Hcol(Hindex) = -Hcol(Hindex)
             nn(r-1) = nn(r-1) - 1
             nn(r) = nn(r) - 1
             step = step+2
c
c            end CASE 3: cases (s=0) OR (s=1 and n even)
c
          ENDIF
c         (case 1 or 2 or 3)
c
          goto 200
      ENDIF
c     end do !while (step .LE. nm2)  (end deflationary loop)
c
c  FINAL ALLOCATIONS
c  *****************
c
      step1 = step+1
      free1 = free+1
      Bfree1 = Bfree+1
c
      IF (nn(2) .EQ. 0) then
c         case resulting k=1   # of inputs = # of states
c
          IF ( nn(1) .EQ. 2 ) then
c             nn = [2,0,...,0]  Two eigenvalues remaining
c
             IF (ncmplx .GT. 0) then
                A(step,step) = A(step,step)-l(step)
                A(step1,step) = A(step1,step)+l(step1)
                A(step1,step1) = A(step1,step1)-l(step)
                A(step,step1) = A(step,step1)-l(step1)
             ELSE
                A(step,step) = A(step,step)-l(step)
                A(step1,step1) = A(step1,step1)-l(step1)
             ENDIF
c
             call stinvb( B(step,Bfree1), ldb, nn(1),
     &             A(step,step), lda, 2, Iwork, Rwork, tol, infot )
c
             IF (infot .NE. ok) then
                 ierr = 1
                 call sabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate computed columns of F into A(1:m,:)
             IF (free1 .LT. step) then
                 call scopy(nn(1), A(step,step), 1, A(free1,step), 1)
                 call scopy(nn(1), A(step,step1), 1, A(free1,step1), 1)
             ELSE IF (free1 .GT. step) then
                 call scopy(nn(1), A(step,step),-1, A(free1,step),-1)
                 call scopy(nn(1), A(step,step1),-1, A(free1,step1),-1)
             ENDIF
                 call scopy(free, zero, 0, A(1,step), 1)
                 call scopy(free, zero, 0, A(1,step1), 1)
c
             status = status+2
             IF (ncmplx .GT. 0) then
                 ncmplx = ncmplx-2
             ENDIF
c
          ELSE IF ( nn(1) .eq. 1  .and.  ncmplx .eq. 0 ) then
c            nn = [1,0,...,0]
c            procede to allocate one real eigenvalue
c
             A(step,step)=A(step,step)-l(step)
             call stinvb( B(step,Bfree+1), ldb, nn(1), 
     &             A(step,step), lda, 1, Iwork, Rwork, tol, infot )
             IF (infot .NE. ok) then
                 ierr = 1
                 call sabort(A, lda, m1, n, step-1)
                 GOTO 3000
             ENDIF
c
c            relocate computed column of F into A(1:m,:)
             call scopy(free, zero, 0, A(1,step), 1)
c            A(m,n) = A(n,n)
             A(m1,step) = A(step,step)
c
             status = status+1
c
c         otherwise
c            nn = [1,0,...,0] with 2 complex eigenvalues to be allocated, or
c            nn = [0,0,...,0]  
c            In either case the system is uncontrollable and no more 
c            allocations are possible. (recall we use only real arithmetic)
c            this is taken care of later
c
          ENDIF
c         (end case k=1)
c
      ELSE
c
c         case resulting k=2   one input, two states
c         nn = [1,1,0,...,0]
c
          step1 = step+1
          IF ( ncmplx .GT. 0 ) then
              lsum = l(step) + l(step)
              lprod= l(step)*l(step) + l(step1)*l(step1)
          ELSE
              lsum = l(step) + l(step1)
              lprod= l(step)*l(step1)
          ENDIF
c
          IF ( (abs(B(step,Bfree+1)) .LT. tol) .OR.
     &         (abs(A(step1,step)) .LT. tol)      ) then
                 ierr = 1
                 call sabort(A, lda, m1, n, step-1)
                 GOTO 3000
          ENDIF
c
          atmp = A(step1,step1)
c
          f11 = ( A(step,step)+atmp-lsum ) / B(step,Bfree+1)
c
          f12 = ( (atmp*(atmp-lsum)+lprod)/A(step1,step)
     &                  + A(step,step1) ) / B(step,Bfree+1)
c
c         relocate last two columns of F
          call scopy( free, zero, 0, A(1,step), 1)
          call scopy( free, zero, 0, A(1,step1), 1)
          A(m1,n-1)=f11
          A(m1,n) = f12
c
          status = status+2
          IF (ncmplx .GT. 0) then
             ncmplx = ncmplx - 2
          ENDIF
c
c         (end case k=2)       
      ENDIF
c     (end final allocations)
c
c     check if there were more eigenvalues in the given data
c     in that case system is uncontrollable
c     (some possibilities are
c        nn = [1,0,...,0] with 2 complex eigenvalues to be allocated, or
c        nn = [0,0,...,0]  
c        In either case the system is uncontrollable and no more 
c        allocations are possible. (recall we use only real arithmetic)
      IF ( status .ne. n ) THEN
         ierr = 2
         call sabort(A, lda, m1, n, step)
         GOTO 3000
      ENDIF
c
c
c  BACK TRANSFORMATION
c  *******************
c
 3000 CONTINUE
c
c     Apply P
c     -------
c     do while (Pindex .LT. Pstart) 
 3050 IF (Pindex .LT. Pstart) then
c         Apply transpose of rotation stored in QG(1,Pindex) to
c         rows Gcol(Pindex), Gcol(Pindex)+1  from cols Fcol(Findex) to n
          i = Gcol(Pindex)
          j = Fcol(Findex)
          cx = QG(1,Pindex)
          sx = QG(2,Pindex)
          call srot(n, A(i+1,j), lda, A(i,j), lda, cx, -sx)
          Findex = Findex-1
          Pindex = Pindex+1
          GOTO 3050
      ENDIF
c     end do !while (Pindex .LT. Pstart) 
c
c  Apply Q-inverse
c  ---------------
c     do while (Gindex .NE. 0)
 3100 IF (Gindex .NE. 0) then
c 
c        1. Apply inverse Householders for one step
c
         IF ( Hcol(Hindex) .EQ. 0 ) then
c            ignore dummy Householder
             Hindex = Hindex-1
         ELSE
c            apply (inverse of) Householders for one step
             IF (Hcol(Hindex) .LT. 0)  Hcol(Hindex) = -Hcol(Hindex)
c            do while (Hcol(Hindex) .GT. 0)
 3200        IF ((Hindex .GT. 0) .AND.(Hcol(Hindex) .GT. 0)) then
                 DO 3250 k=1,m1
                    call shhrfl( A(k,Hcol(Hindex)), lda, QH(1,Hindex))
 3250            CONTINUE
                 Hindex = Hindex-1
                 GOTO 3200
             ENDIF
c            end do !while Hcol(Hindex) .GT. 0)
         ENDIF
c
c        2. Apply inverse Rotations for one step
c
         IF ( Gcol(Gindex) .EQ. 0 ) then
c            ignore dummy rotation
             Gindex = Gindex-1
         ELSE
c            transform
             IF (Gcol(Gindex) .LT. 0)  Gcol(Gindex) = -Gcol(Gindex)
c            do while (Gindex .GT. 0) .AND. (Gcol(Gindex) .GT. 0)
 3400        IF ((Gindex .GT. 0) .AND. (Gcol(Gindex) .GT. 0)) then
                 j = Gcol(Gindex)
                 cx = QG(1,Gindex)
                 sx = QG(2,Gindex)
                 call srot(m1, A(1,j+1), 1, A(1,j), 1, cx, -sx)
                 Gindex = Gindex-1
                 GOTO 3400
             ENDIF
c            end do !while (Gcol(Gindex) .GT. 0)
         ENDIF
c
      GOTO 3100
      ENDIF
c     end do !while (Gindex .NE. 0)
c
 9000 CONTINUE
c  Copy matrix F in array A to array F
      if (m .lt. n) then
         do 9050  j=1,n
             call scopy(m,A(1,j),1,F(1,j),1)
 9050    continue
      else
c        m is greater than n. First m-n rows will be zeros.
         m0 = m-n
         m1 = m-n+1
         do 9070  j=1,n
             call scopy(m0, zero,0, F(1,j),1)
             call scopy(n, A(1,j),1, F(m1,j),1)
 9070    continue
      end if
c
 9900 CONTINUE
c
c  TERMINATION
c  ***********
      info(1) = status
      info(2) = lnpos
      return
c
c ** last line of subroutine smvs1 **
      end
c==========================================================
c==========================================================
c
        subroutine sabort(A, lda, m, n, allocd)
c
c       Purpose
c       =======
c       To zero the sub-matrix of A contained in 
c       rows 1 to M, columns ALLOCD+1 to N
c       That is to set  A(I,J) = 0.0  whenever
c       I is in the set {1,..,M}  AND  J is in the set {ALLOCD+1,..,N}
c       
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c
c       A      REAL array of DIMENSION(LDA,N)
c              The leading M by N part of this array must contain
c              the matrix with elements to be zeroed.
c              Note: this array is overwritten.   (See Purpose)
c
c       LDA    INTEGER
c              Leading dimension of the array A, as declared in the
c              calling program.
c
c       M      INTEGER
c              The last row of A that will have elements set to zero
c              M .LE. LDA
c
c       N      INTEGER
c              The last column of matrix A that will have elements
c              set to zero.
c
c       ALLOCD INTEGER
c              The last column of matrix A that will NOT be changed, ie
c              columns 1 to ALLOCD are left unchanged.
c
c       Arguments Out
c       -------------
c
c       A      REAL array of DIMENSION(LDA,N)
c              The matrix A with  A(I,J)=0.0  whenever
c              I is in {1,...,M}  and  J is in {ALLOCD+1,...,N}
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       Successive calls to BLAS routine SCOPY overwrite, column by column,
c       the designated column elements with zero-vectors of length M
c
c       References
c       ==========
c       C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c       Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c       pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c
c  arguments
c       implicit none
        integer lda, m, n, allocd
        real A(lda,*)
c
c  parameters
        real   zero
        parameter (zero=0.0e0)
c  external subroutines
        external scopy
c
c  local variables
        integer j
c
        DO 100 j=allocd+1,n
            call scopy(m, zero, 0, A(1,j), 1)
  100   continue
c
        return
        end
c
c
c==========================================================
c==========================================================
c
      subroutine shhldr(x,incx,tol,v)
c
c       Purpose
c       =======
c       To compute 3-vector v, with v(3)=1.0, so that 
c       the Householder reflector H, where  H = I-2*v*v'/v'*v 
c       is such that for the given vector x, of dimension 3,
c       H*x = [0 0 -s]'
c       where  s = sign(x(3)) * norm2(x)
c       In addition
c           v'*v/2.0 is computed and returned in v(3)
c           v is contiguous in memory
c           x(i) is overwritten with zero, i=1,2
c           x(3) is overwritten with -s 
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       X      REAL array of DIMENSION (at least 3)
c              The 3 elements  X(1), X(1+INCX), X(1+2*INCX)
c              must contain the vector whose two leading elements
c              will be overwritten with zero when multiplied from
c              the left by the computed Householder.
c              Note: This array is overwritten.
c
c       INCX   The stride for elements of the vector X
c
c
c       Arguments Out
c       -------------
c
c       X      REAL array of DIMENSION (at least 3)
c              X(1) is overwritten with zero.
c              X(1+INCX) is overwritten with zero.
c              X(1+2*INCX) is overwritten with -s, where
c                          s = sign(x(3)) * norm2(x), where
c                          x = (X(1), X(1+INCX), X(1+2*INCX))'
c
c       V      REAL array of DIMENSION (at least 3)
c              v is computed so that v(3)=1.0 and, for the given vector x,
c              H*x = [0 0 -s]', where  H = I-2*v*v'/v'*v 
c              Instead of the known value 1.0, v'*v/2.0 is returned in V(3)
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       TOL    The magnitude below which matrix elements are
c              considered to be zero.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       sigma = sign(x(3))*norm2(x)
c       beta = x(3) + sigma
c       v(1)=x(1)/beta,  beta .ne. zero
c       v(2)=x(2)/beta,  beta .ne. zero
c       v(3)=1.0
c
c       References
c       ==========
c       Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, pp. 195-199.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c     implicit none
      integer  incx
      real x(*), v(*), tol
c
c  parameters
      real zero, one, two
      parameter (zero=0.0e0, one=1.0e0, two=2.0e0)
c
c  functions
      real snrm2
      external snrm2
      intrinsic sign
c
c  local variables
      integer inc1, inc2
      real nrmx, b, s
c
      nrmx = snrm2(3,x,incx)
      IF (nrmx .le. tol) then
             v(1)=zero
             v(2)=zero
             v(3)=zero
             x(1)=zero
             x(2)=zero
             x(3)= zero
             goto 999
c 
      else IF (incx .EQ. 1) then
             s = sign(nrmx, x(3))
             b = x(3) + s
             v(1)=x(1)/b
             v(2)=x(2)/b
             v(3) = (one-(x(3)-s)/b)/two
             x(1) = zero
             x(2) = zero
             x(3) = -s
c 
      else   
             inc1 = 1+incx
             inc2 = 1+2*incx
             s = sign(nrmx, x(inc2))
             b = x(inc2)+s
             v(1) = x(1)/b
             v(2) = x(inc1)/b
             v(3) = (one-(x(inc2)-s)/b)/two
             x(1) = zero
             x(inc1) = zero
             x(inc2) = -s
      endif
c 
  999 continue
      return
      end
c
c
c==========================================================
c==========================================================
c
      subroutine shhrfl(x,incx,v)
c
c       Purpose
c       =======
c       Overwrite x with H*x where 
c       H is the Householder reflector (I-2vv'/v'v), where
c       v is computed by subroutine DHHLDR (with v(3) restored to 1.0)
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       X      REAL array of DIMENSION (at least 3)
c              The 3-element vector x to be overwritten by H*x must 
c              be contained in X(1), X(1+INCX), X(1+2*INCX).
c              Note: This array is overwritten.
c
c       INCX   The stride for elements of the vector X
c
c       V      REAL array of DIMENSION (3)
c              A 3-element vector computed by DHHLDR
c
c
c       Arguments Out
c       -------------
c       X      REAL array of DIMENSION (at least 3)
c              Let
c              x = (X(1), X(1+INCX), X(1+2*INCX))' and y=H*x, 
c              where
c              H is the Householder reflector (I-2vv'/v'v), where
c                v is computed by subroutine SHHLDR, so that
c                v(3) is assumed equal to 1.0 and stores v'v/2.
c              Then
c              X(1) is overwritten with y(1).
c              X(1+INCX) is overwritten with y(2).
c              X(1+2*INCX) is overwritten with y(3).
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       x = (I-2vv'/v'v)x 
c         = x-2vv'x/v'v
c         = x-v'x(2v/v'v)
c
c       References
c       ==========
c       Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c       Johns Hopkins University Press, Baltimore, 1989, pp. 195-199.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c     implicit none
      integer  incx
      real x(*), v(*)
c
c  parameters
      real zero, one
      parameter (zero=0.0e0, one=1.0e0)
c
c  external functions
      real sdot
      external sdot
c
c  local variables
      real t,tmp
      integer inc1, inc2
c
c     don't do anything if the Householder was computed 
c     for a vector with norm less than tol
      if (v(3) .eq. zero) goto 999
c
c     otherwise...
      tmp = v(3)
      v(3) = one
      t = sdot(3,v,1,x,incx)/tmp
c
      IF (incx .EQ. 1) then
          x(1)=x(1)-t*v(1)
          x(2)=x(2)-t*v(2)
          x(3)=x(3)-t
      else
          inc1 = 1+incx
          inc2 = 1+2*incx
          x(1) = x(1)-t*v(1)
          x(inc1) = x(inc1)-t*v(2)
          x(inc2) = x(inc2)-t
      endif
c 
      v(3) = tmp
c
  999 continue
      return
      end
c
c
c==========================================================
c==========================================================
c
      subroutine stinvb( T,ldt,n, B,ldb,p, Iwork, Rwork, tol,infot )
c
c     Purpose
c     =======
c     Overwrite B (NxP) with solution to TX=B where T (NxN) is
c     upper triangular.  If T is numerically singular then no
c     attempt is made to compute X.
c
c     Arguments in
c     ============
c
c     T      REAL array of DIMENSION (LDT,N)
c            The matrix T must occupy the leading N rows by N columns 
c            of the array T
c
c     LDT    INTEGER
c            row dimension of array T, as declared in the calling program
c
c     N      INTEGER        
c            row and column dimension of matrix T
c            row dimension of matrix B
c            N .LE. LDT
c
c     B      REAL array of DIMENSION (LDB,P)
c            the matrix B must occupy the leading N rows by P columns of 
c            the array T
c
c     LDB    INTEGER
c            row dimension of array B, as declared in the calling program
c
c     P      INTEGER
c            column dimension of matrix B
c
c     Arguments Out
c     -------------
c
c     B      REAL array of DIMENSION (LDB,P)
c            leading N rows by P columns contains solution X of TX=B,
c            if T is nonsingular. Otherwise, B is unchanged from B on entry.
c
c     IWORK  INTEGER array of DIMENSION (N)  
c            work space required for condition estimator
c
c     RWORK  REAL array of DIMENSION (3*N)
c            work space required for condition estimator
c
c     Tolerances
c     ----------
c     TOL    REAL
c            Matrix elements with magnitude < TOL are considered zero
c
c     Warning Indicator
c     -----------------
c     INFOT  INTEGER
c            Unless T is non-singular "to working precision", 
c            INFOT contains 0 on exit
c
c     Error Indicator
c     ---------------
c     None.
c
c
c     Warnings and Errors detected by the routine
c     ===========================================
c     INFOT > 0 :  T is non-singular to working precision.
c
c     Method
c     ======
c     The LApack routine STRCON is used to obtain a condition estimate for T
c     If the system is estimated to be "sufficiently well conditioned", the
c     right hand side matrix is solved column by column via repeated calls
c     to the LApack routine STRTRS
c
c     References
c     ==========
c     Coleman, T.F. and Van Loan, C.F., Handbook for Matrix Computations,
c     SIAM, Philadelphia, 1988, pp. 144-145.
c
c     Contributors
c     ============
c     G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c     Revisions
c     =========
c     1994 Feb 03
c
c  ARGUMENTS
c     implicit none
      integer ldt, n, ldb, p, Iwork(*), infot
      real T(ldt,*), B(ldb,*), Rwork(*), tol
c
c  EXTERNAL SUBPROGRAMS
      external strtrs, strcon
c
c  LOCAL VARIABLES
      real rcond
c
      call strcon( '1', 'U', 'N', n, T, ldt, rcond, Rwork, Iwork, infot)
c
      IF (rcond .lt. tol) then
           infot = 1
      ELSE IF (n .eq. 1 .and. abs(T(1,1)) .le. tol) then
           infot = 1
      ELSE
           infot = 0
           call strtrs( 'U', 'N', 'N', n, p, T, ldt, B, ldb, infot )
      ENDIF
      return
      end
c
c
c==========================================================
c==========================================================
c
        real function s1nrmU( U, ldu, n)
c
c       Purpose
c       =======
c       To compute 1-norm of order N upper-triangular matrix U
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       U      REAL array of DIMENSION (LDU,N)
c              The leading N by N part of this array must contain
c              the upper triangular matrix U.
c              Elements outside the upper triangular part of matrix U
c              are not referenced.
c
c       LDU    INTEGER
c              Leading dimension of the array U, as declared in the
c              calling program.
c
c       N      INTEGER
c              Order of the matrix U.
c
c       Arguments Out
c       -------------
c       None.
c       The FUNCTION returns the 1-norm of the matrix U.
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       The 1-norm of the upper triangular part of each column is 
c       computed using BLAS routine SASUM. The maximum of these
c       is returned as the matrix 1-norm.
c
c       References
c       ==========
c       1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c          Johns Hopkins University Press, Baltimore, 1989, pp. 53-57.
c
c       2. C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c          Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c          pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c  arguments
c       implicit none
        integer ldu, n
        real U(ldu,*)
c
c    local variables
        integer j
        real tnrm
c
c    external functions blas sasum
        real sasum
        external sasum
c
c    intrinsic functions
        intrinsic max
c
        tnrm = U(1,1)
        DO 100 j=2,n
            tnrm = max( sasum(j,U(1,j),1), tnrm )
  100   CONTINUE
c
        s1nrmU = tnrm
c
        return
        end
c
c
c==========================================================
c==========================================================
c
        real function s1nrmA( A, lda, n )
c
c       Purpose
c       =======
c       To compute 1-norm of order N general matrix A
c
c       Argument List
c       =============
c
c       Arguments In
c       ------------
c       A      REAL array of DIMENSION (LDA,N)
c              The leading N by N part of this array must contain
c              the matrix A.
c
c       LDA    INTEGER
c              Leading dimension of the array A, as declared in the
c              calling program.
c
c       N      INTEGER
c              Order of the matrix A.
c
c       Arguments Out
c       -------------
c       None.
c       The FUNCTION returns the 1-norm of the matrix A.
c
c       Workspace
c       ---------
c       None.
c
c       Tolerances
c       ----------
c       None.
c
c       Warning Indicator
c       -----------------
c       None.
c
c       Error Indicator
c       ---------------
c       None.
c
c
c       Warnings and Errors detected by the routine
c       ===========================================
c       None.
c
c       Method
c       ======
c       The 1-norm of of each column of A is computed using 
c       BLAS routine SASUM. The maximum of these is returned
c       as the matrix 1-norm.
c
c       References
c       ==========
c       1. Golub, G.H. and Van Loan, C.F., Matrix Computations, 2-nd ed.,
c          Johns Hopkins University Press, Baltimore, 1989, pp. 53-57.
c
c       2. C. Lawson, R. Hanson, D. Kincaid, F. Krogh, "Basic Linear Algebra
c          Subprograms for Fortran Usage", ACM Trans. Math. Soft., v5 (1979),
c          pages 308-323.
c
c       Contributors
c       ============
c       G. Miminis, H. Roth  (Memorial University of Newfoundland, Canada)
c       
c       Revisions
c       =========
c       1994 Feb 03
c
c    arguments
c       implicit none
        integer lda, n
        real A(lda,*)
c
c    local variables
        integer j
        real tnrm
c
c    external functions blas sasum
        real sasum
        external sasum
c
c    intrinsic functions
        intrinsic max
c
        tnrm = sasum( n, A(1,1), 1 )
        DO 100 j=2,n
            tnrm = max( sasum(n,A(1,j),1), tnrm )
  100   CONTINUE
c
        s1nrmA = tnrm
c
        return
        end
C*** sstair.f
c
c FILE: sstair.f
c
c  == ==================================================================
c
        subroutine sstair(n,m, A,lda, B,ldb, kmax, kstair,
     &                    itrnsf, rtrnsf, iwork, rwork,
     &                    tol, iwarn, ierr)
c
c  == ==================================================================
c
c    Purpose
c    =======
c
c    To transform real matrices A and B such that the system (B,A) 
c    is in "upper staircase" (or "controllability") form, with
c    staircase blocks in upper triangular form.
c    This routine is a driver for sstr1.
c
c
c    Argument List
c    =============
c
c    Arguments In
c    ------------
c
c    N      INTEGER.
c           Row and column dimension of matrix A,
c           row dimension of matrix B,
c           N .ge. 1
c
c    M      INTEGER.
c           Column dimension of matrix B.
c           M .ge. 1
c
c    A      REAL array of DIMENSION (LDA,N).
c           The leading N by N part of this array must contain the 
c           real matrix A that is to be converted to upper staircase form.
c           Note: this array is overwritten.
c
c    LDA    INTEGER.
c           Row dimension of array A, as declared in the calling program
c           LDA .ge. N
c
c    B      REAL array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the
c           real matrix B that is to be converted to upper staircase form.
c           Note: this array is overwritten.
c
c    LDB    INTEGER.
c           Row dimension of array B, as declared in the calling program
c           LDB .ge. N.
c
c
c    Arguments Out
c    -------------
c
c    A      REAL array of DIMENSION (LDA,N).
c           The leading N by N part of this array contains the converted 
c           staircase form of the given matrix A.
c
c    B      REAL array of DIMENSION (LDB,M).
c           The leading N by M part of this array contains the converted 
c           staircase form of the given matrix B.
c
c    Kmax   INTEGER.
c           The number of staircase blocks.
c
c    Kstair INTEGER array of DIMENSION (N+1).
c           This array stores the ranks of the staircase blocks of the
c           system [B,A].
c           Kstair(Kmax+1) is set to zero.
c
c    Itrnsf INTEGER array of Dimension (max(M,N)(M+1)/2 + M+2N+3)
c           This array contains integer information pertaining to the
c           transformations performed on A and B, as required for SBKTRN.
c
c    Rtrnsf REAL array of Dimension (max(M,N)(M+1)/2 + N(N+1)/2)
c           This array contains floating point information pertaining to the
c           transformations performed on A and B, as required for SBKTRN.
c
c
c    Work Space
c    ----------
c
c    Iwork  INTEGER array of DIMENSION (N*4)
c
c    Rwork  REAL array of DIMENSION (N*2)
c
c
c    Tolerances
c    ----------
c
c    TOL    REAL .
c           Matrix elements with magnitudes less than TOL are considered zero.
c           If on entry TOL is less than the relative machine precision "eps",
c           it is reset to
c           TOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
c
c
c    Warning Indicator
c    -----------------
c
c    IWARN  INTEGER.
c           Unless a staircase block has rank zero, IWARN contains 0 on exit. 
c           (See Warnings and Errors below).
c
c
c    Error Indicator
c    ---------------
c
c    Ierr   INTEGER
c           Unless the routine detects an error (see next section),
c           Ierr contains 0 on exit.
c
c
c    Warnings and Errors detected by the Routine
c    ===========================================
c
c    Iwarn = 1  The rank of B or the rank of a staircase block of A is 0.
c               The system is therefore uncontrollable.
c
c    IERR < 0   IERR = -j indicates a problem with the j-th argument
c               on entry.  Specifically:
c               IERR = -1   On entry,  N < 1
c               IERR = -2   On entry,  M < 1
c               IERR = -4   On entry,  LDA < N
c               IERR = -6   On entry,  LDB < N
c
c
c    Method
c    ======
c
c    Compute orthogonal transformations T and U so that
c
c              [B1,A1] = T'[B,A]|U |
c                               | T|
c
c    is in upper staircase form.
c
c    References
c    ==========
c
c    G.S. Miminis and C.C.Paige, 'An algorithm for pole assignment of
c    time-invariant multi-input linear systems', Proc. 21st IEEE Conf.
c    on Decision and Control, Orlando, Florida, V.1, pp. 62-67, 1982.
c
c    Contributors
c    ============
c
c    R. Bouzane, G. Miminis, H. Roth
c    (Memorial University of Newfoundland, Canada)
c
c    Revisions
c    =========
c
c    1994 Feb 03
c
c
c       implicit none
        integer           n, m, lda, ldb
        real              A(lda, *), B(ldb, *)
        integer           kmax, kstair(*), itrnsf(*), iwork(*)
        real              rtrnsf(*), rwork(*), tol
        integer           iwarn, ierr

        external          sstr1

c  initialize
        iwarn = 0
        ierr  = 0
c
c  check some input arguments
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, A, lda, B, ldb, 
c         kmax, kstair, itrnsf, rtrnsf, iwork, rwork, tol, iwarn, ierr)
      IF( ldb .lt. n ) ierr = -6
      IF( lda .lt. n ) ierr = -4
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  Partition itrnsf, rtrnsf
c     Arot   starts at itrnsf(1)         has length 1
c     Brot   starts at itrnsf(2)         has length 1
c     Mcol   starts at itrnsf(3)         has length m+n+1
c     Cnum   starts at itrnsf(m+n+4)     has length n
c     Pos    starts at itrnsf(m+2n+4)    has length (max(m,n))(m+1)/2
c
c     Hhold  goes into rtrnsf(1)           has length n(n+1)/2
c     CosSin goes into rtrnsf(1+n(n+1)/2)  has length (max(m,n))(m+1)/2
c
c  do the job
      call sstr1(n,m, A,lda, B,ldb, kmax,kstair, itrnsf(1),
     &           itrnsf(2), itrnsf(3), itrnsf(m+n+4),
     &           itrnsf(m+2*n+4), rtrnsf(1), rtrnsf(1+n*(n+1)/2),
     &           Iwork, Rwork, tol, iwarn)
c
c  make sure kstair(kmax+1) = 0:
      kstair(kmax+1)=0
c
 9000 continue
      return
c     last line of subroutine sstair follows
      end
c
C  == ==================================================================
C
        subroutine sstr1(n,m,A,lda,B,ldb,kmax,ranks,Arot,Brot,
     &                    Mcol,Cnum,Pos,Hhold,CosSin,Swork,
     &                    Vwork,Utol,Error)

C  == ==================================================================
C
C    Purpose
C    =======
C
C    To transform real matrices A and B such that the system (B,A)
C    is in "upper staircase" (or "controllability") form, with
C    staircase blocks in upper triangular form.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER.
C           Row and column dimension of matrix A,
C           row dimension of matrix B,
C           N .ge. 1
C
C    M      INTEGER.
C           Column dimension of matrix B.
C           M .ge. 1
C
C    A      REAL array of DIMENSION (LDA,N).
C           The leading N by N part of this array must contain the
C           real matrix A that is to be converted to upper staircase form.
C           Note: this array is overwritten.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    B      REAL array of DIMENSION (LDB,M).
c           The leading N by M part of this array must contain the
c           real matrix B that is to be converted to upper staircase form.
C           Note: this array is overwritten.
C
C    LDB    INTEGER.
C           Row dimension of array B, as declared in the calling program
C           LDB .ge. N.
C
C
C    Arguments Out
C    -------------
C
C    A      REAL array of DIMENSION (LDA,N).
C           The leading N by N part of this array contains the converted 
C           staircase form of the given matrix A.
C
C    B      REAL array of DIMENSION (LDB,M).
C           The leading N by M part of this array contains the converted 
C           staircase form of the given matrix B.
C
C    Kmax   INTEGER.
C           The number of staircase blocks.
C
C    Ranks  INTEGER array of DIMENSION (N+1).
C           This array stores the ranks of the staircase blocks of [B,A].
C           Ranks(kmax+1)=0.
C
C    Arot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix A.
C
C    Brot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix B.
C
C    Mcol   INTEGER array of DIMENSION (M+N+1).
C           The leading N+M part of this array contains the order of the 
C           column pivoting.
C
C    Cnum   INTEGER array of DIMENSION (N).
C           This array stores the Householders sizes for the Householder
C           vectors.
C
C    Pos    INTEGER array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the positions of the rotations on
C           A and B.
C
C    Hhold  REAL array of DIMENSION (N(N+1)/2).
C           This array stores the Householder vectors applied on A
C           and B.
C
C    CosSin REAL array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the values used in the rotations on
C           A and B.
C
C
C    Work Space
C    ----------
C
C    Swork  INTEGER array of DIMENSION (N*4)
C
C    Vwork  REAL array of DIMENSION (N*2)
C
C
c    Tolerances
c    ----------
c
c    UTOL    REAL .
c           Matrix elements with magnitudes less than UTOL are considered zero.
c           If on entry UTOL is less than the relative machine precision "eps",
c           it is reset to
c           UTOL = (M+N)*||(B,A)||*eps
c                                   where ||.|| denotes the one-norm.
c           See LAPACK routine DLAMCH for details re "eps".
C
C
C    Error Indicator
C    ---------------
C
C    Error  INTEGER
C           Unless the routine detects an error (see next section),
C           Error contains 0 on exit.
C
C
C    Errors detected by the Routine
C    ==============================
C
C    Error = 1  The rank of B or the rank of a subblock of A
C               is 0.  If this happens,  the system is uncontrollable.
C
C
C    Method
C    ======
C
C    Compute orthogonal transformations T and U so that
C
C              [B1,A1] = T'[B,A]|U |
C                               | T|
C
C    is in upper staircase form.
C    Store the transformations in factored form.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n, m, lda, ldb, Error, Kmax
        real A(lda, *), B(ldb, *), CosSin(*)
        real Vwork(*), Hhold(*), mu
        real cx, sx, eps, tol, Utol
        integer Swork(*), Ranks(*)
        integer Pos(*), Cnum(*), Mcol(*)
        integer crow, nrank, endcol, sn,sm,offset
        integer i, j, k, nextcl, rank, col,bm
        integer hh, cc, begin, pc, row,ccol
        integer brank, pp, Arot, Brot, nopre
C
C       External procedures that will be used in this procedure.
        real slamch
        real sonorm
        integer scnorm
        external scnorm, slamch, sonorm
        external srot, srotg, sswap
C
        pp = 1
        pc = 1
        hh = 1
        cc = 1
        Kmax = 1
        Error = 0
        rank = 0
        mu = 0.0d0
C
C       Calculate tolerance
        eps = slamch('E')
        if (Utol .lt. eps) then
            tol = sonorm(n, m, A, lda, B, ldb)
            tol = tol*eps
            Utol = tol
        end if
C
        bm = m
        do 30 j = 1, bm
C
C       Do column pivoting and store to apply to F.
            nextcl = scnorm(j, m, B, ldb, n, j)
            Mcol(j) = nextcl
            if (nextcl .ne. j) then
                call sswap(n, B(1,j), 1, B(1,nextcl), 1)
                Mcol(j+1) = 0
            end if
C
C       This procedure calculates the house holder vector Vwork for the 
C       column starting from B(rank+1, j) down to B(n-rank, j).
C
            call shh(B(rank+1, j), 1, Vwork, n-rank, mu, Utol)
C
C       Store house vector so it can be used on F later
C
            nopre = 1
            do 26 i = 2, n-rank
                if (abs(Vwork(i)) .ge. Utol) then
                    nopre = 0
                end if
26          continue
            if ((nopre .lt. 1) .and. (mu .ge. Utol)) then
                do 20 i = 2, n-rank
                    Hhold(hh) = Vwork(i)
                    hh = hh + 1
20              continue
                Cnum(cc) = n-rank-1
                cc = cc + 1
C
C       Do pre-multipication on B starting at position (rank+1, rank+1)
C
                call sprehh(B,ldb,n,m,Vwork,Vwork(n+1),rank+1,rank+1)
C
C       Do pre-multiplication and post-multiplication on A starting 
C       at position (rank+1, rank+1)
C
                call sprehh(A,lda,n,n,Vwork,Vwork(n+1),rank+1,1)
                call spthh(A,lda,n,n,Vwork,Vwork(n+1),1,rank+1)
            end if
C
C       Check to see if rank needs to be updated.  If diagonal is 0.
            if (abs(B(rank+1,j)) .gt. Utol) then
                rank = rank + 1
            end if
30      continue
        if (rank .eq. 0) then
            Error = 1
            goto 9000
        endif
        brank = rank
        Ranks(Kmax) = rank
        Kmax = Kmax + 1
C
C       Do house holders on (if any) elements of matrix A
        crow = rank+1
        col = 1
        endcol = rank
C
C       This is a while loop to process rows in A.
1000    if (crow .gt. n) goto 2000
            nrank = 0
            begin = crow
            do 60 j = col, endcol
                nextcl = scnorm(j, endcol, A, lda, n, crow)
                Mcol(j+m) = nextcl
                if (nextcl .ne. j) then
C
C       Must swap the columns and rows of A,  the rows of B, and 
C       the columns of F.
C
                    call sswap(n, A(1,j), 1, A(1,nextcl), 1)
                    call sswap(n, A(j,1), lda, A(nextcl, 1), lda)
                    call sswap(m, B(j,1), ldb, B(nextcl, 1), ldb)
                    Mcol(j+m+1) = 0
                end if
C
C       This procedure calculates the house holder vector Vwork for the 
C       column starting from A(crow,j) down to A(n-crow+1, j)
                call shh(A(crow, j), 1, Vwork, n-crow+1, mu, Utol)
C
C       Store house vector so it can be used on F later
C
                nopre = 1
                do 56 i = 2,  n-crow+1
                    if (abs(Vwork(i)) .ge. Utol) then
                        nopre = 0
                    end if
56              continue
                if ((nopre .lt. 1) .and. (mu .ge. Utol)) then
                    do 50 i = 2,  n-crow+1
                        Hhold(hh) = Vwork(i)
                        hh = hh + 1
50                  continue
                    Cnum(cc) = n-crow
                    cc = cc + 1
C
C       Do pre and post multiplication on matrix A.
                    if (Cnum(cc-1) .ne. 0) then
                        call sprehh(A,lda,n,n,Vwork,Vwork(n+1),crow,j)
                        call spthh(A,lda,n,n,Vwork,Vwork(n+1),1,crow)
                    endif
                end if
C
                if (abs(A(crow, j)) .gt. Utol) then 
                    nrank = nrank + 1
                    crow = crow + 1
                    if (crow .gt. n) then
C
C       Saving sub-matrix for rotations
                        Swork(pc) = begin
                        Swork(pc+1) = col
                        Swork(pc+2) = rank
                        Swork(pc+3) = nrank
                        pc = pc + 4
                        if (rank .eq. 0) then
                            Error = 1
                            goto 2000
                        endif
                        Ranks(Kmax) = nrank
                        Kmax = Kmax + 1
                        goto 2000
                    end if
                end if
60          continue
C
C       Saving sub-matrix for rotations
            Swork(pc) = begin
            Swork(pc+1) = col
            Swork(pc+2) = rank
            Swork(pc+3) = nrank
            pc = pc + 4
            Ranks(Kmax) = nrank
            Kmax = Kmax + 1
            col = col + rank
            rank = nrank
            if (rank .eq. 0) then
                Error = 1
                goto 2000
            endif
            endcol = endcol + rank
        goto 1000
C
C       Do rotations on all sub blocks on matrix A.
2000    pc = pc - 1
        Cnum(cc) = 0
        Ranks(Kmax) = 0
        Kmax = Kmax - 1
        do 90 k = pc, 2, -4
C
C       Poping sub-matrix off the stack
            sm = Swork(k)
            sn = Swork(k-1)
            col = Swork(k-2)
            row = Swork(k-3)
            offset = 1
            do 80 i = row+sm-1, row, -1
                ccol = col+sn-offset
                do 70 j = col, ccol-1
                    if (abs(A(i, j)) .gt. Utol) then
C
C       Find values for the rotations
                        call srotg(A(i, ccol), A(i, j), cx, sx)
                        A(i, j) = 0.0
C
C       Apply the rotations to row and columns of A and rows of B
                        call srot(i-1,A(1, ccol),1,A(1, j),1, cx, sx)
                        call srot(n,A(ccol,1),lda,A(j, 1),lda,cx,sx)
                        call srot(m,B(ccol,1),ldb,B(j, 1),ldb,cx, sx)
                        Pos(pp) = ccol
                        Pos(pp+1) = j
                        CosSin(pp) = cx
                        CosSin(pp+1) = sx
                        pp = pp + 2
                    end if
70              continue
                offset = offset + 1
80          continue
90      continue
C
        row = 1
        col = 1
        sn = m
        sm = brank
C
        Arot = pp
        offset = 1
        do 110 i = row+sm-1, row, -1
            ccol = col+sn-offset
            do 100 j = col, ccol-1
                if (abs(B(i, j)) .gt. Utol) then
C
C       Calculate the rotations needed in B
                    call srotg(B(i, ccol), B(i, j), cx, sx)
                    B(i, j) = 0.0
C
C       Apply the rotation on B
                    call srot(i-1, B(1, ccol), 1, B(1, j), 1, cx, sx)
                    Pos(pp) = ccol
                    Pos(pp+1) = j
                    CosSin(pp) = cx
                    CosSin(pp+1) = sx
                    pp = pp + 2
                end if
100         continue
            offset = offset + 1
110     continue
        Brot = pp
C                
9000    return
C
        end
C
C
C==== =================================================================
C
        subroutine sbktrn(n,m,F,ldf,itrnsf, rtrnsf, rwork, ierr)
C
C==== =================================================================
C
C    Purpose
C    =======
C
C    To compute matrix F from F1 = U'FT as computed by DMEVAS, where T and U
C    are computed by DSTAIR.
C    This routine is a driver for sbktr1.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER
C           Column dimension of matrix F
C           N .ge. 1
C
C    M      INTEGER
C           Row dimension of matrix F
C           M .ge. 1
C
C    F      REAL array of DIMENSION (LDF, N)
C           The leading M by N part of this array must contain the matrix F1.
C           Note: this array is overwritten.
C
C    LDF    INTEGER
C           Row dimension of array F, as declared in the calling program
C           LDF .ge. M
C
C    Itrnsf INTEGER array of Dimension (max(M,N)(M+1)/2 + M+2N+3)
C           This array contains integer information pertaining to the
C           transformations performed on A and B, as computed by SSTAIR.
C
C    Rtrnsf REAL array of Dimension (max(M,N)(M+1)/2 + N(N+1)/2)
C           This array contains floating point information pertaining to the
C           transformations performed on A and B, as computed by SSTAIR.
C
C
C    Arguments Out
C    -------------
C
C    F      REAL array of DIMENSION (LDF, N)
C           The leading M by N part of this array contains the matrix F.
C
C
C    Work Space
C    ----------
C
C    Rwork  REAL array of DIMENSION (N*2)
C
C
c    Error Indicator
C    ---------------
C
C    Ierr   INTEGER
C           Unless the routine detects an error (see next section),
C           Ierr contains 0 on exit.
C
C
C    Errors detected by the Routine
C    ==============================
C
C    IERR < 0   IERR = -j indicates a problem with the j-th argument
C               on entry.  Specifically:
C               IERR = -1   On entry,  N < 1
C               IERR = -2   On entry,  M < 1
C               IERR = -4   On entry,  LDF < M
C
C    Method
C    ======
C
C    Compute F = U*F1*T' using the factored form of the orthogonal
C    transformations U and T computed by DSTAIR, where F1 is the output
C    from DMEVAS.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer           n, m, ldf
        real              F(ldf, *), rtrnsf(*), rwork(*)
        integer           itrnsf(*), ierr
c
c  external subroutines
c       external sbktr1
c
c  initialize
        ierr  = 0
c
c  check some input arguments
c  ==========================
c  set ierr = -k if we find a problem with the k-th argument
c  the arguments are
c     (n, m, F, ldf, itrnsf, rtrnsf, rwork, ierr)
      IF( ldf .lt. m ) ierr = -4
      IF( m .lt. 1 ) ierr = -2
      IF( n .lt. 1 ) ierr = -1
c
c  That's all we can check.  Quick return if we found a problem
      IF( ierr .lt. 0 ) GOTO 9000
c
c  Partition itrnsf, rtrnsf
c     Arot   goes into itrnsf(1)               (length 1)
c     Brot   goes into itrnsf(2)               (length 1)
c     Mcol   goes into itrnsf(3:2+m+n+1)       (length m+n+1
c     Cnum   goes into itrnsf(m+n+4:m+n+3+n)   (length n)
c     Pos    goes into itrnsf(m+2n+4:end)      (length max(m,n)(m+1)/2)
c
c     Hhold  goes into rtrnsf(1:n(n+1)/2)      (length n(n+1)/2)
c     CosSin goes into rtrnsf(1+n(n+1)/2)      (length max(m,n)(m+1)/2)
c
c  do the job
      call sbktr1(n,m, F,ldf, itrnsf(1), itrnsf(2), itrnsf(3),
     &            itrnsf(m+n+4), itrnsf(m+2*n+4), rtrnsf(1),
     &            rtrnsf(1+n*(n+1)/2), Rwork)
c
 9000   continue
        return
C       last line of sbktrn follows
        end
C
C==== =================================================================
C
        subroutine sbktr1(n,m,F,ldf, Arot, Brot, Mcol, Cnum, Pos,
     &                   Hhold, CosSin, Vwork)
C
C==== =================================================================
C
C    Purpose
C    =======
C
C    To compute matrix F from F1 = U'FT as computed by DMEVAS, where T and U
C    are computed by DSTAIR.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    N      INTEGER
C           Column dimension of matrix F
C           N .ge. 1
C
C    M      INTEGER
C           Row dimension of matrix F
C           M .ge. 1
C
C    F      REAL array of DIMENSION (LDF, N)
C           The leading M by N part of this array must contain the matrix F1.
C           Note: this array is overwritten.
C
C    LDF    INTEGER
C           Row dimension of array F, as declared in the calling program
C           LDF .ge. M
C
C    Arot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix A, as computed by sstr1.
C
C    Brot   INTEGER
C           Stores the position in array CosSin of the last rotation
C           done in matrix B, as computed by sstr1.
C
C    Mcol   INTEGER array of DIMENSION (M+N).
C           The leading N+M part of this array contains the order of the 
C           column pivoting, as computed by sstr1.
C
C    Cnum   INTEGER array of DIMENSION (N).
C           This array stores the Householders sizes for the Householder
C           vectors, as computed by sstr1.
C
C    Pos    INTEGER array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the positions of the rotations on
C           A and B, as computed by sstr1.
C
C    Hhold  REAL array of DIMENSION (N(N+1)/2).
C           This array stores the Householder vectors applied on A
C           and B, as computed by sstr1.
C
C    CosSin REAL array of DIMENSION ((M+1)*max(M,N)/2)
C           This array stores the values used in the rotations on
C           A and B, as computed by sstr1.
C
C
C    Arguments Out
C    -------------
C
C    F      REAL array of DIMENSION (LDF, N)
C           The leading M by N part of this array contains the matrix F
C
C    Work Space
C    ----------
C
C    Vwork  REAL array of DIMENSION (N*2)
C
C    Method
C    ======
C
C    Compute F = U*F1*T' using the factored form of the orthogonal
C    transformations U and T computed by DSTAIR, where F1 is the output
C    from DMEVAS.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n, m, ldf
        real F(ldf,*), Hhold(*)
        real Vwork(*), CosSin(*)
        real sx, cx
        integer Mcol(*), Cnum(*), Pos(*)
        integer i, cc, hh, num
        integer Arot, Brot
C
C       A list of all external functions used in this subroutine
        external srot, scopy, sswap
C
C       Do all rotations (in reverse order) done on matrix B
C       Doing the transpose of the rotations in reverse order.
C
        do 505 i = Brot-1, Arot, -2
            sx = CosSin(i)
            cx = CosSin(i-1)
            call srot(n, F(Pos(i-1),1), ldf, F(Pos(i),1),ldf,cx, -sx)
505     continue
C
C       Do all rotations (in reverse order) done on matrix B
        do 160 i = Arot-1, 2, -2
            sx = CosSin(i)
            cx = CosSin(i-1)
            call srot(m, F(1,Pos(i-1)),1, F(1, Pos(i)),1,cx, -sx)
160     continue
C
C       Find the end of the Cnum array and Hhold array.
        cc = 1
        hh = 0
171     if (Cnum(cc) .eq. 0) goto 131
            hh = hh + Cnum(cc)
            cc = cc + 1
            goto 171
131     num = 1
141     if (Mcol(num) .eq. 0) goto 271
            num = num + 1
            goto 141
271     cc = cc - 1
        num = num - 1
        do 281 i = num, cc+1, -1
            if (i .gt. m) then
                call sswap(m, F(1, i-m), 1, F(1, Mcol(i)), 1)
            else
                call sswap(n, F(i, 1), ldf, F(Mcol(i),1), ldf)
            endif
281     continue
        do 191 i = cc, 1, -1
C
C       Extract the Householder vector
            Vwork(1) = 1.0
            call scopy(Cnum(i), Hhold(hh-Cnum(i)+1), 1, Vwork(2), 1)
C
C       Apply the house holder vector
            call spthh(F,ldf,m,n,Vwork,Vwork(n+1),1,n-Cnum(i))
C
C       If i is greater than m the do the pivot done
C       in A.  Else do the pivot done in B.
            if (i .gt. m) then
                call sswap(m, F(1, i-m), 1, F(1, Mcol(i)), 1)
            else
                call sswap(n, F(i, 1), ldf, F(Mcol(i),1), ldf)
            endif
C
C       Update the start of the next house holder vector.
            hh = hh - Cnum(i)
191     continue
C
        return 
C
        end
C
C
C==== ============================================================
        subroutine shh(X, incx, V, N, mu, tol)
C
C    Purpose
C    =======
C
C    This computes a Householder Vector V from the given vector X.
C    Given the N-vector x, this subroutine computes N-vector v
C    with v(1) = 1 such that  (I - 2vv'/v'v)x  is zero in all 
C    but the first component.  (Here v' is v transposed).
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    X      REAL array of DIMENSION (N)
C           The given vector.  The householder vector is computed 
C           from this vector.
C
C    incx   INTEGER 
C           The stride for the vector X.
C
C    N      INTEGER
C           The number of array elements to use in computing the
C           householder vector.
C
C    tol    REAL 
C           The tolerance.
C
C    Arguments Out
C    -------------
C
C    V      REAL array of DIMENSION (N)
C           This stores the computed householder vector.
C
C    mu     REAL 
C           The two norm of the given vector.
C
C    Method
C    ======
C
C    Given an N-vector x, this subroutine computes an N-vector
C    V with V(1) = 1 such that (I - 2vv'/v'v)x is zero in all 
C    but the first component.  (Here v' is v transposed).
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer N, incx
        real X(*), V(*)
        real mu, beta, tol
        integer i
C
        real snrm2
        external snrm2, scopy
C
C       Compute the 2 norm of column X
        mu = snrm2(N, X, incx)
C
C       Copy column X into column V
        call scopy(N, X, incx, V, 1)
C
        V(1) = 1.0
C
C       Calculate householder vector V
        if (mu .ge. tol) then
            if (X(1) .lt. 0.0) then
                beta = X(1) - mu
            else
                beta = X(1) + mu
            end if
C
            do 16 i = 2, N
                V(i) = V(i)/beta
16          continue
        end if
C
        return
C
        end
C
C==== =============================================================
C
        subroutine sprehh(A, lda, N, M, V, W, StartN, StartM)
C        
C    Purpose
C    =======
C
C    To do pre-multiplication with the householder vector compute in
C    subroutine shh() on a matrix A
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    A      REAL array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that is premultiplied by the reflector determined by vector V.
C
C    lda    INTEGER
C           The leading dimension of array A.
C
C    N      INTEGER
C           Row dimension of matrix A.
C           N .gt. 1
C
C    M      INTEGER
C           Column dimension of matrix A.
C           M .gt. 1
C
C    V      REAL array of DIMENSION (N-StartN)
C           This is the householder vector calculated in subroutine
C           shh().
C
C    StartN INTEGER
C           What row of the matrix to start applying the householder vector.
C           StartN .gt 1 .and. StartN .le. N
C
C    StartM INTEGER
C           What column of the matrix to start applying the householder vector.
C           StartM .gt 1 .and. StartM .le. M
C    
C    Arguments Out
C    -------------
C
C    A      REAL array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that was changed by vector V.
C
C    Work Space
C    ----------
C
C    W      REAL array of DIMENSION (N)
C
C    Method
C    ======
C
C    Given an N by M matrix A and a nonzero m-vector V with V(1) = 1,
C    the following algorithm overwrites A with PA where P=I-2VV'/V'V.
C    Where V' is V transposed.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer lda, N, M, StartN, StartM
        real A(lda, *), V(*), W(*)
        real beta
        integer i,j, k
C
C
C       External functions used in this procedure.
C
        real sdot
        external sdot
C
C       Calculate Beta -> beta = -2/v'v
        beta = sdot(N-StartN+1, V, 1, V, 1)
        beta = -2/beta
C
C       Calculate W -> W = Beta * a'v
        do 36 i = StartM, M
           W(i) = 0.0
           k = 1
           do 26 j = StartN, N
               W(i) = W(i) + A(j,i)*V(k)
               k = k + 1
26         continue
           W(i) = W(i)*beta
36      continue
C
C        Re-calculate A -> A = A + vw'
C
        k = 1
        do 56 i = StartN, N
            do 46 j = StartM, M
                A(i, j) = A(i,j) + W(j)*V(k)
46          continue
            k = k + 1
56       continue
C                    
        return
C
        end
C
C
C==== =============================================================
C
        subroutine spthh(A, lda, N, M, V, W, StartN, StartM)
C
C    Purpose
C    =======
C
C    To do post-multiplication on matrix A using the householder
C    vector V.
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    A      REAL array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that is postmultiplied by the reflector determined by vector V.
C
C    lda    INTEGER
C           The leading dimension of array A.
C
C    N      INTEGER
C           Row dimension of matrix A.
C           N .gt. 1
C
C    M      INTEGER
C           Column dimension of matrix A.
C           M .gt. 1
C
C    V      REAL array of DIMENSION (M-StartM)
C           This is the householder vector calculated in subroutine
C           shh().
C
C    StartN INTEGER
C           What row of the matrix to start applying the householder vector.
C           StartN .gt 1 .and. StartN .le. N
C
C    StartM INTEGER
C           What column of the matrix to start applying the householder vector.
C           StartM .gt 1 .and. StartM .le. M
C    
C    Arguments Out
C    -------------
C
C    A      REAL array of DIMENSION (LDA, M)
C           The leading N by M part of this array is the real matrix 
C           that was changed by vector V.
C
C    Work Space
C    ----------
C
C    W      REAL array of DIMENSION (N)
C
C
C    Method
C    ======
C
C    Given an N by M matrix A and an N-vector V with V(1) = 1, the 
C    following algorithm overwrites A with AP where P=I-2VV'/V'V.
C    Where V' is V transposed.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C
C       implicit none
        integer lda, N, M, StartN, StartM
        real A(lda, *), V(*), W(*)
        real beta
        integer i,j, k
C
C        External functions used in this procedure.
        real sdot
        external sdot
C
C       Calculate Beta -> beta = -2/v'v
        beta = sdot(M-StartM+1, V, 1, V, 1)
        beta = -2/beta
C
C       Calculate W -> W = Beta * AV
        do 76 i = StartN, N
           W(i) = 0.0
           k = 1
           do 66 j = StartM, M
               W(i) = W(i) + A(i,j)*V(k)
               k = k + 1
66          continue
           W(i) = W(i)*beta
76      continue
C
C       Re-calculate A -> A = A + wv'
        do 96 i = StartN, N
            k = 1
            do 86 j = StartM, M
                A(i, j) = A(i,j) + W(i)*V(k)
                k = k + 1
86          continue
96       continue
C                    
        return
C
        end
C
C
C==== =============================================================
C
        integer function scnorm(Begin, End, A, lda, n, Row)
C
C    Purpose
C    =======
C
C    Find the next column with with the highest norm.
C    The next column is between (and including) Begin and End.
C
C
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C
C    Begin  INTEGER
C           What column to start finding the highest norm.
C
C    End    INTEGER
C           What column to stop looking for the highest norm.
C
C    A      REAL array of DIMENSION (LDA,*).
C           The leading N by * part of this array is the real matrix A.
C           This is used to find the next column.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    N      INTEGER.
C           Row dimension of matrix A,
C           N .ge. 1
C
C    Row    INTEGER
C           Start at this row when calculating the norm.
C
C    Arguments Out
C    -------------
C
C    dcnrom INTEGER
C           This will be the column with the highest norm.
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer lda, Begin, End, n, Row
        real A(lda, *)
C
        real mu, great
        integer i
C
        real snrm2
        external snrm2
C
        scnorm = Begin
        great = 0.0
C
        do 21 i = Begin, End
            mu = snrm2(n-Row+1, A(Row,i), 1)
            if (mu .gt. great) then
                great = mu
                scnorm = i
            end if
21      continue
C
        return 
C
        end
C
C
C==== =============================================================
C
        real function sonorm(n, m, A, lda, B, ldb)
C
C    Purpose
C    =======
C
C    To find the greatest one norm of matrix (B,A).  That is
C    sum all the columns in B and A, the one with the largest
C    sum is the one norm.  The sum must be with absolute values.
C        
C    Argument List
C    =============
C
C    Arguments In
C    ------------
C    
C    N      INTEGER.
C           Row and column dimension of matrix A,
C           N .ge. 1
C
C    M      INTEGER.
C           Column dimension of matrix B.
C           M .ge. 1
C
C    A      REAL array of DIMENSION (LDA,N).
C           The leading N by N part of this array must contain the matrix A.
C
C    LDA    INTEGER.
C           Row dimension of array A, as declared in the calling program
C           LDA .ge. N
C
C    B      REAL array of DIMENSION (LDB,M).
C           The leading N by M part of this array must contain the matrix B.
C
C    LDB    INTEGER.
C           Row dimension of array B, as declared in the calling program
C           LDB .ge. N
C
C    Contributors
C    ============
C
C    R. Bouzane, G. Miminis, H. Roth
C    (Memorial University of Newfoundland, Canada)
C
C    Revisions
C    =========
C
C    1994 Feb 03
C
C
C       implicit none
        integer n,m, lda, ldb
        real A(lda, *), B(ldb, *)
        real sum
        integer i, j
C
        sonorm = 0.0
        do 41 j = 1, m
            sum = 0.0
            do 31 i = 1, n
                sum = sum + abs(B(i, j))
31          continue
            if (sum .gt. sonorm) then
                sonorm = sum
            end if
41      continue
C
C       Sum columns in Matrix A
        do 61 j = 1, n
            sum = 0.0
            do 51 i = 1, n
                sum = sum + abs(A(i, j))
51          continue
            if (sum .gt. sonorm) then
                sonorm = sum
            end if
61      continue
C
        return 
C
        end
C*** test.doc

TEST DATA FOR DEMONSTRATION PROGRAM

The parameters in the demonstration program allow systems up to n=40, m=20.
In that set
    max g = 211 occurs for n=40, m=20
    max h = 401 occurs for n=40, m= 1


GROUP 1

This group illustrates eigenvalue assignments in systems with n>m

test01.dat     n=11 > m=7  rank(B)=7 = m   
               illustrates: initial immediate allocations (3);
                            cases r>2
                            r=2 with n1=n2
                            final allocations with nn = 1,1,0,...

test02.dat     n=11 > m=4  rank(B)=4 = m    
               illustrates: cases r>2
                            r=2 with n1=n2
                            n1=n2+1 with n odd (immediate single allocation
                                    in deflation loop)
                            final allocations with nn = 2,0,...

test03.dat     n=13 > m=3  rank(B)=3 = m
               illustrates: cases r>2
                            r=2 with n1=n2
                            final allocations with nn = 1,0,...

test04.dat     n=19 > m=6  rank(B)=6 = m
               illustrates: cases r>2
                            r=2 with n1=n2
                            n1=n2+1 with n odd (immediate single)
                            n1=n2+2 (immediate double allocation in deflation loop)
                            final allocations with nn = 1,1,0,...
                                       
test05.dat     n=8 > m=4   rank(B)=4 = m
               illustrates case r=2 with n1=n2+1, i.e. some subdiagonal blocks
                                of A have less than full row rank

test06.dat     n=9 > m=8   rank(B)=8 = m
               illustrates n-2 initial immediate allocations followed by
                               two final allocations, thus skipping deflation
                               loop

test07.dat     n=8 > m=4   rank(B)=3 < m
               illustrates the computation when B has a leading column of zeros

test08.dat     n=8   m=1   rank(B)=1 = m
               illustrates the special case of a single-input system


GROUP 2

This group demonstrates allocations in systems with m=n, m>n

test09.dat     m=n =8   rank(B)=8 = n

test10.dat     m=n =8   rank(B)=7 < n   
               thus B has 8-7 = 1 leading column of zeros


test11.dat     m=12 > n=8  rank(B)=8 = n

test12.dat     m=12 > n=8  rank(B)=6 < n   
               thus B has 12-6 = 6 leading columns of zeros



GROUP 3

This group demonstrates partial allocation with uncontrollable systems

test13.dat     n=6 > m=3  rank(B)=3 = m
               illustrates abort after four of six allocations

test14.dat     n=7   m=3  rank(B)=3 = m
               illustrates abort after 6 allocations

test15.dat     n=8   m=4  rank(B)=4 = m
               First sub-diagonal block of A is rank deficient, having
                     rank =3 <m. Gives rise to allocation case r=0 with n1=n2+1,
                     as in test05.dat
               System aborts after 7 allocations  (3 complex pairs, 1 real)

test16.dat     same as test15.dat except here we have eight complex 
                     eigenvalues, i.e. lcmplx=8. 
               System aborts after 6 allocations, unable to allocate a
                     single complex eigenvalue using only real arithmetic.

test17.dat     n=11  m=4  rank(B)=4 = m
               illustrates abort after 8 allocations



GROUP 4

This group demonstrates performance under extremes.
The matrices have the general form

        A = | -1  -1  -1  ...  -1  -1  N   |       B = | 1 |
            |  1  -1  -1  ...  -1  -1  N-1 |           | 0 |
            |      1  -1  ...  -1  -1  N-2 |           | 0 |
            |          1  ...  -1  -1  N-3 |           | 0 |
            |             :::   :   :  :   |           | : |
            |               1  -1  -1  3   |           | 0 |
            |                   1  -1  2   |           | 0 |
            |                       1  1   |           | 0 |

(cf. ref 1 below).
The eigenvalues to be assigned to (A-B*F) are chosen to be the eigenvalues
of A. Choosing to assign the eigenvalues of  A  gives  F=0,  since the
systems have one input. We may therefore test the accuracy of our solution.
The above choice however has the following peculiarity. Although some tests
report that some of the eigenvalues have not been assigned, when the
eigenvalues of  (A-B*F) are computed the unassigned eigenvalues are among
those of (A-B*F). This is obviously due to the choice of the eigenvalues
specified for assignment.

The term "relative distance" (say D), refers to the distance of a scaled 
system (so that  0 <= D <= 1 )  from the nearest uncontrollable system
(see ref. 2 below). Tests 18, 19 below involve systems with  D < 10e(-16).
That is they are both very nearly uncontrollable systems.

test18.dat    n=30   m=1
              The condition number of the eigenproblem for A 
              is computed to be  2.5864e+04.

test19.dat    n=40   m=1
              The condition number of the eigenproblem for A 
              is computed to be  8.2836e+05.

References for group 4
1. Golub, G. H. and Van Loan, C. F., Matrix Computations (second edition),
   Johns Hopkins University Press, 1989.  Section 5.5.7, p245.
2. Christian, S. M., Determining the Distance of a Linear System from the
   Nearest Uncontrollable System, Honours Thesis, Dept. of Comp. Sci.,
   Memorial University of Newfoundland, 1990.
   A matlab code for the computation of the distance is available from
   G. Miminis.


GROUP 5

This group consists of only one example, the only example where the system
is not in staircase form.

test20.dat     n=8 > m=3  rank(B)=3 = m

C*** test01.dat
FILE: test01.dat
   test01
   11
   7
   0.0e0

  -2.9678e-01  -4.3576e-01  -3.2877e-01   6.1042e-01  -1.6927e-01  -3.6111e-01   1.4569e-01  -5.8990e-02   2.7649e-01  -6.7780e-01  -2.0902e-01
  -9.6028e-02   4.7129e-01  -1.9225e-01   1.9613e-01   8.1291e-02  -1.2616e-01   1.5379e-01   1.4415e-01  -2.7210e-01   4.3933e-01  -1.1873e-01
   4.2656e-01  -1.9293e-01   1.0465e+00  -2.6243e-01  -1.8381e+00  -4.6527e-01   1.8093e+00  -2.1342e-01  -2.2466e-01   3.2876e-01  -1.9535e-01
  -9.5377e-02   3.4075e-01  -9.7173e-02   5.4993e-01  -4.2683e-01  -2.2421e-01  -2.1530e-01  -2.7775e-01   1.2539e-01  -8.7744e-02  -1.2254e-02
  -1.3532e-01   1.8560e-01  -1.3594e+00   1.3743e-01   1.8406e+00   8.6196e-01  -2.4059e+00   3.9087e-01  -8.6333e-02  -1.1531e-01  -3.1209e-01
   1.8630e-01  -3.1522e-01  -2.0883e-01  -9.0074e-02   1.0537e+00   6.2183e-01  -4.7698e-01  -5.1639e-01  -2.7965e-01  -2.7795e-01   8.5221e-02
  -4.7841e-01   1.4244e-01   1.4733e+00  -7.3882e-02  -1.9081e+00  -6.7747e-01   2.1629e+00  -2.1038e-01  -3.5137e-01  -6.7513e-01   1.9520e-01
   0.0000e+00   0.0000e+00   0.0000e+00   9.9160e-01  -2.0218e-01  -1.8622e-01  -4.9077e-01  -5.8666e-02  -1.1673e-01   3.9999e-01   7.2167e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   8.3831e-01  -5.6032e-02   6.8239e-02  -5.0798e-02  -3.7522e-02   6.8750e-01  -1.7090e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   7.4801e-01   2.0585e-02   7.1705e-03   2.3151e-01  -2.3622e-01  -2.3976e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   4.2622e-01   5.0730e-02   1.3762e-01  -7.6825e-02  -3.7750e-01

  -8.1355e-01  -2.7747e-01   1.8919e-01  -4.4460e-02  -2.3133e-01   2.5506e-01   1.9457e-01
   0.0000e+00  -4.3295e-01   1.2423e-01  -7.1469e-01  -3.8698e-01  -2.5144e-01  -1.3187e-01
   0.0000e+00   0.0000e+00   1.0354e+00   5.9065e-01   4.1681e-01  -8.4900e-01  -1.8522e+00
   0.0000e+00   0.0000e+00   0.0000e+00   5.9433e-01   1.4133e-01   1.8796e-02  -3.9218e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.8254e-01   7.8151e-02   2.4970e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   7.5009e-01   6.9228e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.1303e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   9.5441e-01
   8.5127e-01
   2.8932e-01
   5.3743e-01
   5.1443e-01
   1.0343e-01
   4.1403e-01
   5.7672e-01
   8.7657e-01
   4.4004e-01
   7.2975e-01

   6

   2
   7
   4
   0
C*** test02.dat
FILE: test02.dat
   test02
   11
   4
   0.0e0

   5.2288e-01  -4.3210e-01  -2.3327e-01  -2.0400e+00  -5.2059e-01  -7.9287e-02  -5.7692e-01   6.2213e-01   1.8409e-01   5.5273e-01  -1.0203e-01
   1.0071e-01   4.4451e-01   1.1595e-01   1.1167e+00  -1.0699e-02  -5.3444e-02   7.1376e-02   2.7699e-02  -1.9800e-01   1.5233e-01  -4.8015e-01
   5.8848e-01  -2.3494e-01   7.0573e-02  -1.8483e-01  -5.7797e-01  -8.1669e-03   6.2597e-01  -8.3920e-02  -4.4601e-01   4.0800e-01   2.4982e-01
  -1.8102e+00   1.4413e+00  -6.0526e-01   4.2499e+00   7.9629e-01   2.4094e-01   1.4879e-01  -4.9520e-01   3.8537e-01  -5.2755e-02   2.9614e-01
  -1.5946e-01  -3.1611e-02  -2.9825e-01   8.4013e-01   4.4191e-02   2.3847e-01   6.6773e-01  -2.1610e-01  -1.4784e-01  -6.7419e-01  -7.7187e-01
   0.0000e+00   6.7186e-01  -1.8392e-01   6.7797e-02  -1.6652e-01  -3.7422e-01  -1.6928e-01  -9.8742e-02   3.9233e-01  -4.1975e-01  -1.2146e-01
   0.0000e+00   0.0000e+00   8.2362e-01   5.4477e-01   8.1134e-03   3.0379e-01  -3.1392e-02   1.0449e-01   4.6911e-03   1.2993e-01   4.0013e-01
   0.0000e+00   0.0000e+00   0.0000e+00  -5.1263e-01   7.2441e-03  -5.6254e-02  -5.5940e-01   1.6259e-01  -4.9478e-01  -1.0234e-01   1.9650e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.8241e-01  -1.3311e-01   6.4344e-02   2.1045e-01  -2.8217e-01   6.9507e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   4.5397e-01  -2.3280e-02  -4.4512e-01   2.4522e-01   6.1899e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   3.5411e-01  -1.4637e-01  -3.0886e-01   1.4166e-01

  -1.0093e+00   1.0225e-01   1.3621e-01   1.0378e+00
   0.0000e+00  -1.3007e+00   6.4916e-02  -6.0424e-01
   0.0000e+00   0.0000e+00  -5.0297e-01  -2.3038e-02
   0.0000e+00   0.0000e+00   0.0000e+00  -3.0093e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   1.3119e-01
   8.8565e-01
   9.2174e-02
   1.6220e-01
   7.1064e-02
   3.6534e-01
   2.5306e-01
   1.3511e-01
   7.8315e-01
   4.5531e-01
   3.4952e-01

   6

   3
   4
   4
   3
   0
C*** test03.dat
FILE: test03.dat
   test03
   13
   3
   0.0e0

   2.3415e-01  -6.6611e-01  -8.7832e-01   1.3619e-01   4.3923e-01   2.4279e-02  -2.9354e-01  -1.2244e-01  -1.9227e-01   3.4121e-01   1.4515e-01  -2.1743e-01  -2.6382e-01
   9.7808e-02   1.1042e+00  -2.0577e+00   2.8344e-01   1.1934e-01   1.8189e-01   3.6319e-01  -3.4409e-01  -2.9572e-01   6.0404e-01  -1.6510e-01   3.1831e-01  -5.5275e-01
  -5.2408e-01  -2.4428e+00   5.2279e+00   1.1067e-01  -7.3673e-01  -3.1753e-01   3.6492e-01   1.2967e-01  -2.0171e-01  -8.9844e-01  -5.1353e-02  -3.6011e-02   3.5325e-02
   9.3706e-01  -3.0286e-01  -1.2097e-01  -1.0101e-01  -2.9720e-01  -1.7781e-01   2.3605e-01  -1.8264e-01   8.7159e-02  -1.0584e-01   3.4630e-01   1.5167e-01  -5.1277e-01
   0.0000e+00   8.9476e-01  -4.9862e-01   4.5625e-01   4.9667e-01   2.2624e-01  -2.3633e-01  -1.0635e-01  -1.5540e-01   6.6287e-02   1.8679e-01  -8.8530e-02  -4.9241e-01
   0.0000e+00   0.0000e+00  -1.4845e+00  -6.1167e-02   1.1742e-01  -5.3122e-01   2.9341e-03  -2.1408e-01   1.1803e-01  -1.5822e-01  -2.6706e-01   2.5816e-01   1.4231e-01
   0.0000e+00   0.0000e+00   0.0000e+00   6.4996e-01  -3.5179e-01   2.0265e-01  -1.0783e-01   1.7451e-01   2.6213e-01   2.1533e-01  -2.5791e-01  -4.4896e-02  -3.1415e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.0929e-01  -4.5080e-01  -2.6695e-01   2.6869e-02   3.6370e-01  -1.0283e+00   3.7078e-01  -1.4969e-02  -2.6529e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -6.7154e-01   3.6526e-01  -4.2067e-03   2.5588e-01  -4.3894e-02   1.7405e-01  -5.6865e-01  -1.1892e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.3271e-01  -2.4714e-01   1.4341e-01  -2.2630e-01  -2.8559e-01   9.7551e-02   7.6443e-03
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -2.9676e-01  -5.4455e-02  -1.2384e-01  -7.0215e-01  -1.4147e-01  -2.0397e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   4.5951e-01   1.2187e-01  -1.0459e-01  -3.0439e-01  -1.8346e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   6.5230e-01   1.1987e-01

  -7.8188e-01   2.9838e-01   4.8720e-01
   0.0000e+00  -1.2058e+00   1.5100e+00
   0.0000e+00   0.0000e+00  -3.3081e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00

   7.2975e-01
   8.6926e-01
   7.1564e-01
   8.0072e-01
   7.0654e-01
   7.4172e-01
   1.9092e-02
   8.8603e-01
   5.2499e-01
   4.6332e-01
   6.5194e-02
   7.1342e-01
   4.8894e-01

   6

   5
   3
   3
   3
   3
   1
   0
C*** test04.dat
FILE: test04.dat
   test04
   19
   6
   0.0e0

  -1.1818e-01   6.3163e-01   3.3572e-03   1.8710e-01   2.9895e-02  -8.3503e-02   4.5592e-01  -2.6052e-02  -5.4255e-01   2.4890e-01  -1.1515e-01   1.3171e-01   1.3483e-01  -1.7824e-02   4.4157e-01   3.8503e-01   4.3691e-01   4.7194e-01   1.4446e-01
   1.0195e-01   8.0336e-03  -2.1579e-01   2.0052e-01  -3.9038e-02   6.4059e-01  -9.1996e-02  -2.6074e-01  -3.7009e-01  -5.5530e-01   4.8861e-01  -4.2764e-01   1.2634e-01  -2.9921e-02   2.2844e-01   1.8809e-01   6.5870e-01  -7.9379e-02  -1.9266e-01
   2.6819e-01  -2.3875e-01   4.3931e-01  -2.8176e-01   2.8183e-01  -1.0356e-01   4.7916e-01  -7.3135e-01   2.4661e-01  -7.4514e-02   4.2250e-01   4.2982e-01  -3.3500e-01  -1.9389e-01   1.1509e-01  -6.3803e-02   3.3539e-01  -1.0929e-01  -5.6176e-01
   1.3247e-01  -1.7954e-01   7.0272e-02   1.0537e+00   2.0998e+00  -2.8618e+00   5.8078e-01  -1.9158e-01  -1.0942e-02   1.5626e-01  -3.5872e-01  -9.3053e-02   2.0093e-01   6.2251e-02   1.9645e-01   1.2079e-01  -9.3162e-02   1.5492e-01   1.1902e-01
   2.8727e-01  -3.3560e-01   4.5037e-01   1.7720e+00   2.0957e+00  -3.8883e+00   5.4668e-01   2.2811e-01  -1.0435e-01   7.9100e-01  -8.2959e-01  -3.3912e-02  -1.8420e-01   3.8683e-01   3.5968e-01   1.0507e+00   1.3831e-01  -1.9996e-01   3.2215e-01
  -5.8152e-01   1.2027e-01  -3.6038e-01  -2.0106e+00  -3.4495e+00   5.5591e+00  -3.1162e-01   2.6302e-01   6.6298e-01  -1.0403e+00   8.7447e-01  -6.3545e-01   4.6587e-01  -1.6402e-01  -1.4457e-01  -3.9232e-01   5.3618e-01  -8.4941e-03  -5.1350e-01
   8.7281e-01  -1.0159e-01   2.3583e-02   2.1336e-01   1.7050e-01  -5.1732e-02  -1.3499e-01  -6.2460e-01   1.6041e-01  -7.3318e-02  -3.0030e-01   5.4415e-01  -3.5739e-01   1.4467e-01   7.7711e-02   2.9695e-01   3.8543e-02  -2.3684e-01   2.8348e-01
   0.0000e+00  -9.2845e-01   4.5340e-01   9.5033e-02   1.0305e-01  -8.6812e-03  -3.2628e-01   3.0984e-02  -4.8929e-01  -3.1313e-01  -2.6413e-01  -5.2039e-01   6.9440e-02   6.7992e-02  -4.9331e-01  -6.4400e-01  -6.6424e-02   1.6073e-01   2.5596e-01
   0.0000e+00   0.0000e+00   6.0493e-01  -1.5937e-01   3.7835e-02   4.3270e-01  -2.4601e-01   1.6667e-01  -1.4660e-01  -6.3924e-02   4.4769e-01  -4.3328e-01   8.4137e-03  -9.4444e-03   7.5061e-02  -2.1597e-01   1.1044e-01   4.8764e-02   1.2092e-01
   0.0000e+00   0.0000e+00   0.0000e+00   1.2734e+00   5.1841e-01  -1.1480e+00   2.6505e-02  -4.3702e-01  -2.1112e-01   3.7256e-01  -4.1628e-02   1.0866e-01  -1.9720e-01  -1.9509e-02  -9.8340e-02   2.8573e-01   4.0056e-01  -2.4951e-01  -7.1235e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.6693e-01   1.1760e+00  -4.0098e-01  -6.9142e-02  -1.1935e-01  -2.0445e-01   4.3961e-01   1.5831e-01  -4.8005e-01   1.4228e-01  -1.2873e-01  -3.9844e-01   1.7741e-01  -1.3529e-02   5.9659e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.6450e+00  -2.1470e-01  -3.0510e-02   5.7621e-02  -2.5324e-01   1.4509e-01   2.1658e-02  -2.1492e-01  -1.0037e-02   1.5623e-01  -3.7865e-01  -1.2583e-01   1.3646e-01  -2.6256e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -2.0901e-01  -3.2899e-01   6.0668e-02  -1.6801e-01   1.2498e-01  -9.8926e-02  -8.3362e-02   6.5805e-01  -5.0438e-01  -3.3351e-01  -1.8683e-02   3.1261e-02   1.7991e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.0168e-01   7.2505e-02  -1.6278e-01   6.5224e-01   5.2810e-02  -1.2273e-01   2.6931e-01  -3.5071e-01  -1.4759e-01   1.8028e-01   1.7844e-01   5.3130e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   8.0861e-01  -8.9996e-02  -1.9423e-02   3.7730e-01   2.9360e-01   1.1254e-01  -4.2941e-01   2.8501e-01  -1.4630e-01  -1.7625e-01   2.9819e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.5901e-01   6.6437e-04   1.9117e-01  -2.2575e-01  -7.6123e-02   1.8893e-01  -1.6717e-02   8.2930e-02   2.7565e-01  -3.5331e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -7.3792e-01  -1.3057e-02  -3.0235e-02   4.2448e-01   6.3813e-02  -1.8076e-01   8.3235e-01   4.7756e-01   4.5729e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   5.0066e-01   1.9080e-02   1.1299e-01   1.2067e-01   5.0656e-02  -4.3844e-01  -9.9554e-02  -1.0699e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -6.5779e-01   8.4204e-02

  -7.7996e-01   9.3559e-02  -3.0616e-01   6.6047e-01   4.2056e-02   1.8478e-01
   0.0000e+00   1.1084e+00  -3.5512e-01  -4.8637e-02   6.4653e-02  -1.7736e-01
   0.0000e+00   0.0000e+00   1.1381e+00   1.2042e-01   1.6127e-01  -3.8181e-02
   0.0000e+00   0.0000e+00   0.0000e+00   1.3179e+00   4.1554e-01   1.7823e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   1.4749e+00   2.3535e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -4.1150e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   1.2364e-01
   9.7335e-01
   2.9635e-02
   8.0353e-02
   4.9424e-01
   7.6944e-01
   9.3403e-01
   2.5016e-01
   3.5966e-01
   7.6911e-01
   4.9996e-01
   7.4925e-01
   6.7190e-01
   6.8167e-01
   7.5677e-01
   3.6368e-02
   2.3057e-01
   2.2167e-01
   5.6260e-01

   2

   4
   6
   6
   6
   1
   0
C*** test05.dat
FILE: test05.dat
   test05
   8
   4
   0.0

   1.1652e+00  -8.0509e-02   5.7365e-01  -1.7382e+00   5.3462e-01   4.5954e-02   5.9128e-01   1.4119e-01
  -1.8734e-02   3.6403e-01  -1.0776e-01  -2.6897e-01  -5.5196e-01   4.4734e-03   3.5772e-01   7.0020e-01
   1.2115e+00   4.1112e-02   1.0863e+00  -1.3381e+00   2.0427e-01   4.3403e-01   2.0830e-01   2.6899e-01
  -1.7610e+00  -3.6044e-01  -1.1561e+00   1.6339e+00  -6.6672e-02  -1.7707e-01  -4.1364e-01  -7.3337e-01
   0.0000e+00  -2.1755e-01   6.0266e-01   7.7004e-03  -2.9116e-01   6.6811e-01   3.6965e-03   6.6128e-02
   0.0000e+00   0.0000e+00   6.4787e-01  -6.4446e-01   1.0295e-01  -4.6592e-01   9.0618e-02   1.7450e-01
   0.0000e+00   0.0000e+00   0.0000e+00  -5.8440e-01  -1.2314e-03   1.2238e-01   4.6610e-01  -2.7841e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -4.4623e-01   2.6422e-01

   4.1257e-01  -7.1166e-02  -3.3406e-01  -1.6773e+00
   0.0000e+00  -8.4157e-01   4.7752e-02   5.8467e-02
   0.0000e+00   0.0000e+00  -1.1324e+00  -1.5809e+00
   0.0000e+00   0.0000e+00   0.0000e+00   2.1144e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   4.6792e-01
   2.8721e-01
   1.7833e-01
   1.5372e-01
   5.7165e-01
   8.0241e-01
   3.3054e-02
   5.3445e-01

   2

   3
   4
   3
   1
   0
C*** test06.dat
FILE: test06.dat
   test06
   9
   8
   0.0

  -1.7504e-01   6.7297e-02   2.6862e-01   2.5047e-02  -1.7169e-01   1.4055e-01   6.2919e-01  -4.0489e-01  -5.6197e-02
  -2.3162e-01  -3.5858e-01   8.9973e-02   1.3880e-01   2.0550e-02   1.8244e-01   1.1194e-01  -1.0537e-02  -1.6847e-01
  -1.7370e-01   6.3431e-01   1.9527e+00   2.4905e-01  -4.2999e-01   1.7697e-01   1.1627e+00   1.8443e+00   2.3758e-01
  -2.5288e-01   4.1336e-01   3.0027e-01   3.6778e-01  -4.2960e-02  -1.1900e-01   4.8056e-01   5.5468e-01  -2.6664e-01
  -4.0515e-01  -5.1499e-01  -1.0620e+00  -1.9846e-01  -1.2909e-01  -4.2372e-01  -1.7133e-01  -2.6833e-01   4.4144e-01
   8.3629e-01   4.2871e-01  -1.9488e-01   2.2326e-01  -3.8877e-01  -4.3007e-01   5.5699e-01  -5.9676e-02   1.0063e-01
   1.3962e-02  -2.6379e-02   9.2544e-01   1.3877e-01  -9.3246e-03   1.1551e-01   1.4682e+00   1.1047e+00  -1.4802e-03
   1.1204e-01  -1.3305e-01   1.7525e+00   4.8448e-01  -7.5984e-01   1.7680e-01   1.3234e+00   1.5373e+00   1.1858e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -8.2981e-01  -8.0219e-01

   4.0961e-01  -2.9411e-01  -3.0791e-02  -4.9208e-02  -4.6880e-02   9.9540e-02   5.7227e-01  -6.0726e-02
   0.0000e+00   9.1944e-01   3.6930e-01  -9.5659e-02  -1.5380e-01  -7.0388e-01   1.1559e-01   6.5268e-02 0.0000e+00   0.0000e+00  -6.0756e-01  -5.6127e-01  -1.3551e-01   2.6557e-01  -6.0461e-01   2.8623e+00
   0.0000e+00   0.0000e+00   0.0000e+00  -7.7815e-01   3.2349e-01  -2.2707e-01   6.5616e-03   4.5671e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   5.8752e-01   2.3816e-01   6.3307e-02  -5.4958e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   5.8639e-01  -2.5505e-01   3.3556e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.0460e-01   1.6050e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   2.4116e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   6.2163e-01
   8.0307e-01
   2.4784e-01
   4.7643e-01
   3.8931e-01
   2.0325e-01
   2.8375e-02
   9.0167e-01
   4.2650e-01

   2

   2
   8
   1
   0
C*** test07.dat
FILE: test07.dat
   test07
   8
   4
   0.0

   5.6392e-01   6.4772e-01  -8.6309e-02   2.9546e-01  -1.7572e-01   3.2404e-01  -5.6451e-02   1.8628e-01
   1.2286e+00   3.4545e+00  -7.9074e-01   4.1360e-01  -9.5597e-01   6.2643e-01   1.7136e-01  -2.0121e-01
  -2.3450e-01  -8.2472e-01   6.4445e-01   7.3392e-01   3.9850e-02  -2.0126e-01   4.5446e-01  -2.7422e-01
   5.9614e-01  -4.3820e-01   1.4521e-01  -5.8877e-02   9.2204e-02   3.6082e-02  -2.4306e-01   1.0808e-01
   0.0000e+00  -9.6402e-01   1.5953e-01  -1.7955e-01   1.5410e-01  -7.0082e-02  -9.9585e-02  -2.2052e-01
   0.0000e+00   0.0000e+00  -4.3168e-01  -1.4238e-01  -5.8048e-02  -2.5504e-01   9.6957e-02  -7.5734e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   7.2491e-01   2.9800e-01   3.5137e-01  -4.1184e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -2.4509e-01  -1.7871e-01  -6.3171e-01

   0.0000e+00  -6.7460e-01   3.5619e-01  -8.9351e-02
   0.0000e+00   0.0000e+00   2.0329e+00   1.6817e+00
   0.0000e+00   0.0000e+00   0.0000e+00  -9.9587e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   4.6792e-01
   2.8721e-01
   1.7833e-01
   1.5372e-01
   5.7165e-01
   8.0241e-01
   3.3054e-02
   5.3445e-01

   4

   3
   3
   3
   2
   0
C*** test08.dat
FILE: test08.dat
   test08
   7
   1
   0.0

   2.7533e+00   1.6016e+00  -3.5728e-02  -3.6522e-01  -2.9759e-01  -1.9169e-01   9.3521e-01
   1.6917e+00   5.3902e-01  -3.1721e-01   1.8576e-01   3.8002e-01  -2.6292e-01   1.3211e-02
   0.0000e+00   5.1627e-01  -5.0808e-01   3.0779e-01   1.5646e-02   1.9867e-01  -6.2833e-02
   0.0000e+00   0.0000e+00  -6.4345e-01   3.1891e-02   5.0618e-01  -4.2568e-01   8.8552e-03
   0.0000e+00   0.0000e+00   0.0000e+00  -1.9538e-01  -2.5678e-02  -3.2631e-01   1.5533e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   4.4022e-01  -3.6005e-01  -2.3789e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   7.6846e-02   3.1509e-01

  -1.6876e+00
   0.0000e+00
   0.0000e+00
   0.0000e+00
   0.0000e+00
   0.0000e+00
   0.0000e+00

   5.0452e-01
   5.1629e-01
   3.1903e-01
   9.8664e-01
   4.9398e-01
   2.6614e-01
   9.0733e-02

   2

   7
   1
   1
   1
   1
   1
   1
   1
C*** test09.dat
FILE: test09.dat
   test09
   8
   8
   0.0

   3.3863e+00   1.2970e+00   6.8401e-02  -1.6807e-01   1.3643e+00   5.8419e-01  -1.1948e-01  -3.5636e-01
   1.8262e+00   2.2228e-01   6.4823e-02  -1.4952e-01  -1.6189e-01   4.2057e-01   8.2231e-02  -2.5567e-01
  -4.1478e-01  -3.7728e-01   7.5322e-01  -1.6737e-02  -5.0886e-02   2.3927e-01  -2.4875e-01   5.6316e-01
  -1.9934e-01   1.4462e-01  -3.6354e-01  -1.6969e-01  -3.1838e-01  -8.6776e-02   1.0658e-01  -4.6959e-01
   4.2980e-01  -2.1000e-02  -1.2929e-02   3.7302e-01   6.8087e-01   2.9589e-01  -1.6497e-01  -1.0878e-01
   3.4183e-01  -2.5491e-01  -2.6765e-01  -4.5671e-02   4.2002e-01   2.6674e-01  -8.1237e-02   1.4580e-02
   2.2507e-01  -2.5721e-01   7.4317e-03  -1.3891e-01  -1.1977e-01   1.5838e-01  -5.3907e-02  -4.0870e-02
   2.1090e-01   5.8834e-02   5.3085e-01  -1.1465e-02  -7.3817e-03  -1.6294e-02   9.8098e-02   2.1245e-01

  -2.0679e+00  -1.5167e+00  -9.8482e-01  -1.3341e+00  -1.4173e+00  -1.1772e+00  -1.2914e+00  -1.0910e+00
   0.0000e+00  -1.2748e+00  -1.9521e-01   1.8128e-01  -5.5224e-01  -4.9392e-01  -6.3513e-01  -6.8193e-01
   0.0000e+00   0.0000e+00   8.7884e-01  -7.2161e-02   4.4757e-01   4.3917e-01   3.3898e-01  -2.1518e-01
   0.0000e+00   0.0000e+00   0.0000e+00  -7.9005e-01  -2.2451e-01  -5.2175e-02  -1.9970e-02   1.0739e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -6.4359e-01  -1.1835e-01  -3.6255e-01  -4.4829e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.9504e-01  -2.7957e-01  -3.3985e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.7483e-01   1.3969e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -2.7583e-01

   3.8882e-01
   9.5216e-01
   9.4755e-01
   3.8985e-01
   2.6921e-01
   6.9217e-01
   2.8404e-01
   7.7687e-01

   6

   1
   8
C*** test10.dat
FILE: test10.dat
   test10
   8
   8
   0.0e0

   3.9786e-01   3.5206e-01   5.1598e-02   7.1719e-01  -7.0242e-02  -2.4831e-01  -1.6948e-01  -2.7154e-01
   5.4449e-02   4.5925e-01  -4.1353e-02  -4.0177e-02   8.5495e-02   8.6587e-01   8.6456e-02   7.2405e-01
  -2.1535e-01  -5.2821e-01  -2.5934e-04  -4.1832e-01  -7.8581e-02  -4.1538e-01  -4.7041e-01   2.7887e-01
   7.9098e-02  -6.9542e-02  -9.9614e-02   2.9045e-01   8.1273e-02   6.7808e-01  -4.4715e-02  -2.0711e-01
   3.4337e-02  -1.5865e-01   4.6362e-02  -2.5657e-01   3.4028e-01   4.5890e-01  -3.2710e-01   1.3807e-01
   9.3741e-03   2.7476e-02   1.3960e-02  -1.8552e-03  -4.8963e-02   3.9204e+00   1.2293e-01  -2.0983e-01
   1.9958e-01   1.6111e-01   3.6223e-02  -2.0339e-01   1.1742e-01   1.5716e-01  -5.1922e-02   2.0187e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   6.4623e-01   1.4415e-01

   0.0000e+00   5.3040e-01  -2.7873e-01  -2.3905e-01   8.9290e-02   1.4689e-01  -6.9433e-02   4.4875e-01
   0.0000e+00   0.0000e+00  -9.5951e-01  -1.8827e-01   3.2675e-01   1.8923e-01  -5.2016e-01   1.0506e-01
   0.0000e+00   0.0000e+00   0.0000e+00  -6.9473e-01   1.1420e-01   2.0463e-01   4.5928e-01   1.4951e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   6.3948e-01   2.0105e-01  -3.2764e-01  -5.6423e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   6.3613e-01  -3.1038e-01  -2.9520e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.0716e+00  -2.5948e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -5.8925e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   8.2871e-01
   9.4549e-02
   8.1738e-02
   7.6400e-01
   6.2957e-01
   2.1385e-01
   2.1355e-01
   8.1061e-02

   6

   2
   7
   1
C*** test11.dat
FILE: test11.dat
   test11
   8
   12
   0.0e0

   3.5457e+00   3.4272e-01  -4.5342e-01  -9.9450e-01   3.7759e-01  -8.6237e-01  -2.1257e-01  -7.1427e-01
   8.3218e-01   6.8561e-01  -1.9525e-01  -1.3290e-01  -2.8856e-01  -3.1282e-01  -3.5166e-01   1.0813e-01
  -1.8173e-01  -5.7059e-01  -6.8478e-02   1.9873e-01  -2.6720e-01   2.9871e-01   3.2190e-02  -3.4552e-01
  -9.4282e-01  -1.0060e-01   4.7300e-01   5.2276e-01   6.8245e-02   3.5689e-01  -8.3860e-01  -3.1796e-01
  -2.5108e-01  -1.2123e-01   1.1264e-01   1.8635e-01  -4.0463e-01  -6.6646e-01  -1.3099e-01   4.7477e-01
  -4.2470e-01  -6.3609e-02   2.1190e-01  -1.5021e-01  -8.8972e-02   1.4906e-01   3.2916e-01   1.7351e-01
  -5.3899e-01  -5.0446e-01   7.4225e-02   1.0385e-01   1.7043e-01  -1.4107e-01  -9.4844e-02   1.7363e-01
  -4.7261e-01  -9.7094e-02   1.3355e-01  -1.7700e-01   6.2837e-01  -2.4296e-02  -7.0442e-02  -1.1252e-01

   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   2.1841e+00   1.5780e+00   1.8734e+00   1.3901e+00   1.4631e+00  -2.0262e+00   1.9557e+00   2.0276e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   1.2026e+00   4.2467e-01   3.9631e-01  -2.8934e-01  -3.0682e-01   3.1144e-02  -4.3497e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.1316e+00   1.4674e-01  -1.6105e-01  -2.2733e-02  -2.1079e-01   1.7952e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.0727e+00  -1.6798e-01  -1.5484e-01  -3.5832e-01   3.8274e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.1940e-01   2.5641e-01   2.7377e-01   2.9155e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   7.8766e-01  -3.0988e-01   1.9920e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -7.6845e-01  -7.6432e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   5.3827e-01

   9.0167e-01
   4.2650e-01
   1.4202e-01
   9.4749e-01
   4.1031e-01
   1.3119e-01
   8.8565e-01
   9.2174e-02

   6

   1
   8
C*** test12.dat
FILE: test12.dat
   test12
   8
   12
   0.0e0

   7.2702e-01   2.3381e-01   3.9975e-01  -4.6385e-01  -3.1672e-01   6.1185e-01  -1.1925e-02   5.3388e-01
   3.2074e-01   8.5628e-02   2.8138e-01  -5.7942e-01  -1.8862e-01   5.9573e-01   2.1649e-01  -3.6953e-01
   5.9747e-01   5.0666e-03  -6.6962e-02  -3.0696e-01  -5.8420e-01   5.9183e-01   1.1638e-01   2.9807e-03
   1.2940e-02   5.1686e-02  -2.3495e-01  -3.4633e-01   4.7052e-01  -1.1537e+00   9.2765e-02   2.7276e-01
  -3.0809e-01  -1.4685e-01   1.3760e-01   5.6382e-01   5.7218e-02  -9.8264e-01  -9.7807e-01   2.9776e-01
   1.0314e+00   5.5611e-01   1.0322e+00  -7.3460e-01  -6.0446e-01   3.0921e+00  -1.1323e-01  -4.1910e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -6.6247e-01   3.9144e-02   4.8427e-03   4.6842e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   5.7783e-01   2.0325e-01   6.6917e-01

   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.6695e-01  -4.1178e-01  -6.8377e-02  -3.0893e-01   6.4625e-02  -1.2141e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  0.0000e+00  -8.6884e-01  -1.4454e-01   2.3079e-01   4.1128e-02  -9.6517e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -8.6603e-01   2.8238e-01   2.1318e-01  -5.1222e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -9.7076e-01   1.6957e-01   5.3172e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.1211e+00   1.4003e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.4080e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   9.0167e-01
   4.2650e-01
   1.4202e-01
   9.4749e-01
   4.1031e-01
   1.3119e-01
   8.8565e-01
   9.2174e-02

   2

   2
   6
   2
C*** test13.dat
FILE: test13.dat
   test13
   6
   3
   0.0e0

   1 2 3 4 5 4
   6 5 4 8 9 3
   8 4 2 3 4 2
   0 3 2 6 7 6
   0 0 6 3 9 7
   0 0 0 0 0 8

   8 6 5
   0 9 7
   0 0 7
   0 0 0
   0 0 0
   0 0 0

   0.1234
   0.4321
   0.6789
   0.9876
   0.2468
   0.8642

   6

   3
   3
   2
   1
C*** test14.dat
FILE: test14.dat
   test14
   7
   3
   0.0

   3.4154e+00   7.0861e-01   6.3519e-02  -6.3994e-01   4.2915e-01   2.6791e-02   2.5569e-01
  -6.7357e-02  -3.2618e-01  -2.5427e-01   7.2458e-02   1.9108e-01   1.3052e-01   1.2506e-02
   2.2022e-01  -2.4668e-01  -2.1201e-01  -1.7046e-01  -2.8010e-01  -2.2360e-01   7.3320e-03
  -1.1551e+00   4.0280e-02  -1.5178e-01   1.7455e-01  -6.2950e-03  -8.6111e-04   1.0530e+00
   0.0000e+00   5.3410e-01  -8.5129e-02  -1.2252e-01  -1.5639e-01  -2.6565e-01  -5.3535e-02
   0.0000e+00   0.0000e+00   1.0081e-01  -1.0328e-01   6.8692e-02  -3.7728e-02   5.4693e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.1216e-01

  -2.3856e+00  -3.5062e-01   6.6300e-02
   0.0000e+00  -9.8582e-01  -9.0124e-02
   0.0000e+00   0.0000e+00  -6.8075e-01
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00

   4.6445e-01
   9.4098e-01
   5.0084e-02
   7.6151e-01
   7.7020e-01
   8.2782e-01
   1.2537e-01

   2

   3
   3
   3
   0
C*** test15.dat
FILE: test15.dat
   test15
   8
   4
   -1.0e0

   9.5370e-01  -7.0749e-01  -9.2387e-01  -1.0824e+00   1.5800e-01   1.6625e-01  -1.3262e-01   3.5705e-01
   8.4248e-02   4.5589e-01   6.5238e-01   5.0479e-01   2.4822e-02   3.3613e-01  -3.9601e-01   7.6632e-02
  -6.9031e-01   3.6439e-01   7.1656e-01   1.4881e+00   4.8145e-01  -4.7302e-01   1.1851e-01   4.1251e-02
  -1.6031e+00   4.2296e-01   1.2803e+00   1.6329e+00   1.3188e-01  -1.3793e-01   2.5090e-01   1.0162e-01
   0.0000e+00   2.2785e-01   4.8225e-02  -1.1851e-01  -2.4609e-02  -5.1050e-01  -5.6085e-01  -2.7464e-01
   0.0000e+00   0.0000e+00  -5.6564e-01  -2.4175e-01   4.0745e-01  -2.3156e-01  -3.9217e-01   2.3909e-02
   0.0000e+00   0.0000e+00   0.0000e+00  -7.0169e-01   3.1147e-01  -8.0880e-01   2.4877e-01  -4.6728e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.0295e-01

   1.3194e+00  -2.7822e-02   2.9922e-01  -1.3419e+00
   0.0000e+00  -6.4414e-01   1.2107e-02   8.5096e-01
   0.0000e+00   0.0000e+00  -3.6301e-01   9.9188e-01
   0.0000e+00   0.0000e+00   0.0000e+00   2.0807e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   7.2187e-01
   4.9658e-01
   5.3694e-02
   4.4163e-01
   5.1917e-01
   7.7194e-01
   6.5356e-02
   4.4279e-01

   2

   3
   4
   3
   0
C*** test16.dat
FILE: test16.dat
   test16
   8
   4
   -1.0e0

   9.5370e-01  -7.0749e-01  -9.2387e-01  -1.0824e+00   1.5800e-01   1.6625e-01  -1.3262e-01   3.5705e-01
   8.4248e-02   4.5589e-01   6.5238e-01   5.0479e-01   2.4822e-02   3.3613e-01  -3.9601e-01   7.6632e-02
  -6.9031e-01   3.6439e-01   7.1656e-01   1.4881e+00   4.8145e-01  -4.7302e-01   1.1851e-01   4.1251e-02
  -1.6031e+00   4.2296e-01   1.2803e+00   1.6329e+00   1.3188e-01  -1.3793e-01   2.5090e-01   1.0162e-01
   0.0000e+00   2.2785e-01   4.8225e-02  -1.1851e-01  -2.4609e-02  -5.1050e-01  -5.6085e-01  -2.7464e-01
   0.0000e+00   0.0000e+00  -5.6564e-01  -2.4175e-01   4.0745e-01  -2.3156e-01  -3.9217e-01   2.3909e-02
   0.0000e+00   0.0000e+00   0.0000e+00  -7.0169e-01   3.1147e-01  -8.0880e-01   2.4877e-01  -4.6728e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -3.0295e-01

   1.3194e+00  -2.7822e-02   2.9922e-01  -1.3419e+00
   0.0000e+00  -6.4414e-01   1.2107e-02   8.5096e-01
   0.0000e+00   0.0000e+00  -3.6301e-01   9.9188e-01
   0.0000e+00   0.0000e+00   0.0000e+00   2.0807e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   7.2187e-01
   4.9658e-01
   5.3694e-02
   4.4163e-01
   5.1917e-01
   7.7194e-01
   6.5356e-02
   4.4279e-01

   8
   3
   4
   3
   0
C*** test17.dat
FILE: test17.dat
   test17
   11
   4
   -1.0e0

   5.2288e-01  -4.3210e-01  -2.3327e-01  -2.0400e+00  -5.2059e-01  -7.9287e-02  -5.7692e-01   6.2213e-01   1.8409e-01   5.5273e-01  -1.0203e-01
   1.0071e-01   4.4451e-01   1.1595e-01   1.1167e+00  -1.0699e-02  -5.3444e-02   7.1376e-02   2.7699e-02  -1.9800e-01   1.5233e-01  -4.8015e-01
   5.8848e-01  -2.3494e-01   7.0573e-02  -1.8483e-01  -5.7797e-01  -8.1669e-03   6.2597e-01  -8.3920e-02  -4.4601e-01   4.0800e-01   2.4982e-01
  -1.8102e+00   1.4413e+00  -6.0526e-01   4.2499e+00   7.9629e-01   2.4094e-01   1.4879e-01  -4.9520e-01   3.8537e-01  -5.2755e-02   2.9614e-01
  -1.5946e-01  -3.1611e-02  -2.9825e-01   8.4013e-01   4.4191e-02   2.3847e-01   6.6773e-01  -2.1610e-01  -1.4784e-01  -6.7419e-01  -7.7187e-01
   0.0000e+00   6.7186e-01  -1.8392e-01   6.7797e-02  -1.6652e-01  -3.7422e-01  -1.6928e-01  -9.8742e-02   3.9233e-01  -4.1975e-01  -1.2146e-01
   0.0000e+00   0.0000e+00   8.2362e-01   5.4477e-01   8.1134e-03   3.0379e-01  -3.1392e-02   1.0449e-01   4.6911e-03   1.2993e-01   4.0013e-01
   0.0000e+00   0.0000e+00   0.0000e+00  -5.1263e-01   7.2441e-03  -5.6254e-02  -5.5940e-01   1.6259e-01  -4.9478e-01  -1.0234e-01   1.9650e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   2.1045e-01  -2.8217e-01   6.9507e-02
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -4.4512e-01   2.4522e-01   6.1899e-01
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00  -1.4637e-01  -3.0886e-01   1.4166e-01

  -1.0093e+00   1.0225e-01   1.3621e-01   1.0378e+00
   0.0000e+00  -1.3007e+00   6.4916e-02  -6.0424e-01
   0.0000e+00   0.0000e+00  -5.0297e-01  -2.3038e-02
   0.0000e+00   0.0000e+00   0.0000e+00  -3.0093e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00
   0.0000e+00   0.0000e+00   0.0000e+00   0.0000e+00

   1.3119e-01
   8.8565e-01
   9.2174e-02
   1.6220e-01
   7.1064e-02
   3.6534e-01
   2.5306e-01
   1.3511e-01
   7.8315e-01
   4.5531e-01
   3.4952e-01

   2
   3
   4 
   4
   0
C*** test18.dat
FILE: test18.dat
   test18
   30
   1
   0.0e0

  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   30.0
   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   29.0
   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   28.0
   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   27.0
   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   26.0
   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   25.0
   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   24.0
   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   23.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   22.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   21.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   20.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   19.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   18.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   17.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   16.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   15.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   14.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   13.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   12.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   11.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   10.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   9.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   8.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0   7.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0   6.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0   5.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0   4.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0   3.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0   2.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0   1.0
 
   1.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
 
  -2.1852421e-02 
   1.9998806e+00
  -8.6454473e-02 
   1.9981305e+00
  -1.9098305e-01 
   1.9908607e+00
  -3.3086959e-01 
   1.9724413e+00
  -4.9999962e-01 
   1.9364915e+00
  -6.9098289e-01 
   1.8768443e+00
  -8.9547215e-01 
   1.7883320e+00
  -1.1045287e+00 
   1.6673376e+00
  -1.3090163e+00 
   1.5121089e+00
  -1.4999993e+00 
   1.3228762e+00
  -1.6691309e+00 
   1.1018189e+00
  -1.8090180e+00 
   8.5291131e-01
  -1.9135460e+00 
   5.8167243e-01
  -1.9781471e+00 
   2.9484156e-01
  -1.9999990e+00 
   2.0  

   28

   30
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    0
C*** test19.dat
FILE: test19.dat
   test19
   40
   1
   0.0e0

  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 40.0
   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 39.0
   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 38.0
   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 37.0
   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 36.0
   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 35.0
   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 34.0
   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 33.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 32.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 31.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 30.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 29.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 28.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 27.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 26.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 25.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 24.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 23.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 22.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 21.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 20.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 19.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 18.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 17.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 16.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 15.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 14.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 13.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 12.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 11.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0 10.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0  9.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0  8.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0  -1.0 -1.0  7.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0  -1.0 -1.0  6.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0  -1.0 -1.0  5.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0  -1.0 -1.0  4.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0  -1.0 -1.0  3.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   1.0 -1.0  2.0
   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0   0.0  1.0  1.0

   1.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0 
   0.0
   0.0
   0.0
   0.0
   0.0
   0.0

 
  -0.0123 
   2.0000
  -0.0489
   1.9994
  -0.1090 
   1.9970
  -0.1910
   1.9909
  -0.2929
   1.9784
  -0.4122
   1.9571
  -0.5460 
   1.9240
  -0.6910
   1.8768
  -0.8436
   1.8134
  -1.0000
   1.7321
  -1.1564 
   1.6318
  -1.3090
   1.5121
  -1.4540 
   1.3733
  -1.5878
   1.2161
  -1.7071
   1.0420
  -1.8090
   0.8529
  -1.8910 
   0.6512
  -1.9511
   0.4397
  -1.9877
   0.2216
  -2.0000
   2.0000

   38

   40
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    1
    0
C*** test20.dat
FILE:  test20.dat
   test20
   9
   3
   0.0e0

   2.1895919e-01   5.3461635e-02   9.3043649e-01   2.6245299e-01   9.8255029e-01   7.6649478e-01   6.0564328e-02   9.4776425e-01   5.0083984e-02
   4.7044616e-02   5.2970019e-01   8.4616689e-01   4.7464514e-02   7.2266040e-01   4.7773177e-01   9.0465309e-01   7.3749075e-02   7.6151426e-01
   6.7886472e-01   6.7114938e-01   5.2692878e-01   7.3608188e-01   7.5335583e-01   2.3777443e-01   5.0452289e-01   5.0070709e-01   7.7020455e-01
   6.7929641e-01   7.6981862e-03   9.1964891e-02   3.2823423e-01   6.5151857e-01   2.7490684e-01   5.1629196e-01   3.8414215e-01   8.2781730e-01
   9.3469290e-01   3.8341565e-01   6.5391896e-01   6.3263857e-01   7.2685883e-02   3.5926498e-01   3.1903294e-01   2.7708180e-01   1.2536538e-01
   3.8350208e-01   6.6842238e-02   4.1599936e-01   7.5641049e-01   6.3163472e-01   1.6650720e-01   9.8664211e-01   9.1381744e-01   1.5867701e-02
   5.1941637e-01   4.1748597e-01   7.0119059e-01   9.9103739e-01   8.8470713e-01   4.8651738e-01   4.9397668e-01   5.2974739e-01   6.8845530e-01
   8.3096535e-01   6.8677271e-01   9.1032083e-01   3.6533867e-01   2.7270997e-01   8.9765629e-01   2.6614451e-01   4.6444582e-01   8.6824713e-01
   3.4572111e-02   5.8897664e-01   7.6219804e-01   2.4703889e-01   4.3641141e-01   9.0920810e-01   9.0732895e-02   9.4097995e-01   6.2954342e-01

   9.3043649e-01   2.6245299e-01   9.8255029e-01
   8.4616689e-01   4.7464514e-02   7.2266040e-01
   5.2692878e-01   7.3608188e-01   7.5335583e-01
   9.1964891e-02   3.2823423e-01   6.5151857e-01
   6.5391896e-01   6.3263857e-01   7.2685883e-02
   4.1599936e-01   7.5641049e-01   6.3163472e-01
   7.0119059e-01   9.9103739e-01   8.8470713e-01
   9.1032083e-01   3.6533867e-01   2.7270997e-01
   7.6219804e-01   2.4703889e-01   4.3641141e-01

   1.5371998e-01
   5.7165481e-01
   8.0240573e-01
   3.3053754e-02
   5.3444984e-01
   4.9848012e-01
   9.5536076e-01
   7.4829265e-01
   5.5458385e-01

   4
