alahdg.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 229 行

      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