![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CERRHE 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE CERRHE( PATH, NUNIT ) 00012 * 00013 * .. Scalar Arguments .. 00014 * CHARACTER*3 PATH 00015 * INTEGER NUNIT 00016 * .. 00017 * 00018 * 00019 *> \par Purpose: 00020 * ============= 00021 *> 00022 *> \verbatim 00023 *> 00024 *> CERRHE tests the error exits for the COMPLEX routines 00025 *> for Hermitian indefinite matrices. 00026 *> \endverbatim 00027 * 00028 * Arguments: 00029 * ========== 00030 * 00031 *> \param[in] PATH 00032 *> \verbatim 00033 *> PATH is CHARACTER*3 00034 *> The LAPACK path name for the routines to be tested. 00035 *> \endverbatim 00036 *> 00037 *> \param[in] NUNIT 00038 *> \verbatim 00039 *> NUNIT is INTEGER 00040 *> The unit number for output. 00041 *> \endverbatim 00042 * 00043 * Authors: 00044 * ======== 00045 * 00046 *> \author Univ. of Tennessee 00047 *> \author Univ. of California Berkeley 00048 *> \author Univ. of Colorado Denver 00049 *> \author NAG Ltd. 00050 * 00051 *> \date November 2011 00052 * 00053 *> \ingroup complex_lin 00054 * 00055 * ===================================================================== 00056 SUBROUTINE CERRHE( PATH, NUNIT ) 00057 * 00058 * -- LAPACK test routine (version 3.4.0) -- 00059 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00060 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00061 * November 2011 00062 * 00063 * .. Scalar Arguments .. 00064 CHARACTER*3 PATH 00065 INTEGER NUNIT 00066 * .. 00067 * 00068 * ===================================================================== 00069 * 00070 * 00071 * .. Parameters .. 00072 INTEGER NMAX 00073 PARAMETER ( NMAX = 4 ) 00074 * .. 00075 * .. Local Scalars .. 00076 CHARACTER*2 C2 00077 INTEGER I, INFO, J 00078 REAL ANRM, RCOND 00079 * .. 00080 * .. Local Arrays .. 00081 INTEGER IP( NMAX ) 00082 REAL R( NMAX ), R1( NMAX ), R2( NMAX ) 00083 COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), 00084 $ W( 2*NMAX ), X( NMAX ) 00085 * .. 00086 * .. External Functions .. 00087 LOGICAL LSAMEN 00088 EXTERNAL LSAMEN 00089 * .. 00090 * .. External Subroutines .. 00091 EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI, 00092 $ CHETRI2, CHETRS, CHKXER, CHPCON, CHPRFS, 00093 $ CHPTRF, CHPTRI, CHPTRS 00094 * .. 00095 * .. Scalars in Common .. 00096 LOGICAL LERR, OK 00097 CHARACTER*32 SRNAMT 00098 INTEGER INFOT, NOUT 00099 * .. 00100 * .. Common blocks .. 00101 COMMON / INFOC / INFOT, NOUT, OK, LERR 00102 COMMON / SRNAMC / SRNAMT 00103 * .. 00104 * .. Intrinsic Functions .. 00105 INTRINSIC CMPLX, REAL 00106 * .. 00107 * .. Executable Statements .. 00108 * 00109 NOUT = NUNIT 00110 WRITE( NOUT, FMT = * ) 00111 C2 = PATH( 2: 3 ) 00112 * 00113 * Set the variables to innocuous values. 00114 * 00115 DO 20 J = 1, NMAX 00116 DO 10 I = 1, NMAX 00117 A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 00118 AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 00119 10 CONTINUE 00120 B( J ) = 0. 00121 R1( J ) = 0. 00122 R2( J ) = 0. 00123 W( J ) = 0. 00124 X( J ) = 0. 00125 IP( J ) = J 00126 20 CONTINUE 00127 ANRM = 1.0 00128 OK = .TRUE. 00129 * 00130 * Test error exits of the routines that use the diagonal pivoting 00131 * factorization of a Hermitian indefinite matrix. 00132 * 00133 IF( LSAMEN( 2, C2, 'HE' ) ) THEN 00134 * 00135 * CHETRF 00136 * 00137 SRNAMT = 'CHETRF' 00138 INFOT = 1 00139 CALL CHETRF( '/', 0, A, 1, IP, W, 1, INFO ) 00140 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00141 INFOT = 2 00142 CALL CHETRF( 'U', -1, A, 1, IP, W, 1, INFO ) 00143 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00144 INFOT = 4 00145 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) 00146 CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) 00147 * 00148 * CHETF2 00149 * 00150 SRNAMT = 'CHETF2' 00151 INFOT = 1 00152 CALL CHETF2( '/', 0, A, 1, IP, INFO ) 00153 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00154 INFOT = 2 00155 CALL CHETF2( 'U', -1, A, 1, IP, INFO ) 00156 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00157 INFOT = 4 00158 CALL CHETF2( 'U', 2, A, 1, IP, INFO ) 00159 CALL CHKXER( 'CHETF2', INFOT, NOUT, LERR, OK ) 00160 * 00161 * CHETRI 00162 * 00163 SRNAMT = 'CHETRI' 00164 INFOT = 1 00165 CALL CHETRI( '/', 0, A, 1, IP, W, INFO ) 00166 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00167 INFOT = 2 00168 CALL CHETRI( 'U', -1, A, 1, IP, W, INFO ) 00169 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00170 INFOT = 4 00171 CALL CHETRI( 'U', 2, A, 1, IP, W, INFO ) 00172 CALL CHKXER( 'CHETRI', INFOT, NOUT, LERR, OK ) 00173 * 00174 * CHETRI2 00175 * 00176 SRNAMT = 'CHETRI2' 00177 INFOT = 1 00178 CALL CHETRI2( '/', 0, A, 1, IP, W, 1, INFO ) 00179 CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) 00180 INFOT = 2 00181 CALL CHETRI2( 'U', -1, A, 1, IP, W, 1, INFO ) 00182 CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) 00183 INFOT = 4 00184 CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) 00185 CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) 00186 * 00187 * CHETRS 00188 * 00189 SRNAMT = 'CHETRS' 00190 INFOT = 1 00191 CALL CHETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) 00192 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00193 INFOT = 2 00194 CALL CHETRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) 00195 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00196 INFOT = 3 00197 CALL CHETRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) 00198 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00199 INFOT = 5 00200 CALL CHETRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) 00201 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00202 INFOT = 8 00203 CALL CHETRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) 00204 CALL CHKXER( 'CHETRS', INFOT, NOUT, LERR, OK ) 00205 * 00206 * CHERFS 00207 * 00208 SRNAMT = 'CHERFS' 00209 INFOT = 1 00210 CALL CHERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, 00211 $ R, INFO ) 00212 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00213 INFOT = 2 00214 CALL CHERFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00215 $ W, R, INFO ) 00216 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00217 INFOT = 3 00218 CALL CHERFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00219 $ W, R, INFO ) 00220 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00221 INFOT = 5 00222 CALL CHERFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, 00223 $ R, INFO ) 00224 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00225 INFOT = 7 00226 CALL CHERFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, 00227 $ R, INFO ) 00228 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00229 INFOT = 10 00230 CALL CHERFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, 00231 $ R, INFO ) 00232 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00233 INFOT = 12 00234 CALL CHERFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, 00235 $ R, INFO ) 00236 CALL CHKXER( 'CHERFS', INFOT, NOUT, LERR, OK ) 00237 * 00238 * CHECON 00239 * 00240 SRNAMT = 'CHECON' 00241 INFOT = 1 00242 CALL CHECON( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) 00243 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00244 INFOT = 2 00245 CALL CHECON( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) 00246 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00247 INFOT = 4 00248 CALL CHECON( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) 00249 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00250 INFOT = 6 00251 CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) 00252 CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) 00253 * 00254 * Test error exits of the routines that use the diagonal pivoting 00255 * factorization of a Hermitian indefinite packed matrix. 00256 * 00257 ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN 00258 * 00259 * CHPTRF 00260 * 00261 SRNAMT = 'CHPTRF' 00262 INFOT = 1 00263 CALL CHPTRF( '/', 0, A, IP, INFO ) 00264 CALL CHKXER( 'CHPTRF', INFOT, NOUT, LERR, OK ) 00265 INFOT = 2 00266 CALL CHPTRF( 'U', -1, A, IP, INFO ) 00267 CALL CHKXER( 'CHPTRF', INFOT, NOUT, LERR, OK ) 00268 * 00269 * CHPTRI 00270 * 00271 SRNAMT = 'CHPTRI' 00272 INFOT = 1 00273 CALL CHPTRI( '/', 0, A, IP, W, INFO ) 00274 CALL CHKXER( 'CHPTRI', INFOT, NOUT, LERR, OK ) 00275 INFOT = 2 00276 CALL CHPTRI( 'U', -1, A, IP, W, INFO ) 00277 CALL CHKXER( 'CHPTRI', INFOT, NOUT, LERR, OK ) 00278 * 00279 * CHPTRS 00280 * 00281 SRNAMT = 'CHPTRS' 00282 INFOT = 1 00283 CALL CHPTRS( '/', 0, 0, A, IP, B, 1, INFO ) 00284 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00285 INFOT = 2 00286 CALL CHPTRS( 'U', -1, 0, A, IP, B, 1, INFO ) 00287 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00288 INFOT = 3 00289 CALL CHPTRS( 'U', 0, -1, A, IP, B, 1, INFO ) 00290 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00291 INFOT = 7 00292 CALL CHPTRS( 'U', 2, 1, A, IP, B, 1, INFO ) 00293 CALL CHKXER( 'CHPTRS', INFOT, NOUT, LERR, OK ) 00294 * 00295 * CHPRFS 00296 * 00297 SRNAMT = 'CHPRFS' 00298 INFOT = 1 00299 CALL CHPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00300 $ INFO ) 00301 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00302 INFOT = 2 00303 CALL CHPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00304 $ INFO ) 00305 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00306 INFOT = 3 00307 CALL CHPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, R, 00308 $ INFO ) 00309 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00310 INFOT = 8 00311 CALL CHPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, R, 00312 $ INFO ) 00313 CALL CHKXER( 'CHPRFS', INFOT, NOUT, LERR, OK ) 00314 INFOT = 10 00315 CALL CHPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, R, 00316 $ INFO ) 00317 CALL CHKXER( 'CHPRFS', 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