Move LAPACK trunk into position.

1 files changed, 228 insertions, 0 deletions

diff --git a/TESTING/EIG/alahdg.f b/TESTING/EIG/alahdg.f
new file mode 100644
index 00000000..5c9edfe7
--- /dev/null
+++ b/TESTING/EIG/alahdg.f
@@ -0,0 +1,228 @@
+      SUBROUTINE ALAHDG( IOUNIT, PATH )
+*
+*  -- LAPACK test routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER*3       PATH
+      INTEGER           IOUNIT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ALAHDG prints header information for the different test paths.
+*
+*  Arguments
+*  =========
+*
+*  IOUNIT  (input) INTEGER
+*          The unit number to which the header information should be
+*          printed.
+*
+*  PATH    (input) CHARACTER*3
+*          The name of the path for which the header information is to
+*          be printed.  Current paths are
+*             GQR:  GQR (general matrices)
+*             GRQ:  GRQ (general matrices)
+*             LSE:  LSE Problem
+*             GLM:  GLM Problem
+*             GSV:  Generalized Singular Value Decomposition
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      CHARACTER*3       C2
+      INTEGER           ITYPE
+*     ..
+*     .. External Functions ..
+      LOGICAL           LSAMEN
+      EXTERNAL          LSAMEN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( IOUNIT.LE.0 )
+     $   RETURN
+      C2 = PATH( 1: 3 )
+*
+*     First line describing matrices in this path
+*
+      IF( LSAMEN( 3, C2, 'GQR' ) ) THEN
+         ITYPE = 1
+         WRITE( IOUNIT, FMT = 9991 )PATH
+      ELSE IF( LSAMEN( 3, C2, 'GRQ' ) ) THEN
+         ITYPE = 2
+         WRITE( IOUNIT, FMT = 9992 )PATH
+      ELSE IF( LSAMEN( 3, C2, 'LSE' ) ) THEN
+         ITYPE = 3
+         WRITE( IOUNIT, FMT = 9993 )PATH
+      ELSE IF( LSAMEN( 3, C2, 'GLM' ) ) THEN
+         ITYPE = 4
+         WRITE( IOUNIT, FMT = 9994 )PATH
+      ELSE IF( LSAMEN( 3, C2, 'GSV' ) ) THEN
+         ITYPE = 5
+         WRITE( IOUNIT, FMT = 9995 )PATH
+      END IF
+*
+*     Matrix types
+*
+      WRITE( IOUNIT, FMT = 9999 )'Matrix types: '
+*
+      IF( ITYPE.EQ.1 )THEN
+         WRITE( IOUNIT, FMT = 9950 )1
+         WRITE( IOUNIT, FMT = 9952 )2
+         WRITE( IOUNIT, FMT = 9954 )3
+         WRITE( IOUNIT, FMT = 9955 )4
+         WRITE( IOUNIT, FMT = 9956 )5
+         WRITE( IOUNIT, FMT = 9957 )6
+         WRITE( IOUNIT, FMT = 9961 )7
+         WRITE( IOUNIT, FMT = 9962 )8
+      ELSE IF( ITYPE.EQ.2 )THEN
+         WRITE( IOUNIT, FMT = 9951 )1
+         WRITE( IOUNIT, FMT = 9953 )2
+         WRITE( IOUNIT, FMT = 9954 )3
+         WRITE( IOUNIT, FMT = 9955 )4
+         WRITE( IOUNIT, FMT = 9956 )5
+         WRITE( IOUNIT, FMT = 9957 )6
+         WRITE( IOUNIT, FMT = 9961 )7
+         WRITE( IOUNIT, FMT = 9962 )8
+      ELSE IF( ITYPE.EQ.3 )THEN
+         WRITE( IOUNIT, FMT = 9950 )1
+         WRITE( IOUNIT, FMT = 9952 )2
+         WRITE( IOUNIT, FMT = 9954 )3
+         WRITE( IOUNIT, FMT = 9955 )4
+         WRITE( IOUNIT, FMT = 9955 )5
+         WRITE( IOUNIT, FMT = 9955 )6
+         WRITE( IOUNIT, FMT = 9955 )7
+         WRITE( IOUNIT, FMT = 9955 )8
+      ELSE IF( ITYPE.EQ.4 )THEN
+         WRITE( IOUNIT, FMT = 9951 )1
+         WRITE( IOUNIT, FMT = 9953 )2
+         WRITE( IOUNIT, FMT = 9954 )3
+         WRITE( IOUNIT, FMT = 9955 )4
+         WRITE( IOUNIT, FMT = 9955 )5
+         WRITE( IOUNIT, FMT = 9955 )6
+         WRITE( IOUNIT, FMT = 9955 )7
+         WRITE( IOUNIT, FMT = 9955 )8
+      ELSE IF( ITYPE.EQ.5 )THEN
+         WRITE( IOUNIT, FMT = 9950 )1
+         WRITE( IOUNIT, FMT = 9952 )2
+         WRITE( IOUNIT, FMT = 9954 )3
+         WRITE( IOUNIT, FMT = 9955 )4
+         WRITE( IOUNIT, FMT = 9956 )5
+         WRITE( IOUNIT, FMT = 9957 )6
+         WRITE( IOUNIT, FMT = 9959 )7
+         WRITE( IOUNIT, FMT = 9960 )8
+      END IF
+*
+*     Tests performed
+*
+      WRITE( IOUNIT, FMT = 9999 )'Test ratios: '
+*
+      IF( ITYPE.EQ.1 ) THEN
+*
+*        GQR decomposition of rectangular matrices
+*
+         WRITE( IOUNIT, FMT = 9930 )1
+         WRITE( IOUNIT, FMT = 9931 )2
+         WRITE( IOUNIT, FMT = 9932 )3
+         WRITE( IOUNIT, FMT = 9933 )4
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        GRQ decomposition of rectangular matrices
+*
+         WRITE( IOUNIT, FMT = 9934 )1
+         WRITE( IOUNIT, FMT = 9935 )2
+         WRITE( IOUNIT, FMT = 9932 )3
+         WRITE( IOUNIT, FMT = 9933 )4
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        LSE Problem
+*
+         WRITE( IOUNIT, FMT = 9937 )1
+         WRITE( IOUNIT, FMT = 9938 )2
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        GLM Problem
+*
+         WRITE( IOUNIT, FMT = 9939 )1
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        GSVD
+*
+         WRITE( IOUNIT, FMT = 9940 )1
+         WRITE( IOUNIT, FMT = 9941 )2
+         WRITE( IOUNIT, FMT = 9942 )3
+         WRITE( IOUNIT, FMT = 9943 )4
+         WRITE( IOUNIT, FMT = 9944 )5
+      END IF
+*
+ 9999 FORMAT( 1X, A )
+ 9991 FORMAT( / 1X, A3, ': GQR factorization of general matrices' )
+ 9992 FORMAT( / 1X, A3, ': GRQ factorization of general matrices' )
+ 9993 FORMAT( / 1X, A3, ': LSE Problem' )
+ 9994 FORMAT( / 1X, A3, ': GLM Problem' )
+ 9995 FORMAT( / 1X, A3, ': Generalized Singular Value Decomposition' )
+*
+ 9950 FORMAT( 3X, I2, ': A-diagonal matrix  B-upper triangular' )
+ 9951 FORMAT( 3X, I2, ': A-diagonal matrix  B-lower triangular' )
+ 9952 FORMAT( 3X, I2, ': A-upper triangular B-upper triangular' )
+ 9953 FORMAT( 3X, I2, ': A-lower triangular B-diagonal triangular' )
+ 9954 FORMAT( 3X, I2, ': A-lower triangular B-upper triangular' )
+*
+ 9955 FORMAT( 3X, I2, ': Random matrices cond(A)=100, cond(B)=10,' )
+*
+ 9956 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
+     $      'cond(B)= sqrt( 0.1/EPS )' )
+ 9957 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
+     $      'cond(B)= 0.1/EPS' )
+ 9959 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
+     $      'cond(B)=  0.1/EPS ' )
+ 9960 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
+     $      'cond(B)=  sqrt( 0.1/EPS )' )
+*
+ 9961 FORMAT( 3X, I2, ': Matrix scaled near underflow limit' )
+ 9962 FORMAT( 3X, I2, ': Matrix scaled near overflow limit' )
+*
+*
+*     GQR test ratio
+*
+ 9930 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( min( N, M )*norm( A )',
+     $       '* EPS )' )
+ 9931 FORMAT( 3X, I2, ': norm( T * Z - Q'' * B )  / ( min(P,N)*norm(B)',
+     $       '* EPS )' )
+ 9932 FORMAT( 3X, I2, ': norm( I - Q''*Q )   / ( N * EPS )' )
+ 9933 FORMAT( 3X, I2, ': norm( I - Z''*Z )   / ( P * EPS )' )
+*
+*     GRQ test ratio
+*
+ 9934 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( min( N,M )*norm(A) * ',
+     $       'EPS )' )
+ 9935 FORMAT( 3X, I2, ': norm( T * Q - Z'' * B )  / ( min( P,N ) * nor',
+     $       'm(B)*EPS )' )
+*
+*     LSE test ratio
+*
+ 9937 FORMAT( 3X, I2, ': norm( A*x - c )  / ( norm(A)*norm(x) * EPS )' )
+ 9938 FORMAT( 3X, I2, ': norm( B*x - d )  / ( norm(B)*norm(x) * EPS )' )
+*
+*     GLM test ratio
+*
+ 9939 FORMAT( 3X, I2, ': norm( d - A*x - B*y ) / ( (norm(A)+norm(B) )*',
+     $       '(norm(x)+norm(y))*EPS )' )
+*
+*     GSVD test ratio
+*
+ 9940 FORMAT( 3X, I2, ': norm( U'' * A * Q - D1 * R ) / ( min( M, N )*',
+     $       'norm( A ) * EPS )' )
+ 9941 FORMAT( 3X, I2, ': norm( V'' * B * Q - D2 * R ) / ( min( P, N )*',
+     $       'norm( B ) * EPS )' )
+ 9942 FORMAT( 3X, I2, ': norm( I - U''*U )   / ( M * EPS )' )
+ 9943 FORMAT( 3X, I2, ': norm( I - V''*V )   / ( P * EPS )' )
+ 9944 FORMAT( 3X, I2, ': norm( I - Q''*Q )   / ( N * EPS )' )
+      RETURN
+*
+*     End of ALAHDG
+*
+      END