|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DERRGT( 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 * DERRGT tests the error exits for the DOUBLE PRECISION 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 DOUBLE PRECISION ANORM, RCOND 00037 * .. 00038 * .. Local Arrays .. 00039 INTEGER IP( NMAX ), IW( NMAX ) 00040 DOUBLE PRECISION 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, DGTCON, DGTRFS, DGTTRF, DGTTRS, 00050 $ DPTCON, DPTRFS, DPTTRF, DPTTRS 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.D0 00067 D( 2 ) = 2.D0 00068 DF( 1 ) = 1.D0 00069 DF( 2 ) = 2.D0 00070 E( 1 ) = 3.D0 00071 E( 2 ) = 4.D0 00072 EF( 1 ) = 3.D0 00073 EF( 2 ) = 4.D0 00074 ANORM = 1.0D0 00075 OK = .TRUE. 00076 * 00077 IF( LSAMEN( 2, C2, 'GT' ) ) THEN 00078 * 00079 * Test error exits for the general tridiagonal routines. 00080 * 00081 * DGTTRF 00082 * 00083 SRNAMT = 'DGTTRF' 00084 INFOT = 1 00085 CALL DGTTRF( -1, C, D, E, F, IP, INFO ) 00086 CALL CHKXER( 'DGTTRF', INFOT, NOUT, LERR, OK ) 00087 * 00088 * DGTTRS 00089 * 00090 SRNAMT = 'DGTTRS' 00091 INFOT = 1 00092 CALL DGTTRS( '/', 0, 0, C, D, E, F, IP, X, 1, INFO ) 00093 CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK ) 00094 INFOT = 2 00095 CALL DGTTRS( 'N', -1, 0, C, D, E, F, IP, X, 1, INFO ) 00096 CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK ) 00097 INFOT = 3 00098 CALL DGTTRS( 'N', 0, -1, C, D, E, F, IP, X, 1, INFO ) 00099 CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK ) 00100 INFOT = 10 00101 CALL DGTTRS( 'N', 2, 1, C, D, E, F, IP, X, 1, INFO ) 00102 CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK ) 00103 * 00104 * DGTRFS 00105 * 00106 SRNAMT = 'DGTRFS' 00107 INFOT = 1 00108 CALL DGTRFS( '/', 0, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 1, 00109 $ R1, R2, W, IW, INFO ) 00110 CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK ) 00111 INFOT = 2 00112 CALL DGTRFS( 'N', -1, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 00113 $ 1, R1, R2, W, IW, INFO ) 00114 CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK ) 00115 INFOT = 3 00116 CALL DGTRFS( 'N', 0, -1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 00117 $ 1, R1, R2, W, IW, INFO ) 00118 CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK ) 00119 INFOT = 13 00120 CALL DGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 2, 00121 $ R1, R2, W, IW, INFO ) 00122 CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK ) 00123 INFOT = 15 00124 CALL DGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 2, X, 1, 00125 $ R1, R2, W, IW, INFO ) 00126 CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK ) 00127 * 00128 * DGTCON 00129 * 00130 SRNAMT = 'DGTCON' 00131 INFOT = 1 00132 CALL DGTCON( '/', 0, C, D, E, F, IP, ANORM, RCOND, W, IW, 00133 $ INFO ) 00134 CALL CHKXER( 'DGTCON', INFOT, NOUT, LERR, OK ) 00135 INFOT = 2 00136 CALL DGTCON( 'I', -1, C, D, E, F, IP, ANORM, RCOND, W, IW, 00137 $ INFO ) 00138 CALL CHKXER( 'DGTCON', INFOT, NOUT, LERR, OK ) 00139 INFOT = 8 00140 CALL DGTCON( 'I', 0, C, D, E, F, IP, -ANORM, RCOND, W, IW, 00141 $ INFO ) 00142 CALL CHKXER( 'DGTCON', 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 * DPTTRF 00150 * 00151 SRNAMT = 'DPTTRF' 00152 INFOT = 1 00153 CALL DPTTRF( -1, D, E, INFO ) 00154 CALL CHKXER( 'DPTTRF', INFOT, NOUT, LERR, OK ) 00155 * 00156 * DPTTRS 00157 * 00158 SRNAMT = 'DPTTRS' 00159 INFOT = 1 00160 CALL DPTTRS( -1, 0, D, E, X, 1, INFO ) 00161 CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK ) 00162 INFOT = 2 00163 CALL DPTTRS( 0, -1, D, E, X, 1, INFO ) 00164 CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK ) 00165 INFOT = 6 00166 CALL DPTTRS( 2, 1, D, E, X, 1, INFO ) 00167 CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK ) 00168 * 00169 * DPTRFS 00170 * 00171 SRNAMT = 'DPTRFS' 00172 INFOT = 1 00173 CALL DPTRFS( -1, 0, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO ) 00174 CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK ) 00175 INFOT = 2 00176 CALL DPTRFS( 0, -1, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO ) 00177 CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK ) 00178 INFOT = 8 00179 CALL DPTRFS( 2, 1, D, E, DF, EF, B, 1, X, 2, R1, R2, W, INFO ) 00180 CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK ) 00181 INFOT = 10 00182 CALL DPTRFS( 2, 1, D, E, DF, EF, B, 2, X, 1, R1, R2, W, INFO ) 00183 CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK ) 00184 * 00185 * DPTCON 00186 * 00187 SRNAMT = 'DPTCON' 00188 INFOT = 1 00189 CALL DPTCON( -1, D, E, ANORM, RCOND, W, INFO ) 00190 CALL CHKXER( 'DPTCON', INFOT, NOUT, LERR, OK ) 00191 INFOT = 4 00192 CALL DPTCON( 0, D, E, -ANORM, RCOND, W, INFO ) 00193 CALL CHKXER( 'DPTCON', 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 DERRGT 00203 * 00204 END
1.7.3 
