 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE SERRGT( PATH, NUNIT ) 00002 * 00003 * -- LAPACK test routine (version 3.1) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. Scalar Arguments .. 00008 CHARACTER*3 PATH 00009 INTEGER NUNIT 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * SERRGT tests the error exits for the REAL tridiagonal 00016 * routines. 00017 * 00018 * Arguments 00019 * ========= 00020 * 00021 * PATH (input) CHARACTER*3 00022 * The LAPACK path name for the routines to be tested. 00023 * 00024 * NUNIT (input) INTEGER 00025 * The unit number for output. 00026 * 00027 * ===================================================================== 00028 * 00029 * .. Parameters .. 00030 INTEGER NMAX 00031 PARAMETER ( NMAX = 2 ) 00032 * .. 00033 * .. Local Scalars .. 00034 CHARACTER*2 C2 00035 INTEGER INFO 00036 REAL ANORM, RCOND 00037 * .. 00038 * .. Local Arrays .. 00039 INTEGER IP( NMAX ), IW( NMAX ) 00040 REAL B( NMAX ), C( NMAX ), CF( NMAX ), D( NMAX ), 00041 $ DF( NMAX ), E( NMAX ), EF( NMAX ), F( NMAX ), 00042 $ R1( NMAX ), R2( NMAX ), W( NMAX ), X( NMAX ) 00043 * .. 00044 * .. External Functions .. 00045 LOGICAL LSAMEN 00046 EXTERNAL LSAMEN 00047 * .. 00048 * .. External Subroutines .. 00049 EXTERNAL ALAESM, CHKXER, SGTCON, SGTRFS, SGTTRF, SGTTRS, 00050 $ SPTCON, SPTRFS, SPTTRF, SPTTRS 00051 * .. 00052 * .. Scalars in Common .. 00053 LOGICAL LERR, OK 00054 CHARACTER*32 SRNAMT 00055 INTEGER INFOT, NOUT 00056 * .. 00057 * .. Common blocks .. 00058 COMMON / INFOC / INFOT, NOUT, OK, LERR 00059 COMMON / SRNAMC / SRNAMT 00060 * .. 00061 * .. Executable Statements .. 00062 * 00063 NOUT = NUNIT 00064 WRITE( NOUT, FMT = * ) 00065 C2 = PATH( 2: 3 ) 00066 D( 1 ) = 1. 00067 D( 2 ) = 2. 00068 DF( 1 ) = 1. 00069 DF( 2 ) = 2. 00070 E( 1 ) = 3. 00071 E( 2 ) = 4. 00072 EF( 1 ) = 3. 00073 EF( 2 ) = 4. 00074 ANORM = 1.0 00075 OK = .TRUE. 00076 * 00077 IF( LSAMEN( 2, C2, 'GT' ) ) THEN 00078 * 00079 * Test error exits for the general tridiagonal routines. 00080 * 00081 * SGTTRF 00082 * 00083 SRNAMT = 'SGTTRF' 00084 INFOT = 1 00085 CALL SGTTRF( -1, C, D, E, F, IP, INFO ) 00086 CALL CHKXER( 'SGTTRF', INFOT, NOUT, LERR, OK ) 00087 * 00088 * SGTTRS 00089 * 00090 SRNAMT = 'SGTTRS' 00091 INFOT = 1 00092 CALL SGTTRS( '/', 0, 0, C, D, E, F, IP, X, 1, INFO ) 00093 CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK ) 00094 INFOT = 2 00095 CALL SGTTRS( 'N', -1, 0, C, D, E, F, IP, X, 1, INFO ) 00096 CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK ) 00097 INFOT = 3 00098 CALL SGTTRS( 'N', 0, -1, C, D, E, F, IP, X, 1, INFO ) 00099 CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK ) 00100 INFOT = 10 00101 CALL SGTTRS( 'N', 2, 1, C, D, E, F, IP, X, 1, INFO ) 00102 CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK ) 00103 * 00104 * SGTRFS 00105 * 00106 SRNAMT = 'SGTRFS' 00107 INFOT = 1 00108 CALL SGTRFS( '/', 0, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 1, 00109 $ R1, R2, W, IW, INFO ) 00110 CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK ) 00111 INFOT = 2 00112 CALL SGTRFS( 'N', -1, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 00113 $ 1, R1, R2, W, IW, INFO ) 00114 CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK ) 00115 INFOT = 3 00116 CALL SGTRFS( 'N', 0, -1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 00117 $ 1, R1, R2, W, IW, INFO ) 00118 CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK ) 00119 INFOT = 13 00120 CALL SGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 2, 00121 $ R1, R2, W, IW, INFO ) 00122 CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK ) 00123 INFOT = 15 00124 CALL SGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 2, X, 1, 00125 $ R1, R2, W, IW, INFO ) 00126 CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK ) 00127 * 00128 * SGTCON 00129 * 00130 SRNAMT = 'SGTCON' 00131 INFOT = 1 00132 CALL SGTCON( '/', 0, C, D, E, F, IP, ANORM, RCOND, W, IW, 00133 $ INFO ) 00134 CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK ) 00135 INFOT = 2 00136 CALL SGTCON( 'I', -1, C, D, E, F, IP, ANORM, RCOND, W, IW, 00137 $ INFO ) 00138 CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK ) 00139 INFOT = 8 00140 CALL SGTCON( 'I', 0, C, D, E, F, IP, -ANORM, RCOND, W, IW, 00141 $ INFO ) 00142 CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK ) 00143 * 00144 ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN 00145 * 00146 * Test error exits for the positive definite tridiagonal 00147 * routines. 00148 * 00149 * SPTTRF 00150 * 00151 SRNAMT = 'SPTTRF' 00152 INFOT = 1 00153 CALL SPTTRF( -1, D, E, INFO ) 00154 CALL CHKXER( 'SPTTRF', INFOT, NOUT, LERR, OK ) 00155 * 00156 * SPTTRS 00157 * 00158 SRNAMT = 'SPTTRS' 00159 INFOT = 1 00160 CALL SPTTRS( -1, 0, D, E, X, 1, INFO ) 00161 CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK ) 00162 INFOT = 2 00163 CALL SPTTRS( 0, -1, D, E, X, 1, INFO ) 00164 CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK ) 00165 INFOT = 6 00166 CALL SPTTRS( 2, 1, D, E, X, 1, INFO ) 00167 CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK ) 00168 * 00169 * SPTRFS 00170 * 00171 SRNAMT = 'SPTRFS' 00172 INFOT = 1 00173 CALL SPTRFS( -1, 0, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO ) 00174 CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK ) 00175 INFOT = 2 00176 CALL SPTRFS( 0, -1, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO ) 00177 CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK ) 00178 INFOT = 8 00179 CALL SPTRFS( 2, 1, D, E, DF, EF, B, 1, X, 2, R1, R2, W, INFO ) 00180 CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK ) 00181 INFOT = 10 00182 CALL SPTRFS( 2, 1, D, E, DF, EF, B, 2, X, 1, R1, R2, W, INFO ) 00183 CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK ) 00184 * 00185 * SPTCON 00186 * 00187 SRNAMT = 'SPTCON' 00188 INFOT = 1 00189 CALL SPTCON( -1, D, E, ANORM, RCOND, W, INFO ) 00190 CALL CHKXER( 'SPTCON', INFOT, NOUT, LERR, OK ) 00191 INFOT = 4 00192 CALL SPTCON( 0, D, E, -ANORM, RCOND, W, INFO ) 00193 CALL CHKXER( 'SPTCON', INFOT, NOUT, LERR, OK ) 00194 END IF 00195 * 00196 * Print a summary line. 00197 * 00198 CALL ALAESM( PATH, OK, NOUT ) 00199 * 00200 RETURN 00201 * 00202 * End of SERRGT 00203 * 00204 END
1.7.3 
