|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DERRGE( 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 * DERRGE tests the error exits for the DOUBLE PRECISION routines 00016 * for general matrices. 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, LW 00031 PARAMETER ( NMAX = 4, LW = 3*NMAX ) 00032 * .. 00033 * .. Local Scalars .. 00034 CHARACTER*2 C2 00035 INTEGER I, INFO, J 00036 DOUBLE PRECISION ANRM, CCOND, RCOND 00037 * .. 00038 * .. Local Arrays .. 00039 INTEGER IP( NMAX ), IW( NMAX ) 00040 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), 00041 $ R1( NMAX ), R2( NMAX ), W( LW ), X( NMAX ) 00042 * .. 00043 * .. External Functions .. 00044 LOGICAL LSAMEN 00045 EXTERNAL LSAMEN 00046 * .. 00047 * .. External Subroutines .. 00048 EXTERNAL ALAESM, CHKXER, DGBCON, DGBEQU, DGBRFS, DGBTF2, 00049 $ DGBTRF, DGBTRS, DGECON, DGEEQU, DGERFS, DGETF2, 00050 $ DGETRF, DGETRI, DGETRS 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 * .. Intrinsic Functions .. 00062 INTRINSIC DBLE 00063 * .. 00064 * .. Executable Statements .. 00065 * 00066 NOUT = NUNIT 00067 WRITE( NOUT, FMT = * ) 00068 C2 = PATH( 2: 3 ) 00069 * 00070 * Set the variables to innocuous values. 00071 * 00072 DO 20 J = 1, NMAX 00073 DO 10 I = 1, NMAX 00074 A( I, J ) = 1.D0 / DBLE( I+J ) 00075 AF( I, J ) = 1.D0 / DBLE( I+J ) 00076 10 CONTINUE 00077 B( J ) = 0.D0 00078 R1( J ) = 0.D0 00079 R2( J ) = 0.D0 00080 W( J ) = 0.D0 00081 X( J ) = 0.D0 00082 IP( J ) = J 00083 IW( J ) = J 00084 20 CONTINUE 00085 OK = .TRUE. 00086 * 00087 IF( LSAMEN( 2, C2, 'GE' ) ) THEN 00088 * 00089 * Test error exits of the routines that use the LU decomposition 00090 * of a general matrix. 00091 * 00092 * DGETRF 00093 * 00094 SRNAMT = 'DGETRF' 00095 INFOT = 1 00096 CALL DGETRF( -1, 0, A, 1, IP, INFO ) 00097 CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) 00098 INFOT = 2 00099 CALL DGETRF( 0, -1, A, 1, IP, INFO ) 00100 CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) 00101 INFOT = 4 00102 CALL DGETRF( 2, 1, A, 1, IP, INFO ) 00103 CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) 00104 * 00105 * DGETF2 00106 * 00107 SRNAMT = 'DGETF2' 00108 INFOT = 1 00109 CALL DGETF2( -1, 0, A, 1, IP, INFO ) 00110 CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) 00111 INFOT = 2 00112 CALL DGETF2( 0, -1, A, 1, IP, INFO ) 00113 CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) 00114 INFOT = 4 00115 CALL DGETF2( 2, 1, A, 1, IP, INFO ) 00116 CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) 00117 * 00118 * DGETRI 00119 * 00120 SRNAMT = 'DGETRI' 00121 INFOT = 1 00122 CALL DGETRI( -1, A, 1, IP, W, LW, INFO ) 00123 CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK ) 00124 INFOT = 3 00125 CALL DGETRI( 2, A, 1, IP, W, LW, INFO ) 00126 CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK ) 00127 * 00128 * DGETRS 00129 * 00130 SRNAMT = 'DGETRS' 00131 INFOT = 1 00132 CALL DGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) 00133 CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) 00134 INFOT = 2 00135 CALL DGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO ) 00136 CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) 00137 INFOT = 3 00138 CALL DGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO ) 00139 CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) 00140 INFOT = 5 00141 CALL DGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO ) 00142 CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) 00143 INFOT = 8 00144 CALL DGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO ) 00145 CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) 00146 * 00147 * DGERFS 00148 * 00149 SRNAMT = 'DGERFS' 00150 INFOT = 1 00151 CALL DGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, 00152 $ IW, INFO ) 00153 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00154 INFOT = 2 00155 CALL DGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00156 $ W, IW, INFO ) 00157 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00158 INFOT = 3 00159 CALL DGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00160 $ W, IW, INFO ) 00161 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00162 INFOT = 5 00163 CALL DGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, 00164 $ IW, INFO ) 00165 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00166 INFOT = 7 00167 CALL DGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, 00168 $ IW, INFO ) 00169 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00170 INFOT = 10 00171 CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, 00172 $ IW, INFO ) 00173 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00174 INFOT = 12 00175 CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, 00176 $ IW, INFO ) 00177 CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) 00178 * 00179 * DGECON 00180 * 00181 SRNAMT = 'DGECON' 00182 INFOT = 1 00183 CALL DGECON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO ) 00184 CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) 00185 INFOT = 2 00186 CALL DGECON( '1', -1, A, 1, ANRM, RCOND, W, IW, INFO ) 00187 CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) 00188 INFOT = 4 00189 CALL DGECON( '1', 2, A, 1, ANRM, RCOND, W, IW, INFO ) 00190 CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) 00191 * 00192 * DGEEQU 00193 * 00194 SRNAMT = 'DGEEQU' 00195 INFOT = 1 00196 CALL DGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) 00197 CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) 00198 INFOT = 2 00199 CALL DGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) 00200 CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) 00201 INFOT = 4 00202 CALL DGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) 00203 CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) 00204 * 00205 ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN 00206 * 00207 * Test error exits of the routines that use the LU decomposition 00208 * of a general band matrix. 00209 * 00210 * DGBTRF 00211 * 00212 SRNAMT = 'DGBTRF' 00213 INFOT = 1 00214 CALL DGBTRF( -1, 0, 0, 0, A, 1, IP, INFO ) 00215 CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) 00216 INFOT = 2 00217 CALL DGBTRF( 0, -1, 0, 0, A, 1, IP, INFO ) 00218 CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) 00219 INFOT = 3 00220 CALL DGBTRF( 1, 1, -1, 0, A, 1, IP, INFO ) 00221 CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) 00222 INFOT = 4 00223 CALL DGBTRF( 1, 1, 0, -1, A, 1, IP, INFO ) 00224 CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) 00225 INFOT = 6 00226 CALL DGBTRF( 2, 2, 1, 1, A, 3, IP, INFO ) 00227 CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) 00228 * 00229 * DGBTF2 00230 * 00231 SRNAMT = 'DGBTF2' 00232 INFOT = 1 00233 CALL DGBTF2( -1, 0, 0, 0, A, 1, IP, INFO ) 00234 CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) 00235 INFOT = 2 00236 CALL DGBTF2( 0, -1, 0, 0, A, 1, IP, INFO ) 00237 CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) 00238 INFOT = 3 00239 CALL DGBTF2( 1, 1, -1, 0, A, 1, IP, INFO ) 00240 CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) 00241 INFOT = 4 00242 CALL DGBTF2( 1, 1, 0, -1, A, 1, IP, INFO ) 00243 CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) 00244 INFOT = 6 00245 CALL DGBTF2( 2, 2, 1, 1, A, 3, IP, INFO ) 00246 CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) 00247 * 00248 * DGBTRS 00249 * 00250 SRNAMT = 'DGBTRS' 00251 INFOT = 1 00252 CALL DGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO ) 00253 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00254 INFOT = 2 00255 CALL DGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO ) 00256 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00257 INFOT = 3 00258 CALL DGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO ) 00259 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00260 INFOT = 4 00261 CALL DGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO ) 00262 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00263 INFOT = 5 00264 CALL DGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO ) 00265 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00266 INFOT = 7 00267 CALL DGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO ) 00268 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00269 INFOT = 10 00270 CALL DGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO ) 00271 CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) 00272 * 00273 * DGBRFS 00274 * 00275 SRNAMT = 'DGBRFS' 00276 INFOT = 1 00277 CALL DGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, 00278 $ R2, W, IW, INFO ) 00279 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00280 INFOT = 2 00281 CALL DGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, 00282 $ R2, W, IW, INFO ) 00283 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00284 INFOT = 3 00285 CALL DGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, 00286 $ R2, W, IW, INFO ) 00287 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00288 INFOT = 4 00289 CALL DGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, 00290 $ R2, W, IW, INFO ) 00291 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00292 INFOT = 5 00293 CALL DGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, 00294 $ R2, W, IW, INFO ) 00295 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00296 INFOT = 7 00297 CALL DGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1, 00298 $ R2, W, IW, INFO ) 00299 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00300 INFOT = 9 00301 CALL DGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1, 00302 $ R2, W, IW, INFO ) 00303 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00304 INFOT = 12 00305 CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1, 00306 $ R2, W, IW, INFO ) 00307 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00308 INFOT = 14 00309 CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1, 00310 $ R2, W, IW, INFO ) 00311 CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) 00312 * 00313 * DGBCON 00314 * 00315 SRNAMT = 'DGBCON' 00316 INFOT = 1 00317 CALL DGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00318 CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) 00319 INFOT = 2 00320 CALL DGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, 00321 $ INFO ) 00322 CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) 00323 INFOT = 3 00324 CALL DGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, IW, 00325 $ INFO ) 00326 CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) 00327 INFOT = 4 00328 CALL DGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, IW, 00329 $ INFO ) 00330 CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) 00331 INFOT = 6 00332 CALL DGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, IW, INFO ) 00333 CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) 00334 * 00335 * DGBEQU 00336 * 00337 SRNAMT = 'DGBEQU' 00338 INFOT = 1 00339 CALL DGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, 00340 $ INFO ) 00341 CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) 00342 INFOT = 2 00343 CALL DGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, 00344 $ INFO ) 00345 CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) 00346 INFOT = 3 00347 CALL DGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, 00348 $ INFO ) 00349 CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) 00350 INFOT = 4 00351 CALL DGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, 00352 $ INFO ) 00353 CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) 00354 INFOT = 6 00355 CALL DGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, 00356 $ INFO ) 00357 CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) 00358 END IF 00359 * 00360 * Print a summary line. 00361 * 00362 CALL ALAESM( PATH, OK, NOUT ) 00363 * 00364 RETURN 00365 * 00366 * End of DERRGE 00367 * 00368 END
1.7.3 
