LAPACK: TESTING/EIG/slarhs.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
00002      $                   A, LDA, X, LDX, B, LDB, ISEED, INFO )
00003 *
00004 *  -- LAPACK test routine (version 3.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER          TRANS, UPLO, XTYPE
00010       CHARACTER*3        PATH
00011       INTEGER            INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            ISEED( 4 )
00015       REAL               A( LDA, * ), B( LDB, * ), X( LDX, * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  SLARHS chooses a set of NRHS random solution vectors and sets
00022 *  up the right hand sides for the linear system
00023 *     op( A ) * X = B,
00024 *  where op( A ) may be A or A' (transpose of A).
00025 *
00026 *  Arguments
00027 *  =========
00028 *
00029 *  PATH    (input) CHARACTER*3
00030 *          The type of the real matrix A.  PATH may be given in any
00031 *          combination of upper and lower case.  Valid types include
00032 *             xGE:  General m x n matrix
00033 *             xGB:  General banded matrix
00034 *             xPO:  Symmetric positive definite, 2-D storage
00035 *             xPP:  Symmetric positive definite packed
00036 *             xPB:  Symmetric positive definite banded
00037 *             xSY:  Symmetric indefinite, 2-D storage
00038 *             xSP:  Symmetric indefinite packed
00039 *             xSB:  Symmetric indefinite banded
00040 *             xTR:  Triangular
00041 *             xTP:  Triangular packed
00042 *             xTB:  Triangular banded
00043 *             xQR:  General m x n matrix
00044 *             xLQ:  General m x n matrix
00045 *             xQL:  General m x n matrix
00046 *             xRQ:  General m x n matrix
00047 *          where the leading character indicates the precision.
00048 *
00049 *  XTYPE   (input) CHARACTER*1
00050 *          Specifies how the exact solution X will be determined:
00051 *          = 'N':  New solution; generate a random X.
00052 *          = 'C':  Computed; use value of X on entry.
00053 *
00054 *  UPLO    (input) CHARACTER*1
00055 *          Specifies whether the upper or lower triangular part of the
00056 *          matrix A is stored, if A is symmetric.
00057 *          = 'U':  Upper triangular
00058 *          = 'L':  Lower triangular
00059 *
00060 *  TRANS   (input) CHARACTER*1
00061 *          Specifies the operation applied to the matrix A.
00062 *          = 'N':  System is  A * x = b
00063 *          = 'T':  System is  A'* x = b
00064 *          = 'C':  System is  A'* x = b
00065 *
00066 *  M       (input) INTEGER
00067 *          The number or rows of the matrix A.  M >= 0.
00068 *
00069 *  N       (input) INTEGER
00070 *          The number of columns of the matrix A.  N >= 0.
00071 *
00072 *  KL      (input) INTEGER
00073 *          Used only if A is a band matrix; specifies the number of
00074 *          subdiagonals of A if A is a general band matrix or if A is
00075 *          symmetric or triangular and UPLO = 'L'; specifies the number
00076 *          of superdiagonals of A if A is symmetric or triangular and
00077 *          UPLO = 'U'.  0 <= KL <= M-1.
00078 *
00079 *  KU      (input) INTEGER
00080 *          Used only if A is a general band matrix or if A is
00081 *          triangular.
00082 *
00083 *          If PATH = xGB, specifies the number of superdiagonals of A,
00084 *          and 0 <= KU <= N-1.
00085 *
00086 *          If PATH = xTR, xTP, or xTB, specifies whether or not the
00087 *          matrix has unit diagonal:
00088 *          = 1:  matrix has non-unit diagonal (default)
00089 *          = 2:  matrix has unit diagonal
00090 *
00091 *  NRHS    (input) INTEGER
00092 *          The number of right hand side vectors in the system A*X = B.
00093 *
00094 *  A       (input) REAL array, dimension (LDA,N)
00095 *          The test matrix whose type is given by PATH.
00096 *
00097 *  LDA     (input) INTEGER
00098 *          The leading dimension of the array A.
00099 *          If PATH = xGB, LDA >= KL+KU+1.
00100 *          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
00101 *          Otherwise, LDA >= max(1,M).
00102 *
00103 *  X       (input or output) REAL array, dimension(LDX,NRHS)
00104 *          On entry, if XTYPE = 'C' (for 'Computed'), then X contains
00105 *          the exact solution to the system of linear equations.
00106 *          On exit, if XTYPE = 'N' (for 'New'), then X is initialized
00107 *          with random values.
00108 *
00109 *  LDX     (input) INTEGER
00110 *          The leading dimension of the array X.  If TRANS = 'N',
00111 *          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
00112 *
00113 *  B       (output) REAL array, dimension (LDB,NRHS)
00114 *          The right hand side vector(s) for the system of equations,
00115 *          computed from B = op(A) * X, where op(A) is determined by
00116 *          TRANS.
00117 *
00118 *  LDB     (input) INTEGER
00119 *          The leading dimension of the array B.  If TRANS = 'N',
00120 *          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
00121 *
00122 *  ISEED   (input/output) INTEGER array, dimension (4)
00123 *          The seed vector for the random number generator (used in
00124 *          SLATMS).  Modified on exit.
00125 *
00126 *  INFO    (output) INTEGER
00127 *          = 0:  successful exit
00128 *          < 0:  if INFO = -i, the i-th argument had an illegal value
00129 *
00130 *  =====================================================================
00131 *
00132 *     .. Parameters ..
00133       REAL               ONE, ZERO
00134       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
00135 *     ..
00136 *     .. Local Scalars ..
00137       LOGICAL            BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
00138       CHARACTER          C1, DIAG
00139       CHARACTER*2        C2
00140       INTEGER            J, MB, NX
00141 *     ..
00142 *     .. External Functions ..
00143       LOGICAL            LSAME, LSAMEN
00144       EXTERNAL           LSAME, LSAMEN
00145 *     ..
00146 *     .. External Subroutines ..
00147       EXTERNAL           SGBMV, SGEMM, SLACPY, SLARNV, SSBMV, SSPMV,
00148      $                   SSYMM, STBMV, STPMV, STRMM, XERBLA
00149 *     ..
00150 *     .. Intrinsic Functions ..
00151       INTRINSIC          MAX
00152 *     ..
00153 *     .. Executable Statements ..
00154 *
00155 *     Test the input parameters.
00156 *
00157       INFO = 0
00158       C1 = PATH( 1: 1 )
00159       C2 = PATH( 2: 3 )
00160       TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
00161       NOTRAN = .NOT.TRAN
00162       GEN = LSAME( PATH( 2: 2 ), 'G' )
00163       QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
00164       SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
00165       TRI = LSAME( PATH( 2: 2 ), 'T' )
00166       BAND = LSAME( PATH( 3: 3 ), 'B' )
00167       IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN
00168          INFO = -1
00169       ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
00170      $          THEN
00171          INFO = -2
00172       ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
00173      $         ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
00174          INFO = -3
00175       ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
00176      $         ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
00177          INFO = -4
00178       ELSE IF( M.LT.0 ) THEN
00179          INFO = -5
00180       ELSE IF( N.LT.0 ) THEN
00181          INFO = -6
00182       ELSE IF( BAND .AND. KL.LT.0 ) THEN
00183          INFO = -7
00184       ELSE IF( BAND .AND. KU.LT.0 ) THEN
00185          INFO = -8
00186       ELSE IF( NRHS.LT.0 ) THEN
00187          INFO = -9
00188       ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
00189      $         ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
00190      $         ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
00191          INFO = -11
00192       ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
00193      $         ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
00194          INFO = -13
00195       ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
00196      $         ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
00197          INFO = -15
00198       END IF
00199       IF( INFO.NE.0 ) THEN
00200          CALL XERBLA( 'SLARHS', -INFO )
00201          RETURN
00202       END IF
00203 *
00204 *     Initialize X to NRHS random vectors unless XTYPE = 'C'.
00205 *
00206       IF( TRAN ) THEN
00207          NX = M
00208          MB = N
00209       ELSE
00210          NX = N
00211          MB = M
00212       END IF
00213       IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
00214          DO 10 J = 1, NRHS
00215             CALL SLARNV( 2, ISEED, N, X( 1, J ) )
00216    10    CONTINUE
00217       END IF
00218 *
00219 *     Multiply X by op( A ) using an appropriate
00220 *     matrix multiply routine.
00221 *
00222       IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
00223      $    LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
00224      $    LSAMEN( 2, C2, 'RQ' ) ) THEN
00225 *
00226 *        General matrix
00227 *
00228          CALL SGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
00229      $               ZERO, B, LDB )
00230 *
00231       ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
00232 *
00233 *        Symmetric matrix, 2-D storage
00234 *
00235          CALL SSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
00236      $               B, LDB )
00237 *
00238       ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
00239 *
00240 *        General matrix, band storage
00241 *
00242          DO 20 J = 1, NRHS
00243             CALL SGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
00244      $                  1, ZERO, B( 1, J ), 1 )
00245    20    CONTINUE
00246 *
00247       ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
00248 *
00249 *        Symmetric matrix, band storage
00250 *
00251          DO 30 J = 1, NRHS
00252             CALL SSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
00253      $                  B( 1, J ), 1 )
00254    30    CONTINUE
00255 *
00256       ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
00257 *
00258 *        Symmetric matrix, packed storage
00259 *
00260          DO 40 J = 1, NRHS
00261             CALL SSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
00262      $                  1 )
00263    40    CONTINUE
00264 *
00265       ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
00266 *
00267 *        Triangular matrix.  Note that for triangular matrices,
00268 *           KU = 1 => non-unit triangular
00269 *           KU = 2 => unit triangular
00270 *
00271          CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
00272          IF( KU.EQ.2 ) THEN
00273             DIAG = 'U'
00274          ELSE
00275             DIAG = 'N'
00276          END IF
00277          CALL STRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
00278      $               LDB )
00279 *
00280       ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
00281 *
00282 *        Triangular matrix, packed storage
00283 *
00284          CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
00285          IF( KU.EQ.2 ) THEN
00286             DIAG = 'U'
00287          ELSE
00288             DIAG = 'N'
00289          END IF
00290          DO 50 J = 1, NRHS
00291             CALL STPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
00292    50    CONTINUE
00293 *
00294       ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
00295 *
00296 *        Triangular matrix, banded storage
00297 *
00298          CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
00299          IF( KU.EQ.2 ) THEN
00300             DIAG = 'U'
00301          ELSE
00302             DIAG = 'N'
00303          END IF
00304          DO 60 J = 1, NRHS
00305             CALL STBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
00306    60    CONTINUE
00307 *
00308       ELSE
00309 *
00310 *        If PATH is none of the above, return with an error code.
00311 *
00312          INFO = -1
00313          CALL XERBLA( 'SLARHS', -INFO )
00314       END IF
00315 *
00316       RETURN
00317 *
00318 *     End of SLARHS
00319 *
00320       END