![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SERRSY 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 SERRSY( 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 *> SERRSY tests the error exits for the REAL routines 00025 *> for symmetric 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 April 2012 00052 * 00053 *> \ingroup single_lin 00054 * 00055 * ===================================================================== 00056 SUBROUTINE SERRSY( PATH, NUNIT ) 00057 * 00058 * -- LAPACK test routine (version 3.4.1) -- 00059 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00060 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00061 * April 2012 00062 * 00063 * .. Scalar Arguments .. 00064 CHARACTER*3 PATH 00065 INTEGER NUNIT 00066 * .. 00067 * 00068 * ===================================================================== 00069 * 00070 * .. Parameters .. 00071 INTEGER NMAX 00072 PARAMETER ( NMAX = 4 ) 00073 * .. 00074 * .. Local Scalars .. 00075 CHARACTER*2 C2 00076 INTEGER I, INFO, J 00077 REAL ANRM, RCOND 00078 * .. 00079 * .. Local Arrays .. 00080 INTEGER IP( NMAX ), IW( NMAX ) 00081 REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), 00082 $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ) 00083 * .. 00084 * .. External Functions .. 00085 LOGICAL LSAMEN 00086 EXTERNAL LSAMEN 00087 * .. 00088 * .. External Subroutines .. 00089 EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, 00090 $ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI, 00091 $ SSYTRI2, SSYTRS 00092 * .. 00093 * .. Scalars in Common .. 00094 LOGICAL LERR, OK 00095 CHARACTER*32 SRNAMT 00096 INTEGER INFOT, NOUT 00097 * .. 00098 * .. Common blocks .. 00099 COMMON / INFOC / INFOT, NOUT, OK, LERR 00100 COMMON / SRNAMC / SRNAMT 00101 * .. 00102 * .. Intrinsic Functions .. 00103 INTRINSIC REAL 00104 * .. 00105 * .. Executable Statements .. 00106 * 00107 NOUT = NUNIT 00108 WRITE( NOUT, FMT = * ) 00109 C2 = PATH( 2: 3 ) 00110 * 00111 * Set the variables to innocuous values. 00112 * 00113 DO 20 J = 1, NMAX 00114 DO 10 I = 1, NMAX 00115 A( I, J ) = 1. / REAL( I+J ) 00116 AF( I, J ) = 1. / REAL( I+J ) 00117 10 CONTINUE 00118 B( J ) = 0. 00119 R1( J ) = 0. 00120 R2( J ) = 0. 00121 W( J ) = 0. 00122 X( J ) = 0. 00123 IP( J ) = J 00124 IW( J ) = J 00125 20 CONTINUE 00126 ANRM = 1.0 00127 RCOND = 1.0 00128 OK = .TRUE. 00129 * 00130 IF( LSAMEN( 2, C2, 'SY' ) ) THEN 00131 * 00132 * Test error exits of the routines that use factorization 00133 * of a symmetric indefinite matrix with patrial 00134 * (Bunch-Kaufman) pivoting. 00135 * 00136 * SSYTRF 00137 * 00138 SRNAMT = 'SSYTRF' 00139 INFOT = 1 00140 CALL SSYTRF( '/', 0, A, 1, IP, W, 1, INFO ) 00141 CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) 00142 INFOT = 2 00143 CALL SSYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) 00144 CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) 00145 INFOT = 4 00146 CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) 00147 CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) 00148 * 00149 * SSYTF2 00150 * 00151 SRNAMT = 'SSYTF2' 00152 INFOT = 1 00153 CALL SSYTF2( '/', 0, A, 1, IP, INFO ) 00154 CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK ) 00155 INFOT = 2 00156 CALL SSYTF2( 'U', -1, A, 1, IP, INFO ) 00157 CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK ) 00158 INFOT = 4 00159 CALL SSYTF2( 'U', 2, A, 1, IP, INFO ) 00160 CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK ) 00161 * 00162 * SSYTRI 00163 * 00164 SRNAMT = 'SSYTRI' 00165 INFOT = 1 00166 CALL SSYTRI( '/', 0, A, 1, IP, W, INFO ) 00167 CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK ) 00168 INFOT = 2 00169 CALL SSYTRI( 'U', -1, A, 1, IP, W, INFO ) 00170 CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK ) 00171 INFOT = 4 00172 CALL SSYTRI( 'U', 2, A, 1, IP, W, INFO ) 00173 CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK ) 00174 * 00175 * SSYTRI2 00176 * 00177 SRNAMT = 'SSYTRI2' 00178 INFOT = 1 00179 CALL SSYTRI2( '/', 0, A, 1, IP, W, IW(1), INFO ) 00180 CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) 00181 INFOT = 2 00182 CALL SSYTRI2( 'U', -1, A, 1, IP, W, IW(1), INFO ) 00183 CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) 00184 INFOT = 4 00185 CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) 00186 CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) 00187 * 00188 * SSYTRS 00189 * 00190 SRNAMT = 'SSYTRS' 00191 INFOT = 1 00192 CALL SSYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) 00193 CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK ) 00194 INFOT = 2 00195 CALL SSYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) 00196 CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK ) 00197 INFOT = 3 00198 CALL SSYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) 00199 CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK ) 00200 INFOT = 5 00201 CALL SSYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) 00202 CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK ) 00203 INFOT = 8 00204 CALL SSYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) 00205 CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK ) 00206 * 00207 * SSYRFS 00208 * 00209 SRNAMT = 'SSYRFS' 00210 INFOT = 1 00211 CALL SSYRFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, 00212 $ IW, INFO ) 00213 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00214 INFOT = 2 00215 CALL SSYRFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00216 $ W, IW, INFO ) 00217 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00218 INFOT = 3 00219 CALL SSYRFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, 00220 $ W, IW, INFO ) 00221 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00222 INFOT = 5 00223 CALL SSYRFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, 00224 $ IW, INFO ) 00225 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00226 INFOT = 7 00227 CALL SSYRFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, 00228 $ IW, INFO ) 00229 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00230 INFOT = 10 00231 CALL SSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, 00232 $ IW, INFO ) 00233 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00234 INFOT = 12 00235 CALL SSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, 00236 $ IW, INFO ) 00237 CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK ) 00238 * 00239 * SSYCON 00240 * 00241 SRNAMT = 'SSYCON' 00242 INFOT = 1 00243 CALL SSYCON( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00244 CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) 00245 INFOT = 2 00246 CALL SSYCON( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00247 CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) 00248 INFOT = 4 00249 CALL SSYCON( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) 00250 CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) 00251 INFOT = 6 00252 CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) 00253 CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) 00254 * 00255 ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN 00256 * 00257 * Test error exits of the routines that use factorization 00258 * of a symmetric indefinite packed matrix with patrial 00259 * (Bunch-Kaufman) pivoting. 00260 * 00261 * SSPTRF 00262 * 00263 SRNAMT = 'SSPTRF' 00264 INFOT = 1 00265 CALL SSPTRF( '/', 0, A, IP, INFO ) 00266 CALL CHKXER( 'SSPTRF', INFOT, NOUT, LERR, OK ) 00267 INFOT = 2 00268 CALL SSPTRF( 'U', -1, A, IP, INFO ) 00269 CALL CHKXER( 'SSPTRF', INFOT, NOUT, LERR, OK ) 00270 * 00271 * SSPTRI 00272 * 00273 SRNAMT = 'SSPTRI' 00274 INFOT = 1 00275 CALL SSPTRI( '/', 0, A, IP, W, INFO ) 00276 CALL CHKXER( 'SSPTRI', INFOT, NOUT, LERR, OK ) 00277 INFOT = 2 00278 CALL SSPTRI( 'U', -1, A, IP, W, INFO ) 00279 CALL CHKXER( 'SSPTRI', INFOT, NOUT, LERR, OK ) 00280 * 00281 * SSPTRS 00282 * 00283 SRNAMT = 'SSPTRS' 00284 INFOT = 1 00285 CALL SSPTRS( '/', 0, 0, A, IP, B, 1, INFO ) 00286 CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK ) 00287 INFOT = 2 00288 CALL SSPTRS( 'U', -1, 0, A, IP, B, 1, INFO ) 00289 CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK ) 00290 INFOT = 3 00291 CALL SSPTRS( 'U', 0, -1, A, IP, B, 1, INFO ) 00292 CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK ) 00293 INFOT = 7 00294 CALL SSPTRS( 'U', 2, 1, A, IP, B, 1, INFO ) 00295 CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK ) 00296 * 00297 * SSPRFS 00298 * 00299 SRNAMT = 'SSPRFS' 00300 INFOT = 1 00301 CALL SSPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00302 $ INFO ) 00303 CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK ) 00304 INFOT = 2 00305 CALL SSPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00306 $ INFO ) 00307 CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK ) 00308 INFOT = 3 00309 CALL SSPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, IW, 00310 $ INFO ) 00311 CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK ) 00312 INFOT = 8 00313 CALL SSPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, IW, 00314 $ INFO ) 00315 CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK ) 00316 INFOT = 10 00317 CALL SSPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, IW, 00318 $ INFO ) 00319 CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK ) 00320 * 00321 * SSPCON 00322 * 00323 SRNAMT = 'SSPCON' 00324 INFOT = 1 00325 CALL SSPCON( '/', 0, A, IP, ANRM, RCOND, W, IW, INFO ) 00326 CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK ) 00327 INFOT = 2 00328 CALL SSPCON( 'U', -1, A, IP, ANRM, RCOND, W, IW, INFO ) 00329 CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK ) 00330 INFOT = 5 00331 CALL SSPCON( 'U', 1, A, IP, -1.0, RCOND, W, IW, INFO ) 00332 CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK ) 00333 END IF 00334 * 00335 * Print a summary line. 00336 * 00337 CALL ALAESM( PATH, OK, NOUT ) 00338 * 00339 RETURN 00340 * 00341 * End of SERRSY 00342 * 00343 END