 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) 00002 * 00003 * -- LAPACK routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER DIAG, TRANS, UPLO 00010 INTEGER INFO, LDB, N, NRHS 00011 * .. 00012 * .. Array Arguments .. 00013 DOUBLE PRECISION AP( * ), B( LDB, * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * DTPTRS solves a triangular system of the form 00020 * 00021 * A * X = B or A**T * X = B, 00022 * 00023 * where A is a triangular matrix of order N stored in packed format, 00024 * and B is an N-by-NRHS matrix. A check is made to verify that A is 00025 * nonsingular. 00026 * 00027 * Arguments 00028 * ========= 00029 * 00030 * UPLO (input) CHARACTER*1 00031 * = 'U': A is upper triangular; 00032 * = 'L': A is lower triangular. 00033 * 00034 * TRANS (input) CHARACTER*1 00035 * Specifies the form of the system of equations: 00036 * = 'N': A * X = B (No transpose) 00037 * = 'T': A**T * X = B (Transpose) 00038 * = 'C': A**H * X = B (Conjugate transpose = Transpose) 00039 * 00040 * DIAG (input) CHARACTER*1 00041 * = 'N': A is non-unit triangular; 00042 * = 'U': A is unit triangular. 00043 * 00044 * N (input) INTEGER 00045 * The order of the matrix A. N >= 0. 00046 * 00047 * NRHS (input) INTEGER 00048 * The number of right hand sides, i.e., the number of columns 00049 * of the matrix B. NRHS >= 0. 00050 * 00051 * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) 00052 * The upper or lower triangular matrix A, packed columnwise in 00053 * a linear array. The j-th column of A is stored in the array 00054 * AP as follows: 00055 * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; 00056 * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. 00057 * 00058 * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) 00059 * On entry, the right hand side matrix B. 00060 * On exit, if INFO = 0, the solution matrix X. 00061 * 00062 * LDB (input) INTEGER 00063 * The leading dimension of the array B. LDB >= max(1,N). 00064 * 00065 * INFO (output) INTEGER 00066 * = 0: successful exit 00067 * < 0: if INFO = -i, the i-th argument had an illegal value 00068 * > 0: if INFO = i, the i-th diagonal element of A is zero, 00069 * indicating that the matrix is singular and the 00070 * solutions X have not been computed. 00071 * 00072 * ===================================================================== 00073 * 00074 * .. Parameters .. 00075 DOUBLE PRECISION ZERO 00076 PARAMETER ( ZERO = 0.0D+0 ) 00077 * .. 00078 * .. Local Scalars .. 00079 LOGICAL NOUNIT, UPPER 00080 INTEGER J, JC 00081 * .. 00082 * .. External Functions .. 00083 LOGICAL LSAME 00084 EXTERNAL LSAME 00085 * .. 00086 * .. External Subroutines .. 00087 EXTERNAL DTPSV, XERBLA 00088 * .. 00089 * .. Intrinsic Functions .. 00090 INTRINSIC MAX 00091 * .. 00092 * .. Executable Statements .. 00093 * 00094 * Test the input parameters. 00095 * 00096 INFO = 0 00097 UPPER = LSAME( UPLO, 'U' ) 00098 NOUNIT = LSAME( DIAG, 'N' ) 00099 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00100 INFO = -1 00101 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. 00102 $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 00103 INFO = -2 00104 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 00105 INFO = -3 00106 ELSE IF( N.LT.0 ) THEN 00107 INFO = -4 00108 ELSE IF( NRHS.LT.0 ) THEN 00109 INFO = -5 00110 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 00111 INFO = -8 00112 END IF 00113 IF( INFO.NE.0 ) THEN 00114 CALL XERBLA( 'DTPTRS', -INFO ) 00115 RETURN 00116 END IF 00117 * 00118 * Quick return if possible 00119 * 00120 IF( N.EQ.0 ) 00121 $ RETURN 00122 * 00123 * Check for singularity. 00124 * 00125 IF( NOUNIT ) THEN 00126 IF( UPPER ) THEN 00127 JC = 1 00128 DO 10 INFO = 1, N 00129 IF( AP( JC+INFO-1 ).EQ.ZERO ) 00130 $ RETURN 00131 JC = JC + INFO 00132 10 CONTINUE 00133 ELSE 00134 JC = 1 00135 DO 20 INFO = 1, N 00136 IF( AP( JC ).EQ.ZERO ) 00137 $ RETURN 00138 JC = JC + N - INFO + 1 00139 20 CONTINUE 00140 END IF 00141 END IF 00142 INFO = 0 00143 * 00144 * Solve A * x = b or A**T * x = b. 00145 * 00146 DO 30 J = 1, NRHS 00147 CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 ) 00148 30 CONTINUE 00149 * 00150 RETURN 00151 * 00152 * End of DTPTRS 00153 * 00154 END
1.7.3 
