|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DERRSY( PATH, NUNIT ) 00002 * 00003 * -- LAPACK test routine (version 3.2.1) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * April 2009 00006 * 00007 * .. Scalar Arguments .. 00008 CHARACTER*3 PATH 00009 INTEGER NUNIT 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * DERRSY tests the error exits for the DOUBLE PRECISION routines 00016 * for symmetric indefinite matrices. 00017 * 00018 * Note that this file is used only when the XBLAS are available, 00019 * otherwise derrsy.f defines this subroutine. 00020 * 00021 * Arguments 00022 * ========= 00023 * 00024 * PATH (input) CHARACTER*3 00025 * The LAPACK path name for the routines to be tested. 00026 * 00027 * NUNIT (input) INTEGER 00028 * The unit number for output. 00029 * 00030 * ===================================================================== 00031 * 00032 * .. Parameters .. 00033 INTEGER NMAX 00034 PARAMETER ( NMAX = 4 ) 00035 * .. 00036 * .. Local Scalars .. 00037 CHARACTER EQ 00038 CHARACTER*2 C2 00039 INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS 00040 DOUBLE PRECISION ANRM, RCOND, BERR 00041 * .. 00042 * .. Local Arrays .. 00043 INTEGER IP( NMAX ), IW( NMAX ) 00044 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), 00045 $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ), 00046 $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), 00047 $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) 00048 * .. 00049 * .. External Functions .. 00050 LOGICAL LSAMEN 00051 EXTERNAL LSAMEN 00052 * .. 00053 * .. External Subroutines .. 00054 EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, 00055 $ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI, 00056 $ DSYTRI2, DSYTRS, DSYRFSX 00057 * .. 00058 * .. Scalars in Common .. 00059 LOGICAL LERR, OK 00060 CHARACTER*32 SRNAMT 00061 INTEGER INFOT, NOUT 00062 * .. 00063 * .. Common blocks .. 00064 COMMON / INFOC / INFOT, NOUT, OK, LERR 00065 COMMON / SRNAMC / SRNAMT 00066 * .. 00067 * .. Intrinsic Functions .. 00068 INTRINSIC DBLE 00069 * .. 00070 * .. Executable Statements .. 00071 * 00072 NOUT = NUNIT 00073 WRITE( NOUT, FMT = * ) 00074 C2 = PATH( 2: 3 ) 00075 * 00076 * Set the variables to innocuous values. 00077 * 00078 DO 20 J = 1, NMAX 00079 DO 10 I = 1, NMAX 00080 A( I, J ) = 1.D0 / DBLE( I+J ) 00081 AF( I, J ) = 1.D0 / DBLE( I+J ) 00082 10 CONTINUE 00083 B( J ) = 0.D0 00084 R1( J ) = 0.D0 00085 R2( J ) = 0.D0 00086 W( J ) = 0.D0 00087 X( J ) = 0.D0 00088 S( J ) = 0.D0 00089 IP( J ) = J 00090 IW( J ) = J 00091 20 CONTINUE 00092 ANRM = 1.0D0 00093 RCOND = 1.0D0 00094 OK = .TRUE. 00095 * 00096 IF( LSAMEN( 2, C2, 'SY' ) ) THEN 00097 * 00098 * Test error exits of the routines that use the Bunch-Kaufman 00099 * factorization of a symmetric indefinite matrix. 00100 * 00101 * DSYTRF 00102 * 00103 SRNAMT = 'DSYTRF' 00104 INFOT = 1 00105 CALL DSYTRF( '/', 0, A, 1, IP, W, 1, INFO ) 00106 CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) 00107 INFOT = 2 00108 CALL DSYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) 00109 CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) 00110 INFOT = 4 00111 CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) 00112 CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) 00113 * 00114 * DSYTF2 00115 * 00116 SRNAMT = 'DSYTF2' 00117 INFOT = 1 00118 CALL DSYTF2( '/', 0, A, 1, IP, INFO ) 00119 CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK ) 00120 INFOT = 2 00121 CALL DSYTF2( 'U', -1, A, 1, IP, INFO ) 00122 CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK ) 00123 INFOT = 4 00124 CALL DSYTF2( 'U', 2, A, 1, IP, INFO ) 00125 CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK ) 00126 * 00127 * DSYTRI 00128 * 00129 SRNAMT = 'DSYTRI' 00130 INFOT = 1 00131 CALL DSYTRI( '/', 0, A, 1, IP, W, INFO ) 00132 CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK ) 00133 INFOT = 2 00134 CALL DSYTRI( 'U', -1, A, 1, IP, W, INFO ) 00135 CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK ) 00136 INFOT = 4 00137 CALL DSYTRI( 'U', 2, A, 1, IP, W, INFO ) 00138 CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK ) 00139 * 00140 * DSYTRI2 00141 * 00142 SRNAMT = 'DSYTRI2' 00143 INFOT = 1 00144 CALL DSYTRI2( '/', 0, A, 1, IP, W, IW, INFO ) 00145 CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) 00146 INFOT = 2 00147 CALL DSYTRI2( 'U', -1, A, 1, IP, W, IW, INFO ) 00148 CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) 00149 INFOT = 4 00150 CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) 00151 CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) 00152 * 00153 * DSYTRS 00154 * 00155 SRNAMT = 'DSYTRS' 00156 INFOT = 1 00157 CALL DSYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) 00158 CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK ) 00159 INFOT = 2 00160 CALL DSYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) 00161 CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK ) 00162 INFOT = 3 00163 CALL DSYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) 00164 CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK ) 00165 INFOT = 5 00166 CALL DSYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) 00167 CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK ) 00168 INFOT = 8 00169 CALL DSYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) 00170 CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK ) 00171 * 00172 * DSYRFS 00173 * 00174 SRNAMT = 'DSYRFS' 00175 INFOT = 1 00176 CALL DSYRFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, 00177 $ IW, INFO ) 00178 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00179 INFOT = 2 00180 CALL DSYRFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00181 $ W, IW, INFO ) 00182 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00183 INFOT = 3 00184 CALL DSYRFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00185 $ W, IW, INFO ) 00186 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00187 INFOT = 5 00188 CALL DSYRFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, 00189 $ IW, INFO ) 00190 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00191 INFOT = 7 00192 CALL DSYRFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, 00193 $ IW, INFO ) 00194 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00195 INFOT = 10 00196 CALL DSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, 00197 $ IW, INFO ) 00198 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00199 INFOT = 12 00200 CALL DSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, 00201 $ IW, INFO ) 00202 CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK ) 00203 * 00204 * DSYRFSX 00205 * 00206 N_ERR_BNDS = 3 00207 NPARAMS = 0 00208 SRNAMT = 'DSYRFSX' 00209 INFOT = 1 00210 CALL DSYRFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00211 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00212 $ PARAMS, W, IW, INFO ) 00213 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00214 INFOT = 2 00215 CALL DSYRFSX( 'U', EQ, -1, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00216 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00217 $ PARAMS, W, IW, INFO ) 00218 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00219 EQ = 'N' 00220 INFOT = 3 00221 CALL DSYRFSX( 'U', EQ, -1, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00222 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00223 $ PARAMS, W, IW, INFO ) 00224 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00225 INFOT = 4 00226 CALL DSYRFSX( 'U', EQ, 0, -1, A, 1, AF, 1, IP, S, B, 1, X, 1, 00227 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00228 $ PARAMS, W, IW, INFO ) 00229 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00230 INFOT = 6 00231 CALL DSYRFSX( 'U', EQ, 2, 1, A, 1, AF, 2, IP, S, B, 2, X, 2, 00232 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00233 $ PARAMS, W, IW, INFO ) 00234 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00235 INFOT = 8 00236 CALL DSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 1, IP, S, B, 2, X, 2, 00237 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00238 $ PARAMS, W, IW, INFO ) 00239 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00240 INFOT = 11 00241 CALL DSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 1, X, 2, 00242 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00243 $ PARAMS, W, IW, INFO ) 00244 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00245 INFOT = 13 00246 CALL DSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 2, X, 1, 00247 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00248 $ PARAMS, W, IW, INFO ) 00249 CALL CHKXER( 'DSYRFSX', INFOT, NOUT, LERR, OK ) 00250 * 00251 * DSYCON 00252 * 00253 SRNAMT = 'DSYCON' 00254 INFOT = 1 00255 CALL DSYCON( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00256 CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) 00257 INFOT = 2 00258 CALL DSYCON( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00259 CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) 00260 INFOT = 4 00261 CALL DSYCON( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00262 CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) 00263 INFOT = 6 00264 CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO ) 00265 CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) 00266 * 00267 ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN 00268 * 00269 * Test error exits of the routines that use the Bunch-Kaufman 00270 * factorization of a symmetric indefinite packed matrix. 00271 * 00272 * DSPTRF 00273 * 00274 SRNAMT = 'DSPTRF' 00275 INFOT = 1 00276 CALL DSPTRF( '/', 0, A, IP, INFO ) 00277 CALL CHKXER( 'DSPTRF', INFOT, NOUT, LERR, OK ) 00278 INFOT = 2 00279 CALL DSPTRF( 'U', -1, A, IP, INFO ) 00280 CALL CHKXER( 'DSPTRF', INFOT, NOUT, LERR, OK ) 00281 * 00282 * DSPTRI 00283 * 00284 SRNAMT = 'DSPTRI' 00285 INFOT = 1 00286 CALL DSPTRI( '/', 0, A, IP, W, INFO ) 00287 CALL CHKXER( 'DSPTRI', INFOT, NOUT, LERR, OK ) 00288 INFOT = 2 00289 CALL DSPTRI( 'U', -1, A, IP, W, INFO ) 00290 CALL CHKXER( 'DSPTRI', INFOT, NOUT, LERR, OK ) 00291 * 00292 * DSPTRS 00293 * 00294 SRNAMT = 'DSPTRS' 00295 INFOT = 1 00296 CALL DSPTRS( '/', 0, 0, A, IP, B, 1, INFO ) 00297 CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK ) 00298 INFOT = 2 00299 CALL DSPTRS( 'U', -1, 0, A, IP, B, 1, INFO ) 00300 CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK ) 00301 INFOT = 3 00302 CALL DSPTRS( 'U', 0, -1, A, IP, B, 1, INFO ) 00303 CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK ) 00304 INFOT = 7 00305 CALL DSPTRS( 'U', 2, 1, A, IP, B, 1, INFO ) 00306 CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK ) 00307 * 00308 * DSPRFS 00309 * 00310 SRNAMT = 'DSPRFS' 00311 INFOT = 1 00312 CALL DSPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00313 $ INFO ) 00314 CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK ) 00315 INFOT = 2 00316 CALL DSPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00317 $ INFO ) 00318 CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK ) 00319 INFOT = 3 00320 CALL DSPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00321 $ INFO ) 00322 CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK ) 00323 INFOT = 8 00324 CALL DSPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, IW, 00325 $ INFO ) 00326 CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK ) 00327 INFOT = 10 00328 CALL DSPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, IW, 00329 $ INFO ) 00330 CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK ) 00331 * 00332 * DSPCON 00333 * 00334 SRNAMT = 'DSPCON' 00335 INFOT = 1 00336 CALL DSPCON( '/', 0, A, IP, ANRM, RCOND, W, IW, INFO ) 00337 CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK ) 00338 INFOT = 2 00339 CALL DSPCON( 'U', -1, A, IP, ANRM, RCOND, W, IW, INFO ) 00340 CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK ) 00341 INFOT = 5 00342 CALL DSPCON( 'U', 1, A, IP, -1.0D0, RCOND, W, IW, INFO ) 00343 CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK ) 00344 END IF 00345 * 00346 * Print a summary line. 00347 * 00348 CALL ALAESM( PATH, OK, NOUT ) 00349 * 00350 RETURN 00351 * 00352 * End of DERRSY 00353 * 00354 END
1.7.3 
