|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE CERRHE( PATH, NUNIT ) 00002 * 00003 * -- LAPACK test routine (version 3.2) -- 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 * CERRHE tests the error exits for the COMPLEX routines 00016 * for Hermitian indefinite matrices. 00017 * 00018 * Note that this file is used only when the XBLAS are available, 00019 * otherwise cerrhe.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 * 00033 * .. Parameters .. 00034 INTEGER NMAX 00035 PARAMETER ( NMAX = 4 ) 00036 * .. 00037 * .. Local Scalars .. 00038 CHARACTER EQ 00039 CHARACTER*2 C2 00040 INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS 00041 REAL ANRM, RCOND, BERR 00042 * .. 00043 * .. Local Arrays .. 00044 INTEGER IP( NMAX ) 00045 REAL R( NMAX ), R1( NMAX ), R2( NMAX ), 00046 $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), 00047 $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) 00048 COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), 00049 $ W( 2*NMAX ), X( NMAX ) 00050 * .. 00051 * .. External Functions .. 00052 LOGICAL LSAMEN 00053 EXTERNAL LSAMEN 00054 * .. 00055 * .. External Subroutines .. 00056 EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI, 00057 $ CHETRS, CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, 00058 $ CHPTRS, CHERFSX 00059 * .. 00060 * .. Scalars in Common .. 00061 LOGICAL LERR, OK 00062 CHARACTER*32 SRNAMT 00063 INTEGER INFOT, NOUT 00064 * .. 00065 * .. Common blocks .. 00066 COMMON / INFOC / INFOT, NOUT, OK, LERR 00067 COMMON / SRNAMC / SRNAMT 00068 * .. 00069 * .. Intrinsic Functions .. 00070 INTRINSIC CMPLX, REAL 00071 * .. 00072 * .. Executable Statements .. 00073 * 00074 NOUT = NUNIT 00075 WRITE( NOUT, FMT = * ) 00076 C2 = PATH( 2: 3 ) 00077 * 00078 * Set the variables to innocuous values. 00079 * 00080 DO 20 J = 1, NMAX 00081 DO 10 I = 1, NMAX 00082 A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 00083 AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 00084 10 CONTINUE 00085 B( J ) = 0. 00086 R1( J ) = 0. 00087 R2( J ) = 0. 00088 W( J ) = 0. 00089 X( J ) = 0. 00090 S( J ) = 0. 00091 IP( J ) = J 00092 20 CONTINUE 00093 ANRM = 1.0 00094 OK = .TRUE. 00095 * 00096 * Test error exits of the routines that use the diagonal pivoting 00097 * factorization of a Hermitian indefinite matrix. 00098 * 00099 IF( LSAMEN( 2, C2, 'HE' ) ) THEN 00100 * 00101 * CHETRF 00102 * 00103 SRNAMT = 'CHETRF' 00104 INFOT = 1 00105 CALL CHETRF( '/', 0, A, 1, IP, W, 1, INFO ) 00106 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00107 INFOT = 2 00108 CALL CHETRF( 'U', -1, A, 1, IP, W, 1, INFO ) 00109 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00110 INFOT = 4 00111 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) 00112 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00113 * 00114 * CHETF2 00115 * 00116 SRNAMT = 'CHETF2' 00117 INFOT = 1 00118 CALL CHETF2( '/', 0, A, 1, IP, INFO ) 00119 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00120 INFOT = 2 00121 CALL CHETF2( 'U', -1, A, 1, IP, INFO ) 00122 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00123 INFOT = 4 00124 CALL CHETF2( 'U', 2, A, 1, IP, INFO ) 00125 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00126 * 00127 * CHETRI 00128 * 00129 SRNAMT = 'CHETRI' 00130 INFOT = 1 00131 CALL CHETRI( '/', 0, A, 1, IP, W, INFO ) 00132 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00133 INFOT = 2 00134 CALL CHETRI( 'U', -1, A, 1, IP, W, INFO ) 00135 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00136 INFOT = 4 00137 CALL CHETRI( 'U', 2, A, 1, IP, W, INFO ) 00138 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00139 * 00140 * CHETRS 00141 * 00142 SRNAMT = 'CHETRS' 00143 INFOT = 1 00144 CALL CHETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) 00145 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00146 INFOT = 2 00147 CALL CHETRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) 00148 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00149 INFOT = 3 00150 CALL CHETRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) 00151 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00152 INFOT = 5 00153 CALL CHETRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) 00154 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00155 INFOT = 8 00156 CALL CHETRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) 00157 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00158 * 00159 * CHERFS 00160 * 00161 SRNAMT = 'CHERFS' 00162 INFOT = 1 00163 CALL CHERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, 00164 $ R, INFO ) 00165 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00166 INFOT = 2 00167 CALL CHERFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00168 $ W, R, INFO ) 00169 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00170 INFOT = 3 00171 CALL CHERFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00172 $ W, R, INFO ) 00173 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00174 INFOT = 5 00175 CALL CHERFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, 00176 $ R, INFO ) 00177 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00178 INFOT = 7 00179 CALL CHERFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, 00180 $ R, INFO ) 00181 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00182 INFOT = 10 00183 CALL CHERFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, 00184 $ R, INFO ) 00185 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00186 INFOT = 12 00187 CALL CHERFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, 00188 $ R, INFO ) 00189 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00190 * 00191 * CHECON 00192 * 00193 SRNAMT = 'CHECON' 00194 INFOT = 1 00195 CALL CHECON( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) 00196 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00197 INFOT = 2 00198 CALL CHECON( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) 00199 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00200 INFOT = 4 00201 CALL CHECON( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) 00202 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00203 INFOT = 6 00204 CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) 00205 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00206 * 00207 * Test error exits of the routines that use the diagonal pivoting 00208 * factorization of a Hermitian indefinite packed matrix. 00209 * 00210 ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN 00211 * 00212 * CHPTRF 00213 * 00214 SRNAMT = 'CHPTRF' 00215 INFOT = 1 00216 CALL CHPTRF( '/', 0, A, IP, INFO ) 00217 CALL CHKXER( 'CHPTRF', INFOT, NOUT, LERR, OK ) 00218 INFOT = 2 00219 CALL CHPTRF( 'U', -1, A, IP, INFO ) 00220 CALL CHKXER( 'CHPTRF', INFOT, NOUT, LERR, OK ) 00221 * 00222 * CHPTRI 00223 * 00224 SRNAMT = 'CHPTRI' 00225 INFOT = 1 00226 CALL CHPTRI( '/', 0, A, IP, W, INFO ) 00227 CALL CHKXER( 'CHPTRI', INFOT, NOUT, LERR, OK ) 00228 INFOT = 2 00229 CALL CHPTRI( 'U', -1, A, IP, W, INFO ) 00230 CALL CHKXER( 'CHPTRI', INFOT, NOUT, LERR, OK ) 00231 * 00232 * CHPTRS 00233 * 00234 SRNAMT = 'CHPTRS' 00235 INFOT = 1 00236 CALL CHPTRS( '/', 0, 0, A, IP, B, 1, INFO ) 00237 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00238 INFOT = 2 00239 CALL CHPTRS( 'U', -1, 0, A, IP, B, 1, INFO ) 00240 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00241 INFOT = 3 00242 CALL CHPTRS( 'U', 0, -1, A, IP, B, 1, INFO ) 00243 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00244 INFOT = 7 00245 CALL CHPTRS( 'U', 2, 1, A, IP, B, 1, INFO ) 00246 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00247 * 00248 * CHPRFS 00249 * 00250 SRNAMT = 'CHPRFS' 00251 INFOT = 1 00252 CALL CHPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00253 $ INFO ) 00254 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00255 INFOT = 2 00256 CALL CHPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00257 $ INFO ) 00258 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00259 INFOT = 3 00260 CALL CHPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00261 $ INFO ) 00262 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00263 INFOT = 8 00264 CALL CHPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, R, 00265 $ INFO ) 00266 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00267 INFOT = 10 00268 CALL CHPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, R, 00269 $ INFO ) 00270 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00271 * 00272 * CHERFSX 00273 * 00274 N_ERR_BNDS = 3 00275 NPARAMS = 0 00276 SRNAMT = 'CHERFSX' 00277 INFOT = 1 00278 CALL CHERFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00279 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00280 $ PARAMS, W, R, INFO ) 00281 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00282 INFOT = 2 00283 CALL CHERFSX( 'U', EQ, -1, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00284 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00285 $ PARAMS, W, R, INFO ) 00286 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00287 EQ = 'N' 00288 INFOT = 3 00289 CALL CHERFSX( 'U', EQ, -1, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, 00290 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00291 $ PARAMS, W, R, INFO ) 00292 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00293 INFOT = 4 00294 CALL CHERFSX( 'U', EQ, 0, -1, A, 1, AF, 1, IP, S, B, 1, X, 1, 00295 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00296 $ PARAMS, W, R, INFO ) 00297 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00298 INFOT = 6 00299 CALL CHERFSX( 'U', EQ, 2, 1, A, 1, AF, 2, IP, S, B, 2, X, 2, 00300 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00301 $ PARAMS, W, R, INFO ) 00302 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00303 INFOT = 8 00304 CALL CHERFSX( 'U', EQ, 2, 1, A, 2, AF, 1, IP, S, B, 2, X, 2, 00305 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00306 $ PARAMS, W, R, INFO ) 00307 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00308 INFOT = 11 00309 CALL CHERFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 1, X, 2, 00310 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00311 $ PARAMS, W, R, INFO ) 00312 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00313 INFOT = 13 00314 CALL CHERFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 2, X, 1, 00315 $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, 00316 $ PARAMS, W, R, INFO ) 00317 CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) 00318 * 00319 * CHPCON 00320 * 00321 SRNAMT = 'CHPCON' 00322 INFOT = 1 00323 CALL CHPCON( '/', 0, A, IP, ANRM, RCOND, W, INFO ) 00324 CALL CHKXER( 'CHPCON', INFOT, NOUT, LERR, OK ) 00325 INFOT = 2 00326 CALL CHPCON( 'U', -1, A, IP, ANRM, RCOND, W, INFO ) 00327 CALL CHKXER( 'CHPCON', INFOT, NOUT, LERR, OK ) 00328 INFOT = 5 00329 CALL CHPCON( 'U', 1, A, IP, -ANRM, RCOND, W, INFO ) 00330 CALL CHKXER( 'CHPCON', INFOT, NOUT, LERR, OK ) 00331 END IF 00332 * 00333 * Print a summary line. 00334 * 00335 CALL ALAESM( PATH, OK, NOUT ) 00336 * 00337 RETURN 00338 * 00339 * End of CERRHE 00340 * 00341 END
1.7.3 
