LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
strsm.f
Go to the documentation of this file.
00001 *> \brief \b STRSM
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       REAL ALPHA
00015 *       INTEGER LDA,LDB,M,N
00016 *       CHARACTER DIAG,SIDE,TRANSA,UPLO
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       REAL A(LDA,*),B(LDB,*)
00020 *       ..
00021 *  
00022 *
00023 *> \par Purpose:
00024 *  =============
00025 *>
00026 *> \verbatim
00027 *>
00028 *> STRSM  solves one of the matrix equations
00029 *>
00030 *>    op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
00031 *>
00032 *> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
00033 *> non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
00034 *>
00035 *>    op( A ) = A   or   op( A ) = A**T.
00036 *>
00037 *> The matrix X is overwritten on B.
00038 *> \endverbatim
00039 *
00040 *  Arguments:
00041 *  ==========
00042 *
00043 *> \param[in] SIDE
00044 *> \verbatim
00045 *>          SIDE is CHARACTER*1
00046 *>           On entry, SIDE specifies whether op( A ) appears on the left
00047 *>           or right of X as follows:
00048 *>
00049 *>              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
00050 *>
00051 *>              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
00052 *> \endverbatim
00053 *>
00054 *> \param[in] UPLO
00055 *> \verbatim
00056 *>          UPLO is CHARACTER*1
00057 *>           On entry, UPLO specifies whether the matrix A is an upper or
00058 *>           lower triangular matrix as follows:
00059 *>
00060 *>              UPLO = 'U' or 'u'   A is an upper triangular matrix.
00061 *>
00062 *>              UPLO = 'L' or 'l'   A is a lower triangular matrix.
00063 *> \endverbatim
00064 *>
00065 *> \param[in] TRANSA
00066 *> \verbatim
00067 *>          TRANSA is CHARACTER*1
00068 *>           On entry, TRANSA specifies the form of op( A ) to be used in
00069 *>           the matrix multiplication as follows:
00070 *>
00071 *>              TRANSA = 'N' or 'n'   op( A ) = A.
00072 *>
00073 *>              TRANSA = 'T' or 't'   op( A ) = A**T.
00074 *>
00075 *>              TRANSA = 'C' or 'c'   op( A ) = A**T.
00076 *> \endverbatim
00077 *>
00078 *> \param[in] DIAG
00079 *> \verbatim
00080 *>          DIAG is CHARACTER*1
00081 *>           On entry, DIAG specifies whether or not A is unit triangular
00082 *>           as follows:
00083 *>
00084 *>              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
00085 *>
00086 *>              DIAG = 'N' or 'n'   A is not assumed to be unit
00087 *>                                  triangular.
00088 *> \endverbatim
00089 *>
00090 *> \param[in] M
00091 *> \verbatim
00092 *>          M is INTEGER
00093 *>           On entry, M specifies the number of rows of B. M must be at
00094 *>           least zero.
00095 *> \endverbatim
00096 *>
00097 *> \param[in] N
00098 *> \verbatim
00099 *>          N is INTEGER
00100 *>           On entry, N specifies the number of columns of B.  N must be
00101 *>           at least zero.
00102 *> \endverbatim
00103 *>
00104 *> \param[in] ALPHA
00105 *> \verbatim
00106 *>          ALPHA is REAL
00107 *>           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
00108 *>           zero then  A is not referenced and  B need not be set before
00109 *>           entry.
00110 *> \endverbatim
00111 *>
00112 *> \param[in] A
00113 *> \verbatim
00114 *>          A is REAL array of DIMENSION ( LDA, k ),
00115 *>           where k is m when SIDE = 'L' or 'l'  
00116 *>             and k is n when SIDE = 'R' or 'r'.
00117 *>           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
00118 *>           upper triangular part of the array  A must contain the upper
00119 *>           triangular matrix  and the strictly lower triangular part of
00120 *>           A is not referenced.
00121 *>           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
00122 *>           lower triangular part of the array  A must contain the lower
00123 *>           triangular matrix  and the strictly upper triangular part of
00124 *>           A is not referenced.
00125 *>           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
00126 *>           A  are not referenced either,  but are assumed to be  unity.
00127 *> \endverbatim
00128 *>
00129 *> \param[in] LDA
00130 *> \verbatim
00131 *>          LDA is INTEGER
00132 *>           On entry, LDA specifies the first dimension of A as declared
00133 *>           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
00134 *>           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
00135 *>           then LDA must be at least max( 1, n ).
00136 *> \endverbatim
00137 *>
00138 *> \param[in,out] B
00139 *> \verbatim
00140 *>          B is REAL array of DIMENSION ( LDB, n ).
00141 *>           Before entry,  the leading  m by n part of the array  B must
00142 *>           contain  the  right-hand  side  matrix  B,  and  on exit  is
00143 *>           overwritten by the solution matrix  X.
00144 *> \endverbatim
00145 *>
00146 *> \param[in] LDB
00147 *> \verbatim
00148 *>          LDB is INTEGER
00149 *>           On entry, LDB specifies the first dimension of B as declared
00150 *>           in  the  calling  (sub)  program.   LDB  must  be  at  least
00151 *>           max( 1, m ).
00152 *> \endverbatim
00153 *
00154 *  Authors:
00155 *  ========
00156 *
00157 *> \author Univ. of Tennessee 
00158 *> \author Univ. of California Berkeley 
00159 *> \author Univ. of Colorado Denver 
00160 *> \author NAG Ltd. 
00161 *
00162 *> \date November 2011
00163 *
00164 *> \ingroup single_blas_level3
00165 *
00166 *> \par Further Details:
00167 *  =====================
00168 *>
00169 *> \verbatim
00170 *>
00171 *>  Level 3 Blas routine.
00172 *>
00173 *>
00174 *>  -- Written on 8-February-1989.
00175 *>     Jack Dongarra, Argonne National Laboratory.
00176 *>     Iain Duff, AERE Harwell.
00177 *>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00178 *>     Sven Hammarling, Numerical Algorithms Group Ltd.
00179 *> \endverbatim
00180 *>
00181 *  =====================================================================
00182       SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
00183 *
00184 *  -- Reference BLAS level3 routine (version 3.4.0) --
00185 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
00186 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00187 *     November 2011
00188 *
00189 *     .. Scalar Arguments ..
00190       REAL ALPHA
00191       INTEGER LDA,LDB,M,N
00192       CHARACTER DIAG,SIDE,TRANSA,UPLO
00193 *     ..
00194 *     .. Array Arguments ..
00195       REAL A(LDA,*),B(LDB,*)
00196 *     ..
00197 *
00198 *  =====================================================================
00199 *
00200 *     .. External Functions ..
00201       LOGICAL LSAME
00202       EXTERNAL LSAME
00203 *     ..
00204 *     .. External Subroutines ..
00205       EXTERNAL XERBLA
00206 *     ..
00207 *     .. Intrinsic Functions ..
00208       INTRINSIC MAX
00209 *     ..
00210 *     .. Local Scalars ..
00211       REAL TEMP
00212       INTEGER I,INFO,J,K,NROWA
00213       LOGICAL LSIDE,NOUNIT,UPPER
00214 *     ..
00215 *     .. Parameters ..
00216       REAL ONE,ZERO
00217       PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
00218 *     ..
00219 *
00220 *     Test the input parameters.
00221 *
00222       LSIDE = LSAME(SIDE,'L')
00223       IF (LSIDE) THEN
00224           NROWA = M
00225       ELSE
00226           NROWA = N
00227       END IF
00228       NOUNIT = LSAME(DIAG,'N')
00229       UPPER = LSAME(UPLO,'U')
00230 *
00231       INFO = 0
00232       IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
00233           INFO = 1
00234       ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
00235           INFO = 2
00236       ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
00237      +         (.NOT.LSAME(TRANSA,'T')) .AND.
00238      +         (.NOT.LSAME(TRANSA,'C'))) THEN
00239           INFO = 3
00240       ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
00241           INFO = 4
00242       ELSE IF (M.LT.0) THEN
00243           INFO = 5
00244       ELSE IF (N.LT.0) THEN
00245           INFO = 6
00246       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
00247           INFO = 9
00248       ELSE IF (LDB.LT.MAX(1,M)) THEN
00249           INFO = 11
00250       END IF
00251       IF (INFO.NE.0) THEN
00252           CALL XERBLA('STRSM ',INFO)
00253           RETURN
00254       END IF
00255 *
00256 *     Quick return if possible.
00257 *
00258       IF (M.EQ.0 .OR. N.EQ.0) RETURN
00259 *
00260 *     And when  alpha.eq.zero.
00261 *
00262       IF (ALPHA.EQ.ZERO) THEN
00263           DO 20 J = 1,N
00264               DO 10 I = 1,M
00265                   B(I,J) = ZERO
00266    10         CONTINUE
00267    20     CONTINUE
00268           RETURN
00269       END IF
00270 *
00271 *     Start the operations.
00272 *
00273       IF (LSIDE) THEN
00274           IF (LSAME(TRANSA,'N')) THEN
00275 *
00276 *           Form  B := alpha*inv( A )*B.
00277 *
00278               IF (UPPER) THEN
00279                   DO 60 J = 1,N
00280                       IF (ALPHA.NE.ONE) THEN
00281                           DO 30 I = 1,M
00282                               B(I,J) = ALPHA*B(I,J)
00283    30                     CONTINUE
00284                       END IF
00285                       DO 50 K = M,1,-1
00286                           IF (B(K,J).NE.ZERO) THEN
00287                               IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
00288                               DO 40 I = 1,K - 1
00289                                   B(I,J) = B(I,J) - B(K,J)*A(I,K)
00290    40                         CONTINUE
00291                           END IF
00292    50                 CONTINUE
00293    60             CONTINUE
00294               ELSE
00295                   DO 100 J = 1,N
00296                       IF (ALPHA.NE.ONE) THEN
00297                           DO 70 I = 1,M
00298                               B(I,J) = ALPHA*B(I,J)
00299    70                     CONTINUE
00300                       END IF
00301                       DO 90 K = 1,M
00302                           IF (B(K,J).NE.ZERO) THEN
00303                               IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
00304                               DO 80 I = K + 1,M
00305                                   B(I,J) = B(I,J) - B(K,J)*A(I,K)
00306    80                         CONTINUE
00307                           END IF
00308    90                 CONTINUE
00309   100             CONTINUE
00310               END IF
00311           ELSE
00312 *
00313 *           Form  B := alpha*inv( A**T )*B.
00314 *
00315               IF (UPPER) THEN
00316                   DO 130 J = 1,N
00317                       DO 120 I = 1,M
00318                           TEMP = ALPHA*B(I,J)
00319                           DO 110 K = 1,I - 1
00320                               TEMP = TEMP - A(K,I)*B(K,J)
00321   110                     CONTINUE
00322                           IF (NOUNIT) TEMP = TEMP/A(I,I)
00323                           B(I,J) = TEMP
00324   120                 CONTINUE
00325   130             CONTINUE
00326               ELSE
00327                   DO 160 J = 1,N
00328                       DO 150 I = M,1,-1
00329                           TEMP = ALPHA*B(I,J)
00330                           DO 140 K = I + 1,M
00331                               TEMP = TEMP - A(K,I)*B(K,J)
00332   140                     CONTINUE
00333                           IF (NOUNIT) TEMP = TEMP/A(I,I)
00334                           B(I,J) = TEMP
00335   150                 CONTINUE
00336   160             CONTINUE
00337               END IF
00338           END IF
00339       ELSE
00340           IF (LSAME(TRANSA,'N')) THEN
00341 *
00342 *           Form  B := alpha*B*inv( A ).
00343 *
00344               IF (UPPER) THEN
00345                   DO 210 J = 1,N
00346                       IF (ALPHA.NE.ONE) THEN
00347                           DO 170 I = 1,M
00348                               B(I,J) = ALPHA*B(I,J)
00349   170                     CONTINUE
00350                       END IF
00351                       DO 190 K = 1,J - 1
00352                           IF (A(K,J).NE.ZERO) THEN
00353                               DO 180 I = 1,M
00354                                   B(I,J) = B(I,J) - A(K,J)*B(I,K)
00355   180                         CONTINUE
00356                           END IF
00357   190                 CONTINUE
00358                       IF (NOUNIT) THEN
00359                           TEMP = ONE/A(J,J)
00360                           DO 200 I = 1,M
00361                               B(I,J) = TEMP*B(I,J)
00362   200                     CONTINUE
00363                       END IF
00364   210             CONTINUE
00365               ELSE
00366                   DO 260 J = N,1,-1
00367                       IF (ALPHA.NE.ONE) THEN
00368                           DO 220 I = 1,M
00369                               B(I,J) = ALPHA*B(I,J)
00370   220                     CONTINUE
00371                       END IF
00372                       DO 240 K = J + 1,N
00373                           IF (A(K,J).NE.ZERO) THEN
00374                               DO 230 I = 1,M
00375                                   B(I,J) = B(I,J) - A(K,J)*B(I,K)
00376   230                         CONTINUE
00377                           END IF
00378   240                 CONTINUE
00379                       IF (NOUNIT) THEN
00380                           TEMP = ONE/A(J,J)
00381                           DO 250 I = 1,M
00382                               B(I,J) = TEMP*B(I,J)
00383   250                     CONTINUE
00384                       END IF
00385   260             CONTINUE
00386               END IF
00387           ELSE
00388 *
00389 *           Form  B := alpha*B*inv( A**T ).
00390 *
00391               IF (UPPER) THEN
00392                   DO 310 K = N,1,-1
00393                       IF (NOUNIT) THEN
00394                           TEMP = ONE/A(K,K)
00395                           DO 270 I = 1,M
00396                               B(I,K) = TEMP*B(I,K)
00397   270                     CONTINUE
00398                       END IF
00399                       DO 290 J = 1,K - 1
00400                           IF (A(J,K).NE.ZERO) THEN
00401                               TEMP = A(J,K)
00402                               DO 280 I = 1,M
00403                                   B(I,J) = B(I,J) - TEMP*B(I,K)
00404   280                         CONTINUE
00405                           END IF
00406   290                 CONTINUE
00407                       IF (ALPHA.NE.ONE) THEN
00408                           DO 300 I = 1,M
00409                               B(I,K) = ALPHA*B(I,K)
00410   300                     CONTINUE
00411                       END IF
00412   310             CONTINUE
00413               ELSE
00414                   DO 360 K = 1,N
00415                       IF (NOUNIT) THEN
00416                           TEMP = ONE/A(K,K)
00417                           DO 320 I = 1,M
00418                               B(I,K) = TEMP*B(I,K)
00419   320                     CONTINUE
00420                       END IF
00421                       DO 340 J = K + 1,N
00422                           IF (A(J,K).NE.ZERO) THEN
00423                               TEMP = A(J,K)
00424                               DO 330 I = 1,M
00425                                   B(I,J) = B(I,J) - TEMP*B(I,K)
00426   330                         CONTINUE
00427                           END IF
00428   340                 CONTINUE
00429                       IF (ALPHA.NE.ONE) THEN
00430                           DO 350 I = 1,M
00431                               B(I,K) = ALPHA*B(I,K)
00432   350                     CONTINUE
00433                       END IF
00434   360             CONTINUE
00435               END IF
00436           END IF
00437       END IF
00438 *
00439       RETURN
00440 *
00441 *     End of STRSM .
00442 *
00443       END
 All Files Functions