 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE SERREC( 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 * SERREC tests the error exits for the routines for eigen- condition 00016 * estimation for REAL matrices: 00017 * STRSYL, STREXC, STRSNA and STRSEN. 00018 * 00019 * Arguments 00020 * ========= 00021 * 00022 * PATH (input) CHARACTER*3 00023 * The LAPACK path name for the routines to be tested. 00024 * 00025 * NUNIT (input) INTEGER 00026 * The unit number for output. 00027 * 00028 * ===================================================================== 00029 * 00030 * .. Parameters .. 00031 INTEGER NMAX 00032 REAL ONE, ZERO 00033 PARAMETER ( NMAX = 4, ONE = 1.0E0, ZERO = 0.0E0 ) 00034 * .. 00035 * .. Local Scalars .. 00036 INTEGER I, IFST, ILST, INFO, J, M, NT 00037 REAL SCALE 00038 * .. 00039 * .. Local Arrays .. 00040 LOGICAL SEL( NMAX ) 00041 INTEGER IWORK( NMAX ) 00042 REAL A( NMAX, NMAX ), B( NMAX, NMAX ), 00043 $ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ), 00044 $ WI( NMAX ), WORK( NMAX ), WR( NMAX ) 00045 * .. 00046 * .. External Subroutines .. 00047 EXTERNAL CHKXER, STREXC, STRSEN, STRSNA, STRSYL 00048 * .. 00049 * .. Scalars in Common .. 00050 LOGICAL LERR, OK 00051 CHARACTER*32 SRNAMT 00052 INTEGER INFOT, NOUT 00053 * .. 00054 * .. Common blocks .. 00055 COMMON / INFOC / INFOT, NOUT, OK, LERR 00056 COMMON / SRNAMC / SRNAMT 00057 * .. 00058 * .. Executable Statements .. 00059 * 00060 NOUT = NUNIT 00061 OK = .TRUE. 00062 NT = 0 00063 * 00064 * Initialize A, B and SEL 00065 * 00066 DO 20 J = 1, NMAX 00067 DO 10 I = 1, NMAX 00068 A( I, J ) = ZERO 00069 B( I, J ) = ZERO 00070 10 CONTINUE 00071 20 CONTINUE 00072 DO 30 I = 1, NMAX 00073 A( I, I ) = ONE 00074 SEL( I ) = .TRUE. 00075 30 CONTINUE 00076 * 00077 * Test STRSYL 00078 * 00079 SRNAMT = 'STRSYL' 00080 INFOT = 1 00081 CALL STRSYL( 'X', 'N', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO ) 00082 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00083 INFOT = 2 00084 CALL STRSYL( 'N', 'X', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO ) 00085 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00086 INFOT = 3 00087 CALL STRSYL( 'N', 'N', 0, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO ) 00088 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00089 INFOT = 4 00090 CALL STRSYL( 'N', 'N', 1, -1, 0, A, 1, B, 1, C, 1, SCALE, INFO ) 00091 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00092 INFOT = 5 00093 CALL STRSYL( 'N', 'N', 1, 0, -1, A, 1, B, 1, C, 1, SCALE, INFO ) 00094 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00095 INFOT = 7 00096 CALL STRSYL( 'N', 'N', 1, 2, 0, A, 1, B, 1, C, 2, SCALE, INFO ) 00097 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00098 INFOT = 9 00099 CALL STRSYL( 'N', 'N', 1, 0, 2, A, 1, B, 1, C, 1, SCALE, INFO ) 00100 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00101 INFOT = 11 00102 CALL STRSYL( 'N', 'N', 1, 2, 0, A, 2, B, 1, C, 1, SCALE, INFO ) 00103 CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK ) 00104 NT = NT + 8 00105 * 00106 * Test STREXC 00107 * 00108 SRNAMT = 'STREXC' 00109 IFST = 1 00110 ILST = 1 00111 INFOT = 1 00112 CALL STREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00113 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00114 INFOT = 7 00115 CALL STREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00116 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00117 INFOT = 4 00118 ILST = 2 00119 CALL STREXC( 'N', 2, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00120 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00121 INFOT = 6 00122 CALL STREXC( 'V', 2, A, 2, B, 1, IFST, ILST, WORK, INFO ) 00123 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00124 INFOT = 7 00125 IFST = 0 00126 ILST = 1 00127 CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00128 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00129 INFOT = 7 00130 IFST = 2 00131 CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00132 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00133 INFOT = 8 00134 IFST = 1 00135 ILST = 0 00136 CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00137 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00138 INFOT = 8 00139 ILST = 2 00140 CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) 00141 CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) 00142 NT = NT + 8 00143 * 00144 * Test STRSNA 00145 * 00146 SRNAMT = 'STRSNA' 00147 INFOT = 1 00148 CALL STRSNA( 'X', 'A', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M, 00149 $ WORK, 1, IWORK, INFO ) 00150 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00151 INFOT = 2 00152 CALL STRSNA( 'B', 'X', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M, 00153 $ WORK, 1, IWORK, INFO ) 00154 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00155 INFOT = 4 00156 CALL STRSNA( 'B', 'A', SEL, -1, A, 1, B, 1, C, 1, S, SEP, 1, M, 00157 $ WORK, 1, IWORK, INFO ) 00158 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00159 INFOT = 6 00160 CALL STRSNA( 'V', 'A', SEL, 2, A, 1, B, 1, C, 1, S, SEP, 2, M, 00161 $ WORK, 2, IWORK, INFO ) 00162 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00163 INFOT = 8 00164 CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 1, C, 2, S, SEP, 2, M, 00165 $ WORK, 2, IWORK, INFO ) 00166 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00167 INFOT = 10 00168 CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 1, S, SEP, 2, M, 00169 $ WORK, 2, IWORK, INFO ) 00170 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00171 INFOT = 13 00172 CALL STRSNA( 'B', 'A', SEL, 1, A, 1, B, 1, C, 1, S, SEP, 0, M, 00173 $ WORK, 1, IWORK, INFO ) 00174 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00175 INFOT = 13 00176 CALL STRSNA( 'B', 'S', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 1, M, 00177 $ WORK, 2, IWORK, INFO ) 00178 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00179 INFOT = 16 00180 CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 2, M, 00181 $ WORK, 1, IWORK, INFO ) 00182 CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK ) 00183 NT = NT + 9 00184 * 00185 * Test STRSEN 00186 * 00187 SEL( 1 ) = .FALSE. 00188 SRNAMT = 'STRSEN' 00189 INFOT = 1 00190 CALL STRSEN( 'X', 'N', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ), 00191 $ SEP( 1 ), WORK, 1, IWORK, 1, INFO ) 00192 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00193 INFOT = 2 00194 CALL STRSEN( 'N', 'X', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ), 00195 $ SEP( 1 ), WORK, 1, IWORK, 1, INFO ) 00196 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00197 INFOT = 4 00198 CALL STRSEN( 'N', 'N', SEL, -1, A, 1, B, 1, WR, WI, M, S( 1 ), 00199 $ SEP( 1 ), WORK, 1, IWORK, 1, INFO ) 00200 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00201 INFOT = 6 00202 CALL STRSEN( 'N', 'N', SEL, 2, A, 1, B, 1, WR, WI, M, S( 1 ), 00203 $ SEP( 1 ), WORK, 2, IWORK, 1, INFO ) 00204 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00205 INFOT = 8 00206 CALL STRSEN( 'N', 'V', SEL, 2, A, 2, B, 1, WR, WI, M, S( 1 ), 00207 $ SEP( 1 ), WORK, 1, IWORK, 1, INFO ) 00208 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00209 INFOT = 15 00210 CALL STRSEN( 'N', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ), 00211 $ SEP( 1 ), WORK, 0, IWORK, 1, INFO ) 00212 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00213 INFOT = 15 00214 CALL STRSEN( 'E', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ), 00215 $ SEP( 1 ), WORK, 1, IWORK, 1, INFO ) 00216 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00217 INFOT = 15 00218 CALL STRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ), 00219 $ SEP( 1 ), WORK, 3, IWORK, 2, INFO ) 00220 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00221 INFOT = 17 00222 CALL STRSEN( 'E', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ), 00223 $ SEP( 1 ), WORK, 1, IWORK, 0, INFO ) 00224 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00225 INFOT = 17 00226 CALL STRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ), 00227 $ SEP( 1 ), WORK, 4, IWORK, 1, INFO ) 00228 CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK ) 00229 NT = NT + 10 00230 * 00231 * Print a summary line. 00232 * 00233 IF( OK ) THEN 00234 WRITE( NOUT, FMT = 9999 )PATH, NT 00235 ELSE 00236 WRITE( NOUT, FMT = 9998 )PATH 00237 END IF 00238 * 00239 RETURN 00240 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (', 00241 $ I3, ' tests done)' ) 00242 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ex', 00243 $ 'its ***' ) 00244 * 00245 * End of SERREC 00246 * 00247 END
1.7.3 
