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, bN, 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, bN, 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=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