![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SBLAT2 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * PROGRAM SBLAT2 00012 * 00013 * 00014 *> \par Purpose: 00015 * ============= 00016 *> 00017 *> \verbatim 00018 *> 00019 *> Test program for the REAL Level 2 Blas. 00020 *> 00021 *> The program must be driven by a short data file. The first 18 records 00022 *> of the file are read using list-directed input, the last 16 records 00023 *> are read using the format ( A6, L2 ). An annotated example of a data 00024 *> file can be obtained by deleting the first 3 characters from the 00025 *> following 34 lines: 00026 *> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE 00027 *> 6 UNIT NUMBER OF SUMMARY FILE 00028 *> 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE 00029 *> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) 00030 *> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. 00031 *> F LOGICAL FLAG, T TO STOP ON FAILURES. 00032 *> T LOGICAL FLAG, T TO TEST ERROR EXITS. 00033 *> 16.0 THRESHOLD VALUE OF TEST RATIO 00034 *> 6 NUMBER OF VALUES OF N 00035 *> 0 1 2 3 5 9 VALUES OF N 00036 *> 4 NUMBER OF VALUES OF K 00037 *> 0 1 2 4 VALUES OF K 00038 *> 4 NUMBER OF VALUES OF INCX AND INCY 00039 *> 1 2 -1 -2 VALUES OF INCX AND INCY 00040 *> 3 NUMBER OF VALUES OF ALPHA 00041 *> 0.0 1.0 0.7 VALUES OF ALPHA 00042 *> 3 NUMBER OF VALUES OF BETA 00043 *> 0.0 1.0 0.9 VALUES OF BETA 00044 *> SGEMV T PUT F FOR NO TEST. SAME COLUMNS. 00045 *> SGBMV T PUT F FOR NO TEST. SAME COLUMNS. 00046 *> SSYMV T PUT F FOR NO TEST. SAME COLUMNS. 00047 *> SSBMV T PUT F FOR NO TEST. SAME COLUMNS. 00048 *> SSPMV T PUT F FOR NO TEST. SAME COLUMNS. 00049 *> STRMV T PUT F FOR NO TEST. SAME COLUMNS. 00050 *> STBMV T PUT F FOR NO TEST. SAME COLUMNS. 00051 *> STPMV T PUT F FOR NO TEST. SAME COLUMNS. 00052 *> STRSV T PUT F FOR NO TEST. SAME COLUMNS. 00053 *> STBSV T PUT F FOR NO TEST. SAME COLUMNS. 00054 *> STPSV T PUT F FOR NO TEST. SAME COLUMNS. 00055 *> SGER T PUT F FOR NO TEST. SAME COLUMNS. 00056 *> SSYR T PUT F FOR NO TEST. SAME COLUMNS. 00057 *> SSPR T PUT F FOR NO TEST. SAME COLUMNS. 00058 *> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. 00059 *> SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. 00060 *> 00061 *> Further Details 00062 *> =============== 00063 *> 00064 *> See: 00065 *> 00066 *> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. 00067 *> An extended set of Fortran Basic Linear Algebra Subprograms. 00068 *> 00069 *> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics 00070 *> and Computer Science Division, Argonne National Laboratory, 00071 *> 9700 South Cass Avenue, Argonne, Illinois 60439, US. 00072 *> 00073 *> Or 00074 *> 00075 *> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms 00076 *> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford 00077 *> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st 00078 *> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. 00079 *> 00080 *> 00081 *> -- Written on 10-August-1987. 00082 *> Richard Hanson, Sandia National Labs. 00083 *> Jeremy Du Croz, NAG Central Office. 00084 *> 00085 *> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers 00086 *> can be run multiple times without deleting generated 00087 *> output files (susan) 00088 *> \endverbatim 00089 * 00090 * Authors: 00091 * ======== 00092 * 00093 *> \author Univ. of Tennessee 00094 *> \author Univ. of California Berkeley 00095 *> \author Univ. of Colorado Denver 00096 *> \author NAG Ltd. 00097 * 00098 *> \date April 2012 00099 * 00100 *> \ingroup single_blas_testing 00101 * 00102 * ===================================================================== 00103 PROGRAM SBLAT2 00104 * 00105 * -- Reference BLAS test routine (version 3.4.1) -- 00106 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00107 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00108 * April 2012 00109 * 00110 * ===================================================================== 00111 * 00112 * .. Parameters .. 00113 INTEGER NIN 00114 PARAMETER ( NIN = 5 ) 00115 INTEGER NSUBS 00116 PARAMETER ( NSUBS = 16 ) 00117 REAL ZERO, ONE 00118 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 00119 INTEGER NMAX, INCMAX 00120 PARAMETER ( NMAX = 65, INCMAX = 2 ) 00121 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX 00122 PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, 00123 $ NALMAX = 7, NBEMAX = 7 ) 00124 * .. Local Scalars .. 00125 REAL EPS, ERR, THRESH 00126 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, 00127 $ NOUT, NTRA 00128 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, 00129 $ TSTERR 00130 CHARACTER*1 TRANS 00131 CHARACTER*6 SNAMET 00132 CHARACTER*32 SNAPS, SUMMRY 00133 * .. Local Arrays .. 00134 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), 00135 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), 00136 $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 00137 $ XX( NMAX*INCMAX ), Y( NMAX ), 00138 $ YS( NMAX*INCMAX ), YT( NMAX ), 00139 $ YY( NMAX*INCMAX ), Z( 2*NMAX ) 00140 INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) 00141 LOGICAL LTEST( NSUBS ) 00142 CHARACTER*6 SNAMES( NSUBS ) 00143 * .. External Functions .. 00144 REAL SDIFF 00145 LOGICAL LSE 00146 EXTERNAL SDIFF, LSE 00147 * .. External Subroutines .. 00148 EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6, 00149 $ SCHKE, SMVCH 00150 * .. Intrinsic Functions .. 00151 INTRINSIC ABS, MAX, MIN 00152 * .. Scalars in Common .. 00153 INTEGER INFOT, NOUTC 00154 LOGICAL LERR, OK 00155 CHARACTER*6 SRNAMT 00156 * .. Common blocks .. 00157 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00158 COMMON /SRNAMC/SRNAMT 00159 * .. Data statements .. 00160 DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', 00161 $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', 00162 $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', 00163 $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ 00164 * .. Executable Statements .. 00165 * 00166 * Read name and unit number for summary output file and open file. 00167 * 00168 READ( NIN, FMT = * )SUMMRY 00169 READ( NIN, FMT = * )NOUT 00170 OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) 00171 NOUTC = NOUT 00172 * 00173 * Read name and unit number for snapshot output file and open file. 00174 * 00175 READ( NIN, FMT = * )SNAPS 00176 READ( NIN, FMT = * )NTRA 00177 TRACE = NTRA.GE.0 00178 IF( TRACE )THEN 00179 OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) 00180 END IF 00181 * Read the flag that directs rewinding of the snapshot file. 00182 READ( NIN, FMT = * )REWI 00183 REWI = REWI.AND.TRACE 00184 * Read the flag that directs stopping on any failure. 00185 READ( NIN, FMT = * )SFATAL 00186 * Read the flag that indicates whether error exits are to be tested. 00187 READ( NIN, FMT = * )TSTERR 00188 * Read the threshold value of the test ratio 00189 READ( NIN, FMT = * )THRESH 00190 * 00191 * Read and check the parameter values for the tests. 00192 * 00193 * Values of N 00194 READ( NIN, FMT = * )NIDIM 00195 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN 00196 WRITE( NOUT, FMT = 9997 )'N', NIDMAX 00197 GO TO 230 00198 END IF 00199 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) 00200 DO 10 I = 1, NIDIM 00201 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN 00202 WRITE( NOUT, FMT = 9996 )NMAX 00203 GO TO 230 00204 END IF 00205 10 CONTINUE 00206 * Values of K 00207 READ( NIN, FMT = * )NKB 00208 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN 00209 WRITE( NOUT, FMT = 9997 )'K', NKBMAX 00210 GO TO 230 00211 END IF 00212 READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) 00213 DO 20 I = 1, NKB 00214 IF( KB( I ).LT.0 )THEN 00215 WRITE( NOUT, FMT = 9995 ) 00216 GO TO 230 00217 END IF 00218 20 CONTINUE 00219 * Values of INCX and INCY 00220 READ( NIN, FMT = * )NINC 00221 IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN 00222 WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX 00223 GO TO 230 00224 END IF 00225 READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) 00226 DO 30 I = 1, NINC 00227 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN 00228 WRITE( NOUT, FMT = 9994 )INCMAX 00229 GO TO 230 00230 END IF 00231 30 CONTINUE 00232 * Values of ALPHA 00233 READ( NIN, FMT = * )NALF 00234 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN 00235 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX 00236 GO TO 230 00237 END IF 00238 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) 00239 * Values of BETA 00240 READ( NIN, FMT = * )NBET 00241 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN 00242 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX 00243 GO TO 230 00244 END IF 00245 READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) 00246 * 00247 * Report values of parameters. 00248 * 00249 WRITE( NOUT, FMT = 9993 ) 00250 WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) 00251 WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) 00252 WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) 00253 WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) 00254 WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) 00255 IF( .NOT.TSTERR )THEN 00256 WRITE( NOUT, FMT = * ) 00257 WRITE( NOUT, FMT = 9980 ) 00258 END IF 00259 WRITE( NOUT, FMT = * ) 00260 WRITE( NOUT, FMT = 9999 )THRESH 00261 WRITE( NOUT, FMT = * ) 00262 * 00263 * Read names of subroutines and flags which indicate 00264 * whether they are to be tested. 00265 * 00266 DO 40 I = 1, NSUBS 00267 LTEST( I ) = .FALSE. 00268 40 CONTINUE 00269 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT 00270 DO 60 I = 1, NSUBS 00271 IF( SNAMET.EQ.SNAMES( I ) ) 00272 $ GO TO 70 00273 60 CONTINUE 00274 WRITE( NOUT, FMT = 9986 )SNAMET 00275 STOP 00276 70 LTEST( I ) = LTESTT 00277 GO TO 50 00278 * 00279 80 CONTINUE 00280 CLOSE ( NIN ) 00281 * 00282 * Compute EPS (the machine precision). 00283 * 00284 EPS = EPSILON(ZERO) 00285 WRITE( NOUT, FMT = 9998 )EPS 00286 * 00287 * Check the reliability of SMVCH using exact data. 00288 * 00289 N = MIN( 32, NMAX ) 00290 DO 120 J = 1, N 00291 DO 110 I = 1, N 00292 A( I, J ) = MAX( I - J + 1, 0 ) 00293 110 CONTINUE 00294 X( J ) = J 00295 Y( J ) = ZERO 00296 120 CONTINUE 00297 DO 130 J = 1, N 00298 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 00299 130 CONTINUE 00300 * YY holds the exact result. On exit from SMVCH YT holds 00301 * the result computed by SMVCH. 00302 TRANS = 'N' 00303 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, 00304 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 00305 SAME = LSE( YY, YT, N ) 00306 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 00307 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 00308 STOP 00309 END IF 00310 TRANS = 'T' 00311 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, 00312 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 00313 SAME = LSE( YY, YT, N ) 00314 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 00315 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 00316 STOP 00317 END IF 00318 * 00319 * Test each subroutine in turn. 00320 * 00321 DO 210 ISNUM = 1, NSUBS 00322 WRITE( NOUT, FMT = * ) 00323 IF( .NOT.LTEST( ISNUM ) )THEN 00324 * Subprogram is not to be tested. 00325 WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) 00326 ELSE 00327 SRNAMT = SNAMES( ISNUM ) 00328 * Test error exits. 00329 IF( TSTERR )THEN 00330 CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) 00331 WRITE( NOUT, FMT = * ) 00332 END IF 00333 * Test computations. 00334 INFOT = 0 00335 OK = .TRUE. 00336 FATAL = .FALSE. 00337 GO TO ( 140, 140, 150, 150, 150, 160, 160, 00338 $ 160, 160, 160, 160, 170, 180, 180, 00339 $ 190, 190 )ISNUM 00340 * Test SGEMV, 01, and SGBMV, 02. 00341 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00342 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 00343 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 00344 $ X, XX, XS, Y, YY, YS, YT, G ) 00345 GO TO 200 00346 * Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. 00347 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00348 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 00349 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 00350 $ X, XX, XS, Y, YY, YS, YT, G ) 00351 GO TO 200 00352 * Test STRMV, 06, STBMV, 07, STPMV, 08, 00353 * STRSV, 09, STBSV, 10, and STPSV, 11. 00354 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00355 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, 00356 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) 00357 GO TO 200 00358 * Test SGER, 12. 00359 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00360 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00361 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00362 $ YT, G, Z ) 00363 GO TO 200 00364 * Test SSYR, 13, and SSPR, 14. 00365 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00366 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00367 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00368 $ YT, G, Z ) 00369 GO TO 200 00370 * Test SSYR2, 15, and SSPR2, 16. 00371 190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00372 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00373 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00374 $ YT, G, Z ) 00375 * 00376 200 IF( FATAL.AND.SFATAL ) 00377 $ GO TO 220 00378 END IF 00379 210 CONTINUE 00380 WRITE( NOUT, FMT = 9982 ) 00381 GO TO 240 00382 * 00383 220 CONTINUE 00384 WRITE( NOUT, FMT = 9981 ) 00385 GO TO 240 00386 * 00387 230 CONTINUE 00388 WRITE( NOUT, FMT = 9987 ) 00389 * 00390 240 CONTINUE 00391 IF( TRACE ) 00392 $ CLOSE ( NTRA ) 00393 CLOSE ( NOUT ) 00394 STOP 00395 * 00396 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', 00397 $ 'S THAN', F8.2 ) 00398 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 00399 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', 00400 $ 'THAN ', I2 ) 00401 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 00402 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) 00403 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', 00404 $ I2 ) 00405 9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F', 00406 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 00407 9992 FORMAT( ' FOR N ', 9I6 ) 00408 9991 FORMAT( ' FOR K ', 7I6 ) 00409 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) 00410 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) 00411 9988 FORMAT( ' FOR BETA ', 7F6.1 ) 00412 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', 00413 $ /' ******* TESTS ABANDONED *******' ) 00414 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', 00415 $ 'ESTS ABANDONED *******' ) 00416 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', 00417 $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1, 00418 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / 00419 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' 00420 $ , /' ******* TESTS ABANDONED *******' ) 00421 9984 FORMAT( A6, L2 ) 00422 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 00423 9982 FORMAT( /' END OF TESTS' ) 00424 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 00425 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 00426 * 00427 * End of SBLAT2. 00428 * 00429 END 00430 SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 00431 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 00432 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 00433 $ XS, Y, YY, YS, YT, G ) 00434 * 00435 * Tests SGEMV and SGBMV. 00436 * 00437 * Auxiliary routine for test program for Level 2 Blas. 00438 * 00439 * -- Written on 10-August-1987. 00440 * Richard Hanson, Sandia National Labs. 00441 * Jeremy Du Croz, NAG Central Office. 00442 * 00443 * .. Parameters .. 00444 REAL ZERO, HALF 00445 PARAMETER ( ZERO = 0.0, HALF = 0.5 ) 00446 * .. Scalar Arguments .. 00447 REAL EPS, THRESH 00448 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 00449 $ NOUT, NTRA 00450 LOGICAL FATAL, REWI, TRACE 00451 CHARACTER*6 SNAME 00452 * .. Array Arguments .. 00453 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 00454 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), 00455 $ X( NMAX ), XS( NMAX*INCMAX ), 00456 $ XX( NMAX*INCMAX ), Y( NMAX ), 00457 $ YS( NMAX*INCMAX ), YT( NMAX ), 00458 $ YY( NMAX*INCMAX ) 00459 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 00460 * .. Local Scalars .. 00461 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL 00462 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, 00463 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, 00464 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, 00465 $ NL, NS 00466 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN 00467 CHARACTER*1 TRANS, TRANSS 00468 CHARACTER*3 ICH 00469 * .. Local Arrays .. 00470 LOGICAL ISAME( 13 ) 00471 * .. External Functions .. 00472 LOGICAL LSE, LSERES 00473 EXTERNAL LSE, LSERES 00474 * .. External Subroutines .. 00475 EXTERNAL SGBMV, SGEMV, SMAKE, SMVCH 00476 * .. Intrinsic Functions .. 00477 INTRINSIC ABS, MAX, MIN 00478 * .. Scalars in Common .. 00479 INTEGER INFOT, NOUTC 00480 LOGICAL LERR, OK 00481 * .. Common blocks .. 00482 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00483 * .. Data statements .. 00484 DATA ICH/'NTC'/ 00485 * .. Executable Statements .. 00486 FULL = SNAME( 3: 3 ).EQ.'E' 00487 BANDED = SNAME( 3: 3 ).EQ.'B' 00488 * Define the number of arguments. 00489 IF( FULL )THEN 00490 NARGS = 11 00491 ELSE IF( BANDED )THEN 00492 NARGS = 13 00493 END IF 00494 * 00495 NC = 0 00496 RESET = .TRUE. 00497 ERRMAX = ZERO 00498 * 00499 DO 120 IN = 1, NIDIM 00500 N = IDIM( IN ) 00501 ND = N/2 + 1 00502 * 00503 DO 110 IM = 1, 2 00504 IF( IM.EQ.1 ) 00505 $ M = MAX( N - ND, 0 ) 00506 IF( IM.EQ.2 ) 00507 $ M = MIN( N + ND, NMAX ) 00508 * 00509 IF( BANDED )THEN 00510 NK = NKB 00511 ELSE 00512 NK = 1 00513 END IF 00514 DO 100 IKU = 1, NK 00515 IF( BANDED )THEN 00516 KU = KB( IKU ) 00517 KL = MAX( KU - 1, 0 ) 00518 ELSE 00519 KU = N - 1 00520 KL = M - 1 00521 END IF 00522 * Set LDA to 1 more than minimum value if room. 00523 IF( BANDED )THEN 00524 LDA = KL + KU + 1 00525 ELSE 00526 LDA = M 00527 END IF 00528 IF( LDA.LT.NMAX ) 00529 $ LDA = LDA + 1 00530 * Skip tests if not enough room. 00531 IF( LDA.GT.NMAX ) 00532 $ GO TO 100 00533 LAA = LDA*N 00534 NULL = N.LE.0.OR.M.LE.0 00535 * 00536 * Generate the matrix A. 00537 * 00538 TRANSL = ZERO 00539 CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, 00540 $ LDA, KL, KU, RESET, TRANSL ) 00541 * 00542 DO 90 IC = 1, 3 00543 TRANS = ICH( IC: IC ) 00544 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 00545 * 00546 IF( TRAN )THEN 00547 ML = N 00548 NL = M 00549 ELSE 00550 ML = M 00551 NL = N 00552 END IF 00553 * 00554 DO 80 IX = 1, NINC 00555 INCX = INC( IX ) 00556 LX = ABS( INCX )*NL 00557 * 00558 * Generate the vector X. 00559 * 00560 TRANSL = HALF 00561 CALL SMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, 00562 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) 00563 IF( NL.GT.1 )THEN 00564 X( NL/2 ) = ZERO 00565 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO 00566 END IF 00567 * 00568 DO 70 IY = 1, NINC 00569 INCY = INC( IY ) 00570 LY = ABS( INCY )*ML 00571 * 00572 DO 60 IA = 1, NALF 00573 ALPHA = ALF( IA ) 00574 * 00575 DO 50 IB = 1, NBET 00576 BETA = BET( IB ) 00577 * 00578 * Generate the vector Y. 00579 * 00580 TRANSL = ZERO 00581 CALL SMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, 00582 $ YY, ABS( INCY ), 0, ML - 1, 00583 $ RESET, TRANSL ) 00584 * 00585 NC = NC + 1 00586 * 00587 * Save every datum before calling the 00588 * subroutine. 00589 * 00590 TRANSS = TRANS 00591 MS = M 00592 NS = N 00593 KLS = KL 00594 KUS = KU 00595 ALS = ALPHA 00596 DO 10 I = 1, LAA 00597 AS( I ) = AA( I ) 00598 10 CONTINUE 00599 LDAS = LDA 00600 DO 20 I = 1, LX 00601 XS( I ) = XX( I ) 00602 20 CONTINUE 00603 INCXS = INCX 00604 BLS = BETA 00605 DO 30 I = 1, LY 00606 YS( I ) = YY( I ) 00607 30 CONTINUE 00608 INCYS = INCY 00609 * 00610 * Call the subroutine. 00611 * 00612 IF( FULL )THEN 00613 IF( TRACE ) 00614 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 00615 $ TRANS, M, N, ALPHA, LDA, INCX, BETA, 00616 $ INCY 00617 IF( REWI ) 00618 $ REWIND NTRA 00619 CALL SGEMV( TRANS, M, N, ALPHA, AA, 00620 $ LDA, XX, INCX, BETA, YY, 00621 $ INCY ) 00622 ELSE IF( BANDED )THEN 00623 IF( TRACE ) 00624 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 00625 $ TRANS, M, N, KL, KU, ALPHA, LDA, 00626 $ INCX, BETA, INCY 00627 IF( REWI ) 00628 $ REWIND NTRA 00629 CALL SGBMV( TRANS, M, N, KL, KU, ALPHA, 00630 $ AA, LDA, XX, INCX, BETA, 00631 $ YY, INCY ) 00632 END IF 00633 * 00634 * Check if error-exit was taken incorrectly. 00635 * 00636 IF( .NOT.OK )THEN 00637 WRITE( NOUT, FMT = 9993 ) 00638 FATAL = .TRUE. 00639 GO TO 130 00640 END IF 00641 * 00642 * See what data changed inside subroutines. 00643 * 00644 ISAME( 1 ) = TRANS.EQ.TRANSS 00645 ISAME( 2 ) = MS.EQ.M 00646 ISAME( 3 ) = NS.EQ.N 00647 IF( FULL )THEN 00648 ISAME( 4 ) = ALS.EQ.ALPHA 00649 ISAME( 5 ) = LSE( AS, AA, LAA ) 00650 ISAME( 6 ) = LDAS.EQ.LDA 00651 ISAME( 7 ) = LSE( XS, XX, LX ) 00652 ISAME( 8 ) = INCXS.EQ.INCX 00653 ISAME( 9 ) = BLS.EQ.BETA 00654 IF( NULL )THEN 00655 ISAME( 10 ) = LSE( YS, YY, LY ) 00656 ELSE 00657 ISAME( 10 ) = LSERES( 'GE', ' ', 1, 00658 $ ML, YS, YY, 00659 $ ABS( INCY ) ) 00660 END IF 00661 ISAME( 11 ) = INCYS.EQ.INCY 00662 ELSE IF( BANDED )THEN 00663 ISAME( 4 ) = KLS.EQ.KL 00664 ISAME( 5 ) = KUS.EQ.KU 00665 ISAME( 6 ) = ALS.EQ.ALPHA 00666 ISAME( 7 ) = LSE( AS, AA, LAA ) 00667 ISAME( 8 ) = LDAS.EQ.LDA 00668 ISAME( 9 ) = LSE( XS, XX, LX ) 00669 ISAME( 10 ) = INCXS.EQ.INCX 00670 ISAME( 11 ) = BLS.EQ.BETA 00671 IF( NULL )THEN 00672 ISAME( 12 ) = LSE( YS, YY, LY ) 00673 ELSE 00674 ISAME( 12 ) = LSERES( 'GE', ' ', 1, 00675 $ ML, YS, YY, 00676 $ ABS( INCY ) ) 00677 END IF 00678 ISAME( 13 ) = INCYS.EQ.INCY 00679 END IF 00680 * 00681 * If data was incorrectly changed, report 00682 * and return. 00683 * 00684 SAME = .TRUE. 00685 DO 40 I = 1, NARGS 00686 SAME = SAME.AND.ISAME( I ) 00687 IF( .NOT.ISAME( I ) ) 00688 $ WRITE( NOUT, FMT = 9998 )I 00689 40 CONTINUE 00690 IF( .NOT.SAME )THEN 00691 FATAL = .TRUE. 00692 GO TO 130 00693 END IF 00694 * 00695 IF( .NOT.NULL )THEN 00696 * 00697 * Check the result. 00698 * 00699 CALL SMVCH( TRANS, M, N, ALPHA, A, 00700 $ NMAX, X, INCX, BETA, Y, 00701 $ INCY, YT, G, YY, EPS, ERR, 00702 $ FATAL, NOUT, .TRUE. ) 00703 ERRMAX = MAX( ERRMAX, ERR ) 00704 * If got really bad answer, report and 00705 * return. 00706 IF( FATAL ) 00707 $ GO TO 130 00708 ELSE 00709 * Avoid repeating tests with M.le.0 or 00710 * N.le.0. 00711 GO TO 110 00712 END IF 00713 * 00714 50 CONTINUE 00715 * 00716 60 CONTINUE 00717 * 00718 70 CONTINUE 00719 * 00720 80 CONTINUE 00721 * 00722 90 CONTINUE 00723 * 00724 100 CONTINUE 00725 * 00726 110 CONTINUE 00727 * 00728 120 CONTINUE 00729 * 00730 * Report result. 00731 * 00732 IF( ERRMAX.LT.THRESH )THEN 00733 WRITE( NOUT, FMT = 9999 )SNAME, NC 00734 ELSE 00735 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 00736 END IF 00737 GO TO 140 00738 * 00739 130 CONTINUE 00740 WRITE( NOUT, FMT = 9996 )SNAME 00741 IF( FULL )THEN 00742 WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, 00743 $ INCX, BETA, INCY 00744 ELSE IF( BANDED )THEN 00745 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, 00746 $ ALPHA, LDA, INCX, BETA, INCY 00747 END IF 00748 * 00749 140 CONTINUE 00750 RETURN 00751 * 00752 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 00753 $ 'S)' ) 00754 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 00755 $ 'ANGED INCORRECTLY *******' ) 00756 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 00757 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 00758 $ ' - SUSPECT *******' ) 00759 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 00760 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, 00761 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 00762 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, 00763 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, 00764 $ ') .' ) 00765 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 00766 $ '******' ) 00767 * 00768 * End of SCHK1. 00769 * 00770 END 00771 SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 00772 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 00773 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 00774 $ XS, Y, YY, YS, YT, G ) 00775 * 00776 * Tests SSYMV, SSBMV and SSPMV. 00777 * 00778 * Auxiliary routine for test program for Level 2 Blas. 00779 * 00780 * -- Written on 10-August-1987. 00781 * Richard Hanson, Sandia National Labs. 00782 * Jeremy Du Croz, NAG Central Office. 00783 * 00784 * .. Parameters .. 00785 REAL ZERO, HALF 00786 PARAMETER ( ZERO = 0.0, HALF = 0.5 ) 00787 * .. Scalar Arguments .. 00788 REAL EPS, THRESH 00789 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 00790 $ NOUT, NTRA 00791 LOGICAL FATAL, REWI, TRACE 00792 CHARACTER*6 SNAME 00793 * .. Array Arguments .. 00794 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 00795 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), 00796 $ X( NMAX ), XS( NMAX*INCMAX ), 00797 $ XX( NMAX*INCMAX ), Y( NMAX ), 00798 $ YS( NMAX*INCMAX ), YT( NMAX ), 00799 $ YY( NMAX*INCMAX ) 00800 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 00801 * .. Local Scalars .. 00802 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL 00803 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, 00804 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, 00805 $ N, NARGS, NC, NK, NS 00806 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 00807 CHARACTER*1 UPLO, UPLOS 00808 CHARACTER*2 ICH 00809 * .. Local Arrays .. 00810 LOGICAL ISAME( 13 ) 00811 * .. External Functions .. 00812 LOGICAL LSE, LSERES 00813 EXTERNAL LSE, LSERES 00814 * .. External Subroutines .. 00815 EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV 00816 * .. Intrinsic Functions .. 00817 INTRINSIC ABS, MAX 00818 * .. Scalars in Common .. 00819 INTEGER INFOT, NOUTC 00820 LOGICAL LERR, OK 00821 * .. Common blocks .. 00822 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00823 * .. Data statements .. 00824 DATA ICH/'UL'/ 00825 * .. Executable Statements .. 00826 FULL = SNAME( 3: 3 ).EQ.'Y' 00827 BANDED = SNAME( 3: 3 ).EQ.'B' 00828 PACKED = SNAME( 3: 3 ).EQ.'P' 00829 * Define the number of arguments. 00830 IF( FULL )THEN 00831 NARGS = 10 00832 ELSE IF( BANDED )THEN 00833 NARGS = 11 00834 ELSE IF( PACKED )THEN 00835 NARGS = 9 00836 END IF 00837 * 00838 NC = 0 00839 RESET = .TRUE. 00840 ERRMAX = ZERO 00841 * 00842 DO 110 IN = 1, NIDIM 00843 N = IDIM( IN ) 00844 * 00845 IF( BANDED )THEN 00846 NK = NKB 00847 ELSE 00848 NK = 1 00849 END IF 00850 DO 100 IK = 1, NK 00851 IF( BANDED )THEN 00852 K = KB( IK ) 00853 ELSE 00854 K = N - 1 00855 END IF 00856 * Set LDA to 1 more than minimum value if room. 00857 IF( BANDED )THEN 00858 LDA = K + 1 00859 ELSE 00860 LDA = N 00861 END IF 00862 IF( LDA.LT.NMAX ) 00863 $ LDA = LDA + 1 00864 * Skip tests if not enough room. 00865 IF( LDA.GT.NMAX ) 00866 $ GO TO 100 00867 IF( PACKED )THEN 00868 LAA = ( N*( N + 1 ) )/2 00869 ELSE 00870 LAA = LDA*N 00871 END IF 00872 NULL = N.LE.0 00873 * 00874 DO 90 IC = 1, 2 00875 UPLO = ICH( IC: IC ) 00876 * 00877 * Generate the matrix A. 00878 * 00879 TRANSL = ZERO 00880 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, 00881 $ LDA, K, K, RESET, TRANSL ) 00882 * 00883 DO 80 IX = 1, NINC 00884 INCX = INC( IX ) 00885 LX = ABS( INCX )*N 00886 * 00887 * Generate the vector X. 00888 * 00889 TRANSL = HALF 00890 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 00891 $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) 00892 IF( N.GT.1 )THEN 00893 X( N/2 ) = ZERO 00894 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 00895 END IF 00896 * 00897 DO 70 IY = 1, NINC 00898 INCY = INC( IY ) 00899 LY = ABS( INCY )*N 00900 * 00901 DO 60 IA = 1, NALF 00902 ALPHA = ALF( IA ) 00903 * 00904 DO 50 IB = 1, NBET 00905 BETA = BET( IB ) 00906 * 00907 * Generate the vector Y. 00908 * 00909 TRANSL = ZERO 00910 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 00911 $ ABS( INCY ), 0, N - 1, RESET, 00912 $ TRANSL ) 00913 * 00914 NC = NC + 1 00915 * 00916 * Save every datum before calling the 00917 * subroutine. 00918 * 00919 UPLOS = UPLO 00920 NS = N 00921 KS = K 00922 ALS = ALPHA 00923 DO 10 I = 1, LAA 00924 AS( I ) = AA( I ) 00925 10 CONTINUE 00926 LDAS = LDA 00927 DO 20 I = 1, LX 00928 XS( I ) = XX( I ) 00929 20 CONTINUE 00930 INCXS = INCX 00931 BLS = BETA 00932 DO 30 I = 1, LY 00933 YS( I ) = YY( I ) 00934 30 CONTINUE 00935 INCYS = INCY 00936 * 00937 * Call the subroutine. 00938 * 00939 IF( FULL )THEN 00940 IF( TRACE ) 00941 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 00942 $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY 00943 IF( REWI ) 00944 $ REWIND NTRA 00945 CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX, 00946 $ INCX, BETA, YY, INCY ) 00947 ELSE IF( BANDED )THEN 00948 IF( TRACE ) 00949 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 00950 $ UPLO, N, K, ALPHA, LDA, INCX, BETA, 00951 $ INCY 00952 IF( REWI ) 00953 $ REWIND NTRA 00954 CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA, 00955 $ XX, INCX, BETA, YY, INCY ) 00956 ELSE IF( PACKED )THEN 00957 IF( TRACE ) 00958 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 00959 $ UPLO, N, ALPHA, INCX, BETA, INCY 00960 IF( REWI ) 00961 $ REWIND NTRA 00962 CALL SSPMV( UPLO, N, ALPHA, AA, XX, INCX, 00963 $ BETA, YY, INCY ) 00964 END IF 00965 * 00966 * Check if error-exit was taken incorrectly. 00967 * 00968 IF( .NOT.OK )THEN 00969 WRITE( NOUT, FMT = 9992 ) 00970 FATAL = .TRUE. 00971 GO TO 120 00972 END IF 00973 * 00974 * See what data changed inside subroutines. 00975 * 00976 ISAME( 1 ) = UPLO.EQ.UPLOS 00977 ISAME( 2 ) = NS.EQ.N 00978 IF( FULL )THEN 00979 ISAME( 3 ) = ALS.EQ.ALPHA 00980 ISAME( 4 ) = LSE( AS, AA, LAA ) 00981 ISAME( 5 ) = LDAS.EQ.LDA 00982 ISAME( 6 ) = LSE( XS, XX, LX ) 00983 ISAME( 7 ) = INCXS.EQ.INCX 00984 ISAME( 8 ) = BLS.EQ.BETA 00985 IF( NULL )THEN 00986 ISAME( 9 ) = LSE( YS, YY, LY ) 00987 ELSE 00988 ISAME( 9 ) = LSERES( 'GE', ' ', 1, N, 00989 $ YS, YY, ABS( INCY ) ) 00990 END IF 00991 ISAME( 10 ) = INCYS.EQ.INCY 00992 ELSE IF( BANDED )THEN 00993 ISAME( 3 ) = KS.EQ.K 00994 ISAME( 4 ) = ALS.EQ.ALPHA 00995 ISAME( 5 ) = LSE( AS, AA, LAA ) 00996 ISAME( 6 ) = LDAS.EQ.LDA 00997 ISAME( 7 ) = LSE( XS, XX, LX ) 00998 ISAME( 8 ) = INCXS.EQ.INCX 00999 ISAME( 9 ) = BLS.EQ.BETA 01000 IF( NULL )THEN 01001 ISAME( 10 ) = LSE( YS, YY, LY ) 01002 ELSE 01003 ISAME( 10 ) = LSERES( 'GE', ' ', 1, N, 01004 $ YS, YY, ABS( INCY ) ) 01005 END IF 01006 ISAME( 11 ) = INCYS.EQ.INCY 01007 ELSE IF( PACKED )THEN 01008 ISAME( 3 ) = ALS.EQ.ALPHA 01009 ISAME( 4 ) = LSE( AS, AA, LAA ) 01010 ISAME( 5 ) = LSE( XS, XX, LX ) 01011 ISAME( 6 ) = INCXS.EQ.INCX 01012 ISAME( 7 ) = BLS.EQ.BETA 01013 IF( NULL )THEN 01014 ISAME( 8 ) = LSE( YS, YY, LY ) 01015 ELSE 01016 ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, 01017 $ YS, YY, ABS( INCY ) ) 01018 END IF 01019 ISAME( 9 ) = INCYS.EQ.INCY 01020 END IF 01021 * 01022 * If data was incorrectly changed, report and 01023 * return. 01024 * 01025 SAME = .TRUE. 01026 DO 40 I = 1, NARGS 01027 SAME = SAME.AND.ISAME( I ) 01028 IF( .NOT.ISAME( I ) ) 01029 $ WRITE( NOUT, FMT = 9998 )I 01030 40 CONTINUE 01031 IF( .NOT.SAME )THEN 01032 FATAL = .TRUE. 01033 GO TO 120 01034 END IF 01035 * 01036 IF( .NOT.NULL )THEN 01037 * 01038 * Check the result. 01039 * 01040 CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X, 01041 $ INCX, BETA, Y, INCY, YT, G, 01042 $ YY, EPS, ERR, FATAL, NOUT, 01043 $ .TRUE. ) 01044 ERRMAX = MAX( ERRMAX, ERR ) 01045 * If got really bad answer, report and 01046 * return. 01047 IF( FATAL ) 01048 $ GO TO 120 01049 ELSE 01050 * Avoid repeating tests with N.le.0 01051 GO TO 110 01052 END IF 01053 * 01054 50 CONTINUE 01055 * 01056 60 CONTINUE 01057 * 01058 70 CONTINUE 01059 * 01060 80 CONTINUE 01061 * 01062 90 CONTINUE 01063 * 01064 100 CONTINUE 01065 * 01066 110 CONTINUE 01067 * 01068 * Report result. 01069 * 01070 IF( ERRMAX.LT.THRESH )THEN 01071 WRITE( NOUT, FMT = 9999 )SNAME, NC 01072 ELSE 01073 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01074 END IF 01075 GO TO 130 01076 * 01077 120 CONTINUE 01078 WRITE( NOUT, FMT = 9996 )SNAME 01079 IF( FULL )THEN 01080 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, 01081 $ BETA, INCY 01082 ELSE IF( BANDED )THEN 01083 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, 01084 $ INCX, BETA, INCY 01085 ELSE IF( PACKED )THEN 01086 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, 01087 $ BETA, INCY 01088 END IF 01089 * 01090 130 CONTINUE 01091 RETURN 01092 * 01093 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01094 $ 'S)' ) 01095 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01096 $ 'ANGED INCORRECTLY *******' ) 01097 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01098 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01099 $ ' - SUSPECT *******' ) 01100 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01101 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', 01102 $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 01103 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, 01104 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, 01105 $ ') .' ) 01106 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', 01107 $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 01108 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01109 $ '******' ) 01110 * 01111 * End of SCHK2. 01112 * 01113 END 01114 SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01115 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, 01116 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) 01117 * 01118 * Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. 01119 * 01120 * Auxiliary routine for test program for Level 2 Blas. 01121 * 01122 * -- Written on 10-August-1987. 01123 * Richard Hanson, Sandia National Labs. 01124 * Jeremy Du Croz, NAG Central Office. 01125 * 01126 * .. Parameters .. 01127 REAL ZERO, HALF, ONE 01128 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) 01129 * .. Scalar Arguments .. 01130 REAL EPS, THRESH 01131 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA 01132 LOGICAL FATAL, REWI, TRACE 01133 CHARACTER*6 SNAME 01134 * .. Array Arguments .. 01135 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), 01136 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), 01137 $ XS( NMAX*INCMAX ), XT( NMAX ), 01138 $ XX( NMAX*INCMAX ), Z( NMAX ) 01139 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 01140 * .. Local Scalars .. 01141 REAL ERR, ERRMAX, TRANSL 01142 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, 01143 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS 01144 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 01145 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS 01146 CHARACTER*2 ICHD, ICHU 01147 CHARACTER*3 ICHT 01148 * .. Local Arrays .. 01149 LOGICAL ISAME( 13 ) 01150 * .. External Functions .. 01151 LOGICAL LSE, LSERES 01152 EXTERNAL LSE, LSERES 01153 * .. External Subroutines .. 01154 EXTERNAL SMAKE, SMVCH, STBMV, STBSV, STPMV, STPSV, 01155 $ STRMV, STRSV 01156 * .. Intrinsic Functions .. 01157 INTRINSIC ABS, MAX 01158 * .. Scalars in Common .. 01159 INTEGER INFOT, NOUTC 01160 LOGICAL LERR, OK 01161 * .. Common blocks .. 01162 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01163 * .. Data statements .. 01164 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ 01165 * .. Executable Statements .. 01166 FULL = SNAME( 3: 3 ).EQ.'R' 01167 BANDED = SNAME( 3: 3 ).EQ.'B' 01168 PACKED = SNAME( 3: 3 ).EQ.'P' 01169 * Define the number of arguments. 01170 IF( FULL )THEN 01171 NARGS = 8 01172 ELSE IF( BANDED )THEN 01173 NARGS = 9 01174 ELSE IF( PACKED )THEN 01175 NARGS = 7 01176 END IF 01177 * 01178 NC = 0 01179 RESET = .TRUE. 01180 ERRMAX = ZERO 01181 * Set up zero vector for SMVCH. 01182 DO 10 I = 1, NMAX 01183 Z( I ) = ZERO 01184 10 CONTINUE 01185 * 01186 DO 110 IN = 1, NIDIM 01187 N = IDIM( IN ) 01188 * 01189 IF( BANDED )THEN 01190 NK = NKB 01191 ELSE 01192 NK = 1 01193 END IF 01194 DO 100 IK = 1, NK 01195 IF( BANDED )THEN 01196 K = KB( IK ) 01197 ELSE 01198 K = N - 1 01199 END IF 01200 * Set LDA to 1 more than minimum value if room. 01201 IF( BANDED )THEN 01202 LDA = K + 1 01203 ELSE 01204 LDA = N 01205 END IF 01206 IF( LDA.LT.NMAX ) 01207 $ LDA = LDA + 1 01208 * Skip tests if not enough room. 01209 IF( LDA.GT.NMAX ) 01210 $ GO TO 100 01211 IF( PACKED )THEN 01212 LAA = ( N*( N + 1 ) )/2 01213 ELSE 01214 LAA = LDA*N 01215 END IF 01216 NULL = N.LE.0 01217 * 01218 DO 90 ICU = 1, 2 01219 UPLO = ICHU( ICU: ICU ) 01220 * 01221 DO 80 ICT = 1, 3 01222 TRANS = ICHT( ICT: ICT ) 01223 * 01224 DO 70 ICD = 1, 2 01225 DIAG = ICHD( ICD: ICD ) 01226 * 01227 * Generate the matrix A. 01228 * 01229 TRANSL = ZERO 01230 CALL SMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, 01231 $ NMAX, AA, LDA, K, K, RESET, TRANSL ) 01232 * 01233 DO 60 IX = 1, NINC 01234 INCX = INC( IX ) 01235 LX = ABS( INCX )*N 01236 * 01237 * Generate the vector X. 01238 * 01239 TRANSL = HALF 01240 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 01241 $ ABS( INCX ), 0, N - 1, RESET, 01242 $ TRANSL ) 01243 IF( N.GT.1 )THEN 01244 X( N/2 ) = ZERO 01245 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 01246 END IF 01247 * 01248 NC = NC + 1 01249 * 01250 * Save every datum before calling the subroutine. 01251 * 01252 UPLOS = UPLO 01253 TRANSS = TRANS 01254 DIAGS = DIAG 01255 NS = N 01256 KS = K 01257 DO 20 I = 1, LAA 01258 AS( I ) = AA( I ) 01259 20 CONTINUE 01260 LDAS = LDA 01261 DO 30 I = 1, LX 01262 XS( I ) = XX( I ) 01263 30 CONTINUE 01264 INCXS = INCX 01265 * 01266 * Call the subroutine. 01267 * 01268 IF( SNAME( 4: 5 ).EQ.'MV' )THEN 01269 IF( FULL )THEN 01270 IF( TRACE ) 01271 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 01272 $ UPLO, TRANS, DIAG, N, LDA, INCX 01273 IF( REWI ) 01274 $ REWIND NTRA 01275 CALL STRMV( UPLO, TRANS, DIAG, N, AA, LDA, 01276 $ XX, INCX ) 01277 ELSE IF( BANDED )THEN 01278 IF( TRACE ) 01279 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 01280 $ UPLO, TRANS, DIAG, N, K, LDA, INCX 01281 IF( REWI ) 01282 $ REWIND NTRA 01283 CALL STBMV( UPLO, TRANS, DIAG, N, K, AA, 01284 $ LDA, XX, INCX ) 01285 ELSE IF( PACKED )THEN 01286 IF( TRACE ) 01287 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 01288 $ UPLO, TRANS, DIAG, N, INCX 01289 IF( REWI ) 01290 $ REWIND NTRA 01291 CALL STPMV( UPLO, TRANS, DIAG, N, AA, XX, 01292 $ INCX ) 01293 END IF 01294 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 01295 IF( FULL )THEN 01296 IF( TRACE ) 01297 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 01298 $ UPLO, TRANS, DIAG, N, LDA, INCX 01299 IF( REWI ) 01300 $ REWIND NTRA 01301 CALL STRSV( UPLO, TRANS, DIAG, N, AA, LDA, 01302 $ XX, INCX ) 01303 ELSE IF( BANDED )THEN 01304 IF( TRACE ) 01305 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 01306 $ UPLO, TRANS, DIAG, N, K, LDA, INCX 01307 IF( REWI ) 01308 $ REWIND NTRA 01309 CALL STBSV( UPLO, TRANS, DIAG, N, K, AA, 01310 $ LDA, XX, INCX ) 01311 ELSE IF( PACKED )THEN 01312 IF( TRACE ) 01313 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 01314 $ UPLO, TRANS, DIAG, N, INCX 01315 IF( REWI ) 01316 $ REWIND NTRA 01317 CALL STPSV( UPLO, TRANS, DIAG, N, AA, XX, 01318 $ INCX ) 01319 END IF 01320 END IF 01321 * 01322 * Check if error-exit was taken incorrectly. 01323 * 01324 IF( .NOT.OK )THEN 01325 WRITE( NOUT, FMT = 9992 ) 01326 FATAL = .TRUE. 01327 GO TO 120 01328 END IF 01329 * 01330 * See what data changed inside subroutines. 01331 * 01332 ISAME( 1 ) = UPLO.EQ.UPLOS 01333 ISAME( 2 ) = TRANS.EQ.TRANSS 01334 ISAME( 3 ) = DIAG.EQ.DIAGS 01335 ISAME( 4 ) = NS.EQ.N 01336 IF( FULL )THEN 01337 ISAME( 5 ) = LSE( AS, AA, LAA ) 01338 ISAME( 6 ) = LDAS.EQ.LDA 01339 IF( NULL )THEN 01340 ISAME( 7 ) = LSE( XS, XX, LX ) 01341 ELSE 01342 ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS, 01343 $ XX, ABS( INCX ) ) 01344 END IF 01345 ISAME( 8 ) = INCXS.EQ.INCX 01346 ELSE IF( BANDED )THEN 01347 ISAME( 5 ) = KS.EQ.K 01348 ISAME( 6 ) = LSE( AS, AA, LAA ) 01349 ISAME( 7 ) = LDAS.EQ.LDA 01350 IF( NULL )THEN 01351 ISAME( 8 ) = LSE( XS, XX, LX ) 01352 ELSE 01353 ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS, 01354 $ XX, ABS( INCX ) ) 01355 END IF 01356 ISAME( 9 ) = INCXS.EQ.INCX 01357 ELSE IF( PACKED )THEN 01358 ISAME( 5 ) = LSE( AS, AA, LAA ) 01359 IF( NULL )THEN 01360 ISAME( 6 ) = LSE( XS, XX, LX ) 01361 ELSE 01362 ISAME( 6 ) = LSERES( 'GE', ' ', 1, N, XS, 01363 $ XX, ABS( INCX ) ) 01364 END IF 01365 ISAME( 7 ) = INCXS.EQ.INCX 01366 END IF 01367 * 01368 * If data was incorrectly changed, report and 01369 * return. 01370 * 01371 SAME = .TRUE. 01372 DO 40 I = 1, NARGS 01373 SAME = SAME.AND.ISAME( I ) 01374 IF( .NOT.ISAME( I ) ) 01375 $ WRITE( NOUT, FMT = 9998 )I 01376 40 CONTINUE 01377 IF( .NOT.SAME )THEN 01378 FATAL = .TRUE. 01379 GO TO 120 01380 END IF 01381 * 01382 IF( .NOT.NULL )THEN 01383 IF( SNAME( 4: 5 ).EQ.'MV' )THEN 01384 * 01385 * Check the result. 01386 * 01387 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 01388 $ INCX, ZERO, Z, INCX, XT, G, 01389 $ XX, EPS, ERR, FATAL, NOUT, 01390 $ .TRUE. ) 01391 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 01392 * 01393 * Compute approximation to original vector. 01394 * 01395 DO 50 I = 1, N 01396 Z( I ) = XX( 1 + ( I - 1 )* 01397 $ ABS( INCX ) ) 01398 XX( 1 + ( I - 1 )*ABS( INCX ) ) 01399 $ = X( I ) 01400 50 CONTINUE 01401 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z, 01402 $ INCX, ZERO, X, INCX, XT, G, 01403 $ XX, EPS, ERR, FATAL, NOUT, 01404 $ .FALSE. ) 01405 END IF 01406 ERRMAX = MAX( ERRMAX, ERR ) 01407 * If got really bad answer, report and return. 01408 IF( FATAL ) 01409 $ GO TO 120 01410 ELSE 01411 * Avoid repeating tests with N.le.0. 01412 GO TO 110 01413 END IF 01414 * 01415 60 CONTINUE 01416 * 01417 70 CONTINUE 01418 * 01419 80 CONTINUE 01420 * 01421 90 CONTINUE 01422 * 01423 100 CONTINUE 01424 * 01425 110 CONTINUE 01426 * 01427 * Report result. 01428 * 01429 IF( ERRMAX.LT.THRESH )THEN 01430 WRITE( NOUT, FMT = 9999 )SNAME, NC 01431 ELSE 01432 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01433 END IF 01434 GO TO 130 01435 * 01436 120 CONTINUE 01437 WRITE( NOUT, FMT = 9996 )SNAME 01438 IF( FULL )THEN 01439 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, 01440 $ INCX 01441 ELSE IF( BANDED )THEN 01442 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, 01443 $ LDA, INCX 01444 ELSE IF( PACKED )THEN 01445 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX 01446 END IF 01447 * 01448 130 CONTINUE 01449 RETURN 01450 * 01451 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01452 $ 'S)' ) 01453 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01454 $ 'ANGED INCORRECTLY *******' ) 01455 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01456 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01457 $ ' - SUSPECT *******' ) 01458 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01459 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', 01460 $ 'X,', I2, ') .' ) 01461 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), 01462 $ ' A,', I3, ', X,', I2, ') .' ) 01463 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', 01464 $ I3, ', X,', I2, ') .' ) 01465 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01466 $ '******' ) 01467 * 01468 * End of SCHK3. 01469 * 01470 END 01471 SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01472 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 01473 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 01474 $ Z ) 01475 * 01476 * Tests SGER. 01477 * 01478 * Auxiliary routine for test program for Level 2 Blas. 01479 * 01480 * -- Written on 10-August-1987. 01481 * Richard Hanson, Sandia National Labs. 01482 * Jeremy Du Croz, NAG Central Office. 01483 * 01484 * .. Parameters .. 01485 REAL ZERO, HALF, ONE 01486 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) 01487 * .. Scalar Arguments .. 01488 REAL EPS, THRESH 01489 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 01490 LOGICAL FATAL, REWI, TRACE 01491 CHARACTER*6 SNAME 01492 * .. Array Arguments .. 01493 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 01494 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), 01495 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 01496 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 01497 $ YY( NMAX*INCMAX ), Z( NMAX ) 01498 INTEGER IDIM( NIDIM ), INC( NINC ) 01499 * .. Local Scalars .. 01500 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL 01501 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, 01502 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, 01503 $ NC, ND, NS 01504 LOGICAL NULL, RESET, SAME 01505 * .. Local Arrays .. 01506 REAL W( 1 ) 01507 LOGICAL ISAME( 13 ) 01508 * .. External Functions .. 01509 LOGICAL LSE, LSERES 01510 EXTERNAL LSE, LSERES 01511 * .. External Subroutines .. 01512 EXTERNAL SGER, SMAKE, SMVCH 01513 * .. Intrinsic Functions .. 01514 INTRINSIC ABS, MAX, MIN 01515 * .. Scalars in Common .. 01516 INTEGER INFOT, NOUTC 01517 LOGICAL LERR, OK 01518 * .. Common blocks .. 01519 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01520 * .. Executable Statements .. 01521 * Define the number of arguments. 01522 NARGS = 9 01523 * 01524 NC = 0 01525 RESET = .TRUE. 01526 ERRMAX = ZERO 01527 * 01528 DO 120 IN = 1, NIDIM 01529 N = IDIM( IN ) 01530 ND = N/2 + 1 01531 * 01532 DO 110 IM = 1, 2 01533 IF( IM.EQ.1 ) 01534 $ M = MAX( N - ND, 0 ) 01535 IF( IM.EQ.2 ) 01536 $ M = MIN( N + ND, NMAX ) 01537 * 01538 * Set LDA to 1 more than minimum value if room. 01539 LDA = M 01540 IF( LDA.LT.NMAX ) 01541 $ LDA = LDA + 1 01542 * Skip tests if not enough room. 01543 IF( LDA.GT.NMAX ) 01544 $ GO TO 110 01545 LAA = LDA*N 01546 NULL = N.LE.0.OR.M.LE.0 01547 * 01548 DO 100 IX = 1, NINC 01549 INCX = INC( IX ) 01550 LX = ABS( INCX )*M 01551 * 01552 * Generate the vector X. 01553 * 01554 TRANSL = HALF 01555 CALL SMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), 01556 $ 0, M - 1, RESET, TRANSL ) 01557 IF( M.GT.1 )THEN 01558 X( M/2 ) = ZERO 01559 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO 01560 END IF 01561 * 01562 DO 90 IY = 1, NINC 01563 INCY = INC( IY ) 01564 LY = ABS( INCY )*N 01565 * 01566 * Generate the vector Y. 01567 * 01568 TRANSL = ZERO 01569 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 01570 $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 01571 IF( N.GT.1 )THEN 01572 Y( N/2 ) = ZERO 01573 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 01574 END IF 01575 * 01576 DO 80 IA = 1, NALF 01577 ALPHA = ALF( IA ) 01578 * 01579 * Generate the matrix A. 01580 * 01581 TRANSL = ZERO 01582 CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, 01583 $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) 01584 * 01585 NC = NC + 1 01586 * 01587 * Save every datum before calling the subroutine. 01588 * 01589 MS = M 01590 NS = N 01591 ALS = ALPHA 01592 DO 10 I = 1, LAA 01593 AS( I ) = AA( I ) 01594 10 CONTINUE 01595 LDAS = LDA 01596 DO 20 I = 1, LX 01597 XS( I ) = XX( I ) 01598 20 CONTINUE 01599 INCXS = INCX 01600 DO 30 I = 1, LY 01601 YS( I ) = YY( I ) 01602 30 CONTINUE 01603 INCYS = INCY 01604 * 01605 * Call the subroutine. 01606 * 01607 IF( TRACE ) 01608 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, 01609 $ ALPHA, INCX, INCY, LDA 01610 IF( REWI ) 01611 $ REWIND NTRA 01612 CALL SGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, 01613 $ LDA ) 01614 * 01615 * Check if error-exit was taken incorrectly. 01616 * 01617 IF( .NOT.OK )THEN 01618 WRITE( NOUT, FMT = 9993 ) 01619 FATAL = .TRUE. 01620 GO TO 140 01621 END IF 01622 * 01623 * See what data changed inside subroutine. 01624 * 01625 ISAME( 1 ) = MS.EQ.M 01626 ISAME( 2 ) = NS.EQ.N 01627 ISAME( 3 ) = ALS.EQ.ALPHA 01628 ISAME( 4 ) = LSE( XS, XX, LX ) 01629 ISAME( 5 ) = INCXS.EQ.INCX 01630 ISAME( 6 ) = LSE( YS, YY, LY ) 01631 ISAME( 7 ) = INCYS.EQ.INCY 01632 IF( NULL )THEN 01633 ISAME( 8 ) = LSE( AS, AA, LAA ) 01634 ELSE 01635 ISAME( 8 ) = LSERES( 'GE', ' ', M, N, AS, AA, 01636 $ LDA ) 01637 END IF 01638 ISAME( 9 ) = LDAS.EQ.LDA 01639 * 01640 * If data was incorrectly changed, report and return. 01641 * 01642 SAME = .TRUE. 01643 DO 40 I = 1, NARGS 01644 SAME = SAME.AND.ISAME( I ) 01645 IF( .NOT.ISAME( I ) ) 01646 $ WRITE( NOUT, FMT = 9998 )I 01647 40 CONTINUE 01648 IF( .NOT.SAME )THEN 01649 FATAL = .TRUE. 01650 GO TO 140 01651 END IF 01652 * 01653 IF( .NOT.NULL )THEN 01654 * 01655 * Check the result column by column. 01656 * 01657 IF( INCX.GT.0 )THEN 01658 DO 50 I = 1, M 01659 Z( I ) = X( I ) 01660 50 CONTINUE 01661 ELSE 01662 DO 60 I = 1, M 01663 Z( I ) = X( M - I + 1 ) 01664 60 CONTINUE 01665 END IF 01666 DO 70 J = 1, N 01667 IF( INCY.GT.0 )THEN 01668 W( 1 ) = Y( J ) 01669 ELSE 01670 W( 1 ) = Y( N - J + 1 ) 01671 END IF 01672 CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, 01673 $ ONE, A( 1, J ), 1, YT, G, 01674 $ AA( 1 + ( J - 1 )*LDA ), EPS, 01675 $ ERR, FATAL, NOUT, .TRUE. ) 01676 ERRMAX = MAX( ERRMAX, ERR ) 01677 * If got really bad answer, report and return. 01678 IF( FATAL ) 01679 $ GO TO 130 01680 70 CONTINUE 01681 ELSE 01682 * Avoid repeating tests with M.le.0 or N.le.0. 01683 GO TO 110 01684 END IF 01685 * 01686 80 CONTINUE 01687 * 01688 90 CONTINUE 01689 * 01690 100 CONTINUE 01691 * 01692 110 CONTINUE 01693 * 01694 120 CONTINUE 01695 * 01696 * Report result. 01697 * 01698 IF( ERRMAX.LT.THRESH )THEN 01699 WRITE( NOUT, FMT = 9999 )SNAME, NC 01700 ELSE 01701 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01702 END IF 01703 GO TO 150 01704 * 01705 130 CONTINUE 01706 WRITE( NOUT, FMT = 9995 )J 01707 * 01708 140 CONTINUE 01709 WRITE( NOUT, FMT = 9996 )SNAME 01710 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA 01711 * 01712 150 CONTINUE 01713 RETURN 01714 * 01715 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01716 $ 'S)' ) 01717 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01718 $ 'ANGED INCORRECTLY *******' ) 01719 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01720 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01721 $ ' - SUSPECT *******' ) 01722 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01723 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 01724 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, 01725 $ ', Y,', I2, ', A,', I3, ') .' ) 01726 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01727 $ '******' ) 01728 * 01729 * End of SCHK4. 01730 * 01731 END 01732 SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01733 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 01734 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 01735 $ Z ) 01736 * 01737 * Tests SSYR and SSPR. 01738 * 01739 * Auxiliary routine for test program for Level 2 Blas. 01740 * 01741 * -- Written on 10-August-1987. 01742 * Richard Hanson, Sandia National Labs. 01743 * Jeremy Du Croz, NAG Central Office. 01744 * 01745 * .. Parameters .. 01746 REAL ZERO, HALF, ONE 01747 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) 01748 * .. Scalar Arguments .. 01749 REAL EPS, THRESH 01750 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 01751 LOGICAL FATAL, REWI, TRACE 01752 CHARACTER*6 SNAME 01753 * .. Array Arguments .. 01754 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 01755 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), 01756 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 01757 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 01758 $ YY( NMAX*INCMAX ), Z( NMAX ) 01759 INTEGER IDIM( NIDIM ), INC( NINC ) 01760 * .. Local Scalars .. 01761 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL 01762 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, 01763 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS 01764 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 01765 CHARACTER*1 UPLO, UPLOS 01766 CHARACTER*2 ICH 01767 * .. Local Arrays .. 01768 REAL W( 1 ) 01769 LOGICAL ISAME( 13 ) 01770 * .. External Functions .. 01771 LOGICAL LSE, LSERES 01772 EXTERNAL LSE, LSERES 01773 * .. External Subroutines .. 01774 EXTERNAL SMAKE, SMVCH, SSPR, SSYR 01775 * .. Intrinsic Functions .. 01776 INTRINSIC ABS, MAX 01777 * .. Scalars in Common .. 01778 INTEGER INFOT, NOUTC 01779 LOGICAL LERR, OK 01780 * .. Common blocks .. 01781 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01782 * .. Data statements .. 01783 DATA ICH/'UL'/ 01784 * .. Executable Statements .. 01785 FULL = SNAME( 3: 3 ).EQ.'Y' 01786 PACKED = SNAME( 3: 3 ).EQ.'P' 01787 * Define the number of arguments. 01788 IF( FULL )THEN 01789 NARGS = 7 01790 ELSE IF( PACKED )THEN 01791 NARGS = 6 01792 END IF 01793 * 01794 NC = 0 01795 RESET = .TRUE. 01796 ERRMAX = ZERO 01797 * 01798 DO 100 IN = 1, NIDIM 01799 N = IDIM( IN ) 01800 * Set LDA to 1 more than minimum value if room. 01801 LDA = N 01802 IF( LDA.LT.NMAX ) 01803 $ LDA = LDA + 1 01804 * Skip tests if not enough room. 01805 IF( LDA.GT.NMAX ) 01806 $ GO TO 100 01807 IF( PACKED )THEN 01808 LAA = ( N*( N + 1 ) )/2 01809 ELSE 01810 LAA = LDA*N 01811 END IF 01812 * 01813 DO 90 IC = 1, 2 01814 UPLO = ICH( IC: IC ) 01815 UPPER = UPLO.EQ.'U' 01816 * 01817 DO 80 IX = 1, NINC 01818 INCX = INC( IX ) 01819 LX = ABS( INCX )*N 01820 * 01821 * Generate the vector X. 01822 * 01823 TRANSL = HALF 01824 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 01825 $ 0, N - 1, RESET, TRANSL ) 01826 IF( N.GT.1 )THEN 01827 X( N/2 ) = ZERO 01828 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 01829 END IF 01830 * 01831 DO 70 IA = 1, NALF 01832 ALPHA = ALF( IA ) 01833 NULL = N.LE.0.OR.ALPHA.EQ.ZERO 01834 * 01835 * Generate the matrix A. 01836 * 01837 TRANSL = ZERO 01838 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, 01839 $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) 01840 * 01841 NC = NC + 1 01842 * 01843 * Save every datum before calling the subroutine. 01844 * 01845 UPLOS = UPLO 01846 NS = N 01847 ALS = ALPHA 01848 DO 10 I = 1, LAA 01849 AS( I ) = AA( I ) 01850 10 CONTINUE 01851 LDAS = LDA 01852 DO 20 I = 1, LX 01853 XS( I ) = XX( I ) 01854 20 CONTINUE 01855 INCXS = INCX 01856 * 01857 * Call the subroutine. 01858 * 01859 IF( FULL )THEN 01860 IF( TRACE ) 01861 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 01862 $ ALPHA, INCX, LDA 01863 IF( REWI ) 01864 $ REWIND NTRA 01865 CALL SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) 01866 ELSE IF( PACKED )THEN 01867 IF( TRACE ) 01868 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 01869 $ ALPHA, INCX 01870 IF( REWI ) 01871 $ REWIND NTRA 01872 CALL SSPR( UPLO, N, ALPHA, XX, INCX, AA ) 01873 END IF 01874 * 01875 * Check if error-exit was taken incorrectly. 01876 * 01877 IF( .NOT.OK )THEN 01878 WRITE( NOUT, FMT = 9992 ) 01879 FATAL = .TRUE. 01880 GO TO 120 01881 END IF 01882 * 01883 * See what data changed inside subroutines. 01884 * 01885 ISAME( 1 ) = UPLO.EQ.UPLOS 01886 ISAME( 2 ) = NS.EQ.N 01887 ISAME( 3 ) = ALS.EQ.ALPHA 01888 ISAME( 4 ) = LSE( XS, XX, LX ) 01889 ISAME( 5 ) = INCXS.EQ.INCX 01890 IF( NULL )THEN 01891 ISAME( 6 ) = LSE( AS, AA, LAA ) 01892 ELSE 01893 ISAME( 6 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, AS, 01894 $ AA, LDA ) 01895 END IF 01896 IF( .NOT.PACKED )THEN 01897 ISAME( 7 ) = LDAS.EQ.LDA 01898 END IF 01899 * 01900 * If data was incorrectly changed, report and return. 01901 * 01902 SAME = .TRUE. 01903 DO 30 I = 1, NARGS 01904 SAME = SAME.AND.ISAME( I ) 01905 IF( .NOT.ISAME( I ) ) 01906 $ WRITE( NOUT, FMT = 9998 )I 01907 30 CONTINUE 01908 IF( .NOT.SAME )THEN 01909 FATAL = .TRUE. 01910 GO TO 120 01911 END IF 01912 * 01913 IF( .NOT.NULL )THEN 01914 * 01915 * Check the result column by column. 01916 * 01917 IF( INCX.GT.0 )THEN 01918 DO 40 I = 1, N 01919 Z( I ) = X( I ) 01920 40 CONTINUE 01921 ELSE 01922 DO 50 I = 1, N 01923 Z( I ) = X( N - I + 1 ) 01924 50 CONTINUE 01925 END IF 01926 JA = 1 01927 DO 60 J = 1, N 01928 W( 1 ) = Z( J ) 01929 IF( UPPER )THEN 01930 JJ = 1 01931 LJ = J 01932 ELSE 01933 JJ = J 01934 LJ = N - J + 1 01935 END IF 01936 CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, 01937 $ 1, ONE, A( JJ, J ), 1, YT, G, 01938 $ AA( JA ), EPS, ERR, FATAL, NOUT, 01939 $ .TRUE. ) 01940 IF( FULL )THEN 01941 IF( UPPER )THEN 01942 JA = JA + LDA 01943 ELSE 01944 JA = JA + LDA + 1 01945 END IF 01946 ELSE 01947 JA = JA + LJ 01948 END IF 01949 ERRMAX = MAX( ERRMAX, ERR ) 01950 * If got really bad answer, report and return. 01951 IF( FATAL ) 01952 $ GO TO 110 01953 60 CONTINUE 01954 ELSE 01955 * Avoid repeating tests if N.le.0. 01956 IF( N.LE.0 ) 01957 $ GO TO 100 01958 END IF 01959 * 01960 70 CONTINUE 01961 * 01962 80 CONTINUE 01963 * 01964 90 CONTINUE 01965 * 01966 100 CONTINUE 01967 * 01968 * Report result. 01969 * 01970 IF( ERRMAX.LT.THRESH )THEN 01971 WRITE( NOUT, FMT = 9999 )SNAME, NC 01972 ELSE 01973 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01974 END IF 01975 GO TO 130 01976 * 01977 110 CONTINUE 01978 WRITE( NOUT, FMT = 9995 )J 01979 * 01980 120 CONTINUE 01981 WRITE( NOUT, FMT = 9996 )SNAME 01982 IF( FULL )THEN 01983 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA 01984 ELSE IF( PACKED )THEN 01985 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX 01986 END IF 01987 * 01988 130 CONTINUE 01989 RETURN 01990 * 01991 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01992 $ 'S)' ) 01993 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01994 $ 'ANGED INCORRECTLY *******' ) 01995 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01996 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01997 $ ' - SUSPECT *******' ) 01998 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01999 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 02000 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02001 $ I2, ', AP) .' ) 02002 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02003 $ I2, ', A,', I3, ') .' ) 02004 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 02005 $ '******' ) 02006 * 02007 * End of SCHK5. 02008 * 02009 END 02010 SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 02011 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 02012 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 02013 $ Z ) 02014 * 02015 * Tests SSYR2 and SSPR2. 02016 * 02017 * Auxiliary routine for test program for Level 2 Blas. 02018 * 02019 * -- Written on 10-August-1987. 02020 * Richard Hanson, Sandia National Labs. 02021 * Jeremy Du Croz, NAG Central Office. 02022 * 02023 * .. Parameters .. 02024 REAL ZERO, HALF, ONE 02025 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) 02026 * .. Scalar Arguments .. 02027 REAL EPS, THRESH 02028 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 02029 LOGICAL FATAL, REWI, TRACE 02030 CHARACTER*6 SNAME 02031 * .. Array Arguments .. 02032 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 02033 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), 02034 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 02035 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 02036 $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) 02037 INTEGER IDIM( NIDIM ), INC( NINC ) 02038 * .. Local Scalars .. 02039 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL 02040 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, 02041 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, 02042 $ NARGS, NC, NS 02043 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 02044 CHARACTER*1 UPLO, UPLOS 02045 CHARACTER*2 ICH 02046 * .. Local Arrays .. 02047 REAL W( 2 ) 02048 LOGICAL ISAME( 13 ) 02049 * .. External Functions .. 02050 LOGICAL LSE, LSERES 02051 EXTERNAL LSE, LSERES 02052 * .. External Subroutines .. 02053 EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2 02054 * .. Intrinsic Functions .. 02055 INTRINSIC ABS, MAX 02056 * .. Scalars in Common .. 02057 INTEGER INFOT, NOUTC 02058 LOGICAL LERR, OK 02059 * .. Common blocks .. 02060 COMMON /INFOC/INFOT, NOUTC, OK, LERR 02061 * .. Data statements .. 02062 DATA ICH/'UL'/ 02063 * .. Executable Statements .. 02064 FULL = SNAME( 3: 3 ).EQ.'Y' 02065 PACKED = SNAME( 3: 3 ).EQ.'P' 02066 * Define the number of arguments. 02067 IF( FULL )THEN 02068 NARGS = 9 02069 ELSE IF( PACKED )THEN 02070 NARGS = 8 02071 END IF 02072 * 02073 NC = 0 02074 RESET = .TRUE. 02075 ERRMAX = ZERO 02076 * 02077 DO 140 IN = 1, NIDIM 02078 N = IDIM( IN ) 02079 * Set LDA to 1 more than minimum value if room. 02080 LDA = N 02081 IF( LDA.LT.NMAX ) 02082 $ LDA = LDA + 1 02083 * Skip tests if not enough room. 02084 IF( LDA.GT.NMAX ) 02085 $ GO TO 140 02086 IF( PACKED )THEN 02087 LAA = ( N*( N + 1 ) )/2 02088 ELSE 02089 LAA = LDA*N 02090 END IF 02091 * 02092 DO 130 IC = 1, 2 02093 UPLO = ICH( IC: IC ) 02094 UPPER = UPLO.EQ.'U' 02095 * 02096 DO 120 IX = 1, NINC 02097 INCX = INC( IX ) 02098 LX = ABS( INCX )*N 02099 * 02100 * Generate the vector X. 02101 * 02102 TRANSL = HALF 02103 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 02104 $ 0, N - 1, RESET, TRANSL ) 02105 IF( N.GT.1 )THEN 02106 X( N/2 ) = ZERO 02107 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 02108 END IF 02109 * 02110 DO 110 IY = 1, NINC 02111 INCY = INC( IY ) 02112 LY = ABS( INCY )*N 02113 * 02114 * Generate the vector Y. 02115 * 02116 TRANSL = ZERO 02117 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 02118 $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 02119 IF( N.GT.1 )THEN 02120 Y( N/2 ) = ZERO 02121 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 02122 END IF 02123 * 02124 DO 100 IA = 1, NALF 02125 ALPHA = ALF( IA ) 02126 NULL = N.LE.0.OR.ALPHA.EQ.ZERO 02127 * 02128 * Generate the matrix A. 02129 * 02130 TRANSL = ZERO 02131 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, 02132 $ NMAX, AA, LDA, N - 1, N - 1, RESET, 02133 $ TRANSL ) 02134 * 02135 NC = NC + 1 02136 * 02137 * Save every datum before calling the subroutine. 02138 * 02139 UPLOS = UPLO 02140 NS = N 02141 ALS = ALPHA 02142 DO 10 I = 1, LAA 02143 AS( I ) = AA( I ) 02144 10 CONTINUE 02145 LDAS = LDA 02146 DO 20 I = 1, LX 02147 XS( I ) = XX( I ) 02148 20 CONTINUE 02149 INCXS = INCX 02150 DO 30 I = 1, LY 02151 YS( I ) = YY( I ) 02152 30 CONTINUE 02153 INCYS = INCY 02154 * 02155 * Call the subroutine. 02156 * 02157 IF( FULL )THEN 02158 IF( TRACE ) 02159 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 02160 $ ALPHA, INCX, INCY, LDA 02161 IF( REWI ) 02162 $ REWIND NTRA 02163 CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 02164 $ AA, LDA ) 02165 ELSE IF( PACKED )THEN 02166 IF( TRACE ) 02167 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 02168 $ ALPHA, INCX, INCY 02169 IF( REWI ) 02170 $ REWIND NTRA 02171 CALL SSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 02172 $ AA ) 02173 END IF 02174 * 02175 * Check if error-exit was taken incorrectly. 02176 * 02177 IF( .NOT.OK )THEN 02178 WRITE( NOUT, FMT = 9992 ) 02179 FATAL = .TRUE. 02180 GO TO 160 02181 END IF 02182 * 02183 * See what data changed inside subroutines. 02184 * 02185 ISAME( 1 ) = UPLO.EQ.UPLOS 02186 ISAME( 2 ) = NS.EQ.N 02187 ISAME( 3 ) = ALS.EQ.ALPHA 02188 ISAME( 4 ) = LSE( XS, XX, LX ) 02189 ISAME( 5 ) = INCXS.EQ.INCX 02190 ISAME( 6 ) = LSE( YS, YY, LY ) 02191 ISAME( 7 ) = INCYS.EQ.INCY 02192 IF( NULL )THEN 02193 ISAME( 8 ) = LSE( AS, AA, LAA ) 02194 ELSE 02195 ISAME( 8 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, 02196 $ AS, AA, LDA ) 02197 END IF 02198 IF( .NOT.PACKED )THEN 02199 ISAME( 9 ) = LDAS.EQ.LDA 02200 END IF 02201 * 02202 * If data was incorrectly changed, report and return. 02203 * 02204 SAME = .TRUE. 02205 DO 40 I = 1, NARGS 02206 SAME = SAME.AND.ISAME( I ) 02207 IF( .NOT.ISAME( I ) ) 02208 $ WRITE( NOUT, FMT = 9998 )I 02209 40 CONTINUE 02210 IF( .NOT.SAME )THEN 02211 FATAL = .TRUE. 02212 GO TO 160 02213 END IF 02214 * 02215 IF( .NOT.NULL )THEN 02216 * 02217 * Check the result column by column. 02218 * 02219 IF( INCX.GT.0 )THEN 02220 DO 50 I = 1, N 02221 Z( I, 1 ) = X( I ) 02222 50 CONTINUE 02223 ELSE 02224 DO 60 I = 1, N 02225 Z( I, 1 ) = X( N - I + 1 ) 02226 60 CONTINUE 02227 END IF 02228 IF( INCY.GT.0 )THEN 02229 DO 70 I = 1, N 02230 Z( I, 2 ) = Y( I ) 02231 70 CONTINUE 02232 ELSE 02233 DO 80 I = 1, N 02234 Z( I, 2 ) = Y( N - I + 1 ) 02235 80 CONTINUE 02236 END IF 02237 JA = 1 02238 DO 90 J = 1, N 02239 W( 1 ) = Z( J, 2 ) 02240 W( 2 ) = Z( J, 1 ) 02241 IF( UPPER )THEN 02242 JJ = 1 02243 LJ = J 02244 ELSE 02245 JJ = J 02246 LJ = N - J + 1 02247 END IF 02248 CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), 02249 $ NMAX, W, 1, ONE, A( JJ, J ), 1, 02250 $ YT, G, AA( JA ), EPS, ERR, FATAL, 02251 $ NOUT, .TRUE. ) 02252 IF( FULL )THEN 02253 IF( UPPER )THEN 02254 JA = JA + LDA 02255 ELSE 02256 JA = JA + LDA + 1 02257 END IF 02258 ELSE 02259 JA = JA + LJ 02260 END IF 02261 ERRMAX = MAX( ERRMAX, ERR ) 02262 * If got really bad answer, report and return. 02263 IF( FATAL ) 02264 $ GO TO 150 02265 90 CONTINUE 02266 ELSE 02267 * Avoid repeating tests with N.le.0. 02268 IF( N.LE.0 ) 02269 $ GO TO 140 02270 END IF 02271 * 02272 100 CONTINUE 02273 * 02274 110 CONTINUE 02275 * 02276 120 CONTINUE 02277 * 02278 130 CONTINUE 02279 * 02280 140 CONTINUE 02281 * 02282 * Report result. 02283 * 02284 IF( ERRMAX.LT.THRESH )THEN 02285 WRITE( NOUT, FMT = 9999 )SNAME, NC 02286 ELSE 02287 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 02288 END IF 02289 GO TO 170 02290 * 02291 150 CONTINUE 02292 WRITE( NOUT, FMT = 9995 )J 02293 * 02294 160 CONTINUE 02295 WRITE( NOUT, FMT = 9996 )SNAME 02296 IF( FULL )THEN 02297 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, 02298 $ INCY, LDA 02299 ELSE IF( PACKED )THEN 02300 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY 02301 END IF 02302 * 02303 170 CONTINUE 02304 RETURN 02305 * 02306 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 02307 $ 'S)' ) 02308 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 02309 $ 'ANGED INCORRECTLY *******' ) 02310 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 02311 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 02312 $ ' - SUSPECT *******' ) 02313 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 02314 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 02315 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02316 $ I2, ', Y,', I2, ', AP) .' ) 02317 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02318 $ I2, ', Y,', I2, ', A,', I3, ') .' ) 02319 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 02320 $ '******' ) 02321 * 02322 * End of SCHK6. 02323 * 02324 END 02325 SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) 02326 * 02327 * Tests the error exits from the Level 2 Blas. 02328 * Requires a special version of the error-handling routine XERBLA. 02329 * ALPHA, BETA, A, X and Y should not need to be defined. 02330 * 02331 * Auxiliary routine for test program for Level 2 Blas. 02332 * 02333 * -- Written on 10-August-1987. 02334 * Richard Hanson, Sandia National Labs. 02335 * Jeremy Du Croz, NAG Central Office. 02336 * 02337 * .. Scalar Arguments .. 02338 INTEGER ISNUM, NOUT 02339 CHARACTER*6 SRNAMT 02340 * .. Scalars in Common .. 02341 INTEGER INFOT, NOUTC 02342 LOGICAL LERR, OK 02343 * .. Local Scalars .. 02344 REAL ALPHA, BETA 02345 * .. Local Arrays .. 02346 REAL A( 1, 1 ), X( 1 ), Y( 1 ) 02347 * .. External Subroutines .. 02348 EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR, 02349 $ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV, 02350 $ STPSV, STRMV, STRSV 02351 * .. Common blocks .. 02352 COMMON /INFOC/INFOT, NOUTC, OK, LERR 02353 * .. Executable Statements .. 02354 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER 02355 * if anything is wrong. 02356 OK = .TRUE. 02357 * LERR is set to .TRUE. by the special version of XERBLA each time 02358 * it is called, and is then tested and re-set by CHKXER. 02359 LERR = .FALSE. 02360 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 02361 $ 90, 100, 110, 120, 130, 140, 150, 02362 $ 160 )ISNUM 02363 10 INFOT = 1 02364 CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02365 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02366 INFOT = 2 02367 CALL SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02368 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02369 INFOT = 3 02370 CALL SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02371 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02372 INFOT = 6 02373 CALL SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02374 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02375 INFOT = 8 02376 CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02377 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02378 INFOT = 11 02379 CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02380 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02381 GO TO 170 02382 20 INFOT = 1 02383 CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02384 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02385 INFOT = 2 02386 CALL SGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02387 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02388 INFOT = 3 02389 CALL SGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02390 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02391 INFOT = 4 02392 CALL SGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02393 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02394 INFOT = 5 02395 CALL SGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02396 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02397 INFOT = 8 02398 CALL SGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02399 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02400 INFOT = 10 02401 CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02402 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02403 INFOT = 13 02404 CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02405 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02406 GO TO 170 02407 30 INFOT = 1 02408 CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02409 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02410 INFOT = 2 02411 CALL SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02412 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02413 INFOT = 5 02414 CALL SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02415 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02416 INFOT = 7 02417 CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02418 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02419 INFOT = 10 02420 CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02421 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02422 GO TO 170 02423 40 INFOT = 1 02424 CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02425 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02426 INFOT = 2 02427 CALL SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02428 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02429 INFOT = 3 02430 CALL SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02431 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02432 INFOT = 6 02433 CALL SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02434 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02435 INFOT = 8 02436 CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02437 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02438 INFOT = 11 02439 CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02440 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02441 GO TO 170 02442 50 INFOT = 1 02443 CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) 02444 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02445 INFOT = 2 02446 CALL SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) 02447 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02448 INFOT = 6 02449 CALL SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) 02450 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02451 INFOT = 9 02452 CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) 02453 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02454 GO TO 170 02455 60 INFOT = 1 02456 CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) 02457 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02458 INFOT = 2 02459 CALL STRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) 02460 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02461 INFOT = 3 02462 CALL STRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) 02463 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02464 INFOT = 4 02465 CALL STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 02466 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02467 INFOT = 6 02468 CALL STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 02469 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02470 INFOT = 8 02471 CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 02472 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02473 GO TO 170 02474 70 INFOT = 1 02475 CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 02476 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02477 INFOT = 2 02478 CALL STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 02479 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02480 INFOT = 3 02481 CALL STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 02482 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02483 INFOT = 4 02484 CALL STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 02485 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02486 INFOT = 5 02487 CALL STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 02488 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02489 INFOT = 7 02490 CALL STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 02491 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02492 INFOT = 9 02493 CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 02494 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02495 GO TO 170 02496 80 INFOT = 1 02497 CALL STPMV( '/', 'N', 'N', 0, A, X, 1 ) 02498 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02499 INFOT = 2 02500 CALL STPMV( 'U', '/', 'N', 0, A, X, 1 ) 02501 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02502 INFOT = 3 02503 CALL STPMV( 'U', 'N', '/', 0, A, X, 1 ) 02504 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02505 INFOT = 4 02506 CALL STPMV( 'U', 'N', 'N', -1, A, X, 1 ) 02507 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02508 INFOT = 7 02509 CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 ) 02510 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02511 GO TO 170 02512 90 INFOT = 1 02513 CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) 02514 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02515 INFOT = 2 02516 CALL STRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) 02517 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02518 INFOT = 3 02519 CALL STRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) 02520 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02521 INFOT = 4 02522 CALL STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 02523 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02524 INFOT = 6 02525 CALL STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 02526 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02527 INFOT = 8 02528 CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 02529 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02530 GO TO 170 02531 100 INFOT = 1 02532 CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 02533 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02534 INFOT = 2 02535 CALL STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 02536 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02537 INFOT = 3 02538 CALL STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 02539 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02540 INFOT = 4 02541 CALL STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 02542 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02543 INFOT = 5 02544 CALL STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 02545 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02546 INFOT = 7 02547 CALL STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 02548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02549 INFOT = 9 02550 CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 02551 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02552 GO TO 170 02553 110 INFOT = 1 02554 CALL STPSV( '/', 'N', 'N', 0, A, X, 1 ) 02555 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02556 INFOT = 2 02557 CALL STPSV( 'U', '/', 'N', 0, A, X, 1 ) 02558 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02559 INFOT = 3 02560 CALL STPSV( 'U', 'N', '/', 0, A, X, 1 ) 02561 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02562 INFOT = 4 02563 CALL STPSV( 'U', 'N', 'N', -1, A, X, 1 ) 02564 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02565 INFOT = 7 02566 CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 ) 02567 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02568 GO TO 170 02569 120 INFOT = 1 02570 CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02571 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02572 INFOT = 2 02573 CALL SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) 02574 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02575 INFOT = 5 02576 CALL SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) 02577 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02578 INFOT = 7 02579 CALL SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) 02580 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02581 INFOT = 9 02582 CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02583 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02584 GO TO 170 02585 130 INFOT = 1 02586 CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 ) 02587 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02588 INFOT = 2 02589 CALL SSYR( 'U', -1, ALPHA, X, 1, A, 1 ) 02590 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02591 INFOT = 5 02592 CALL SSYR( 'U', 0, ALPHA, X, 0, A, 1 ) 02593 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02594 INFOT = 7 02595 CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 ) 02596 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02597 GO TO 170 02598 140 INFOT = 1 02599 CALL SSPR( '/', 0, ALPHA, X, 1, A ) 02600 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02601 INFOT = 2 02602 CALL SSPR( 'U', -1, ALPHA, X, 1, A ) 02603 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02604 INFOT = 5 02605 CALL SSPR( 'U', 0, ALPHA, X, 0, A ) 02606 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02607 GO TO 170 02608 150 INFOT = 1 02609 CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) 02610 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02611 INFOT = 2 02612 CALL SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) 02613 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02614 INFOT = 5 02615 CALL SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) 02616 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02617 INFOT = 7 02618 CALL SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) 02619 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02620 INFOT = 9 02621 CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) 02622 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02623 GO TO 170 02624 160 INFOT = 1 02625 CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) 02626 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02627 INFOT = 2 02628 CALL SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) 02629 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02630 INFOT = 5 02631 CALL SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) 02632 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02633 INFOT = 7 02634 CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) 02635 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02636 * 02637 170 IF( OK )THEN 02638 WRITE( NOUT, FMT = 9999 )SRNAMT 02639 ELSE 02640 WRITE( NOUT, FMT = 9998 )SRNAMT 02641 END IF 02642 RETURN 02643 * 02644 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 02645 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', 02646 $ '**' ) 02647 * 02648 * End of SCHKE. 02649 * 02650 END 02651 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, 02652 $ KU, RESET, TRANSL ) 02653 * 02654 * Generates values for an M by N matrix A within the bandwidth 02655 * defined by KL and KU. 02656 * Stores the values in the array AA in the data structure required 02657 * by the routine, with unwanted elements set to rogue value. 02658 * 02659 * TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. 02660 * 02661 * Auxiliary routine for test program for Level 2 Blas. 02662 * 02663 * -- Written on 10-August-1987. 02664 * Richard Hanson, Sandia National Labs. 02665 * Jeremy Du Croz, NAG Central Office. 02666 * 02667 * .. Parameters .. 02668 REAL ZERO, ONE 02669 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 02670 REAL ROGUE 02671 PARAMETER ( ROGUE = -1.0E10 ) 02672 * .. Scalar Arguments .. 02673 REAL TRANSL 02674 INTEGER KL, KU, LDA, M, N, NMAX 02675 LOGICAL RESET 02676 CHARACTER*1 DIAG, UPLO 02677 CHARACTER*2 TYPE 02678 * .. Array Arguments .. 02679 REAL A( NMAX, * ), AA( * ) 02680 * .. Local Scalars .. 02681 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK 02682 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER 02683 * .. External Functions .. 02684 REAL SBEG 02685 EXTERNAL SBEG 02686 * .. Intrinsic Functions .. 02687 INTRINSIC MAX, MIN 02688 * .. Executable Statements .. 02689 GEN = TYPE( 1: 1 ).EQ.'G' 02690 SYM = TYPE( 1: 1 ).EQ.'S' 02691 TRI = TYPE( 1: 1 ).EQ.'T' 02692 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' 02693 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' 02694 UNIT = TRI.AND.DIAG.EQ.'U' 02695 * 02696 * Generate data in array A. 02697 * 02698 DO 20 J = 1, N 02699 DO 10 I = 1, M 02700 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) 02701 $ THEN 02702 IF( ( I.LE.J.AND.J - I.LE.KU ).OR. 02703 $ ( I.GE.J.AND.I - J.LE.KL ) )THEN 02704 A( I, J ) = SBEG( RESET ) + TRANSL 02705 ELSE 02706 A( I, J ) = ZERO 02707 END IF 02708 IF( I.NE.J )THEN 02709 IF( SYM )THEN 02710 A( J, I ) = A( I, J ) 02711 ELSE IF( TRI )THEN 02712 A( J, I ) = ZERO 02713 END IF 02714 END IF 02715 END IF 02716 10 CONTINUE 02717 IF( TRI ) 02718 $ A( J, J ) = A( J, J ) + ONE 02719 IF( UNIT ) 02720 $ A( J, J ) = ONE 02721 20 CONTINUE 02722 * 02723 * Store elements in array AS in data structure required by routine. 02724 * 02725 IF( TYPE.EQ.'GE' )THEN 02726 DO 50 J = 1, N 02727 DO 30 I = 1, M 02728 AA( I + ( J - 1 )*LDA ) = A( I, J ) 02729 30 CONTINUE 02730 DO 40 I = M + 1, LDA 02731 AA( I + ( J - 1 )*LDA ) = ROGUE 02732 40 CONTINUE 02733 50 CONTINUE 02734 ELSE IF( TYPE.EQ.'GB' )THEN 02735 DO 90 J = 1, N 02736 DO 60 I1 = 1, KU + 1 - J 02737 AA( I1 + ( J - 1 )*LDA ) = ROGUE 02738 60 CONTINUE 02739 DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) 02740 AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) 02741 70 CONTINUE 02742 DO 80 I3 = I2, LDA 02743 AA( I3 + ( J - 1 )*LDA ) = ROGUE 02744 80 CONTINUE 02745 90 CONTINUE 02746 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN 02747 DO 130 J = 1, N 02748 IF( UPPER )THEN 02749 IBEG = 1 02750 IF( UNIT )THEN 02751 IEND = J - 1 02752 ELSE 02753 IEND = J 02754 END IF 02755 ELSE 02756 IF( UNIT )THEN 02757 IBEG = J + 1 02758 ELSE 02759 IBEG = J 02760 END IF 02761 IEND = N 02762 END IF 02763 DO 100 I = 1, IBEG - 1 02764 AA( I + ( J - 1 )*LDA ) = ROGUE 02765 100 CONTINUE 02766 DO 110 I = IBEG, IEND 02767 AA( I + ( J - 1 )*LDA ) = A( I, J ) 02768 110 CONTINUE 02769 DO 120 I = IEND + 1, LDA 02770 AA( I + ( J - 1 )*LDA ) = ROGUE 02771 120 CONTINUE 02772 130 CONTINUE 02773 ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN 02774 DO 170 J = 1, N 02775 IF( UPPER )THEN 02776 KK = KL + 1 02777 IBEG = MAX( 1, KL + 2 - J ) 02778 IF( UNIT )THEN 02779 IEND = KL 02780 ELSE 02781 IEND = KL + 1 02782 END IF 02783 ELSE 02784 KK = 1 02785 IF( UNIT )THEN 02786 IBEG = 2 02787 ELSE 02788 IBEG = 1 02789 END IF 02790 IEND = MIN( KL + 1, 1 + M - J ) 02791 END IF 02792 DO 140 I = 1, IBEG - 1 02793 AA( I + ( J - 1 )*LDA ) = ROGUE 02794 140 CONTINUE 02795 DO 150 I = IBEG, IEND 02796 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) 02797 150 CONTINUE 02798 DO 160 I = IEND + 1, LDA 02799 AA( I + ( J - 1 )*LDA ) = ROGUE 02800 160 CONTINUE 02801 170 CONTINUE 02802 ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN 02803 IOFF = 0 02804 DO 190 J = 1, N 02805 IF( UPPER )THEN 02806 IBEG = 1 02807 IEND = J 02808 ELSE 02809 IBEG = J 02810 IEND = N 02811 END IF 02812 DO 180 I = IBEG, IEND 02813 IOFF = IOFF + 1 02814 AA( IOFF ) = A( I, J ) 02815 IF( I.EQ.J )THEN 02816 IF( UNIT ) 02817 $ AA( IOFF ) = ROGUE 02818 END IF 02819 180 CONTINUE 02820 190 CONTINUE 02821 END IF 02822 RETURN 02823 * 02824 * End of SMAKE. 02825 * 02826 END 02827 SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, 02828 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) 02829 * 02830 * Checks the results of the computational tests. 02831 * 02832 * Auxiliary routine for test program for Level 2 Blas. 02833 * 02834 * -- Written on 10-August-1987. 02835 * Richard Hanson, Sandia National Labs. 02836 * Jeremy Du Croz, NAG Central Office. 02837 * 02838 * .. Parameters .. 02839 REAL ZERO, ONE 02840 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 02841 * .. Scalar Arguments .. 02842 REAL ALPHA, BETA, EPS, ERR 02843 INTEGER INCX, INCY, M, N, NMAX, NOUT 02844 LOGICAL FATAL, MV 02845 CHARACTER*1 TRANS 02846 * .. Array Arguments .. 02847 REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), 02848 $ YY( * ) 02849 * .. Local Scalars .. 02850 REAL ERRI 02851 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL 02852 LOGICAL TRAN 02853 * .. Intrinsic Functions .. 02854 INTRINSIC ABS, MAX, SQRT 02855 * .. Executable Statements .. 02856 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 02857 IF( TRAN )THEN 02858 ML = N 02859 NL = M 02860 ELSE 02861 ML = M 02862 NL = N 02863 END IF 02864 IF( INCX.LT.0 )THEN 02865 KX = NL 02866 INCXL = -1 02867 ELSE 02868 KX = 1 02869 INCXL = 1 02870 END IF 02871 IF( INCY.LT.0 )THEN 02872 KY = ML 02873 INCYL = -1 02874 ELSE 02875 KY = 1 02876 INCYL = 1 02877 END IF 02878 * 02879 * Compute expected result in YT using data in A, X and Y. 02880 * Compute gauges in G. 02881 * 02882 IY = KY 02883 DO 30 I = 1, ML 02884 YT( IY ) = ZERO 02885 G( IY ) = ZERO 02886 JX = KX 02887 IF( TRAN )THEN 02888 DO 10 J = 1, NL 02889 YT( IY ) = YT( IY ) + A( J, I )*X( JX ) 02890 G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) 02891 JX = JX + INCXL 02892 10 CONTINUE 02893 ELSE 02894 DO 20 J = 1, NL 02895 YT( IY ) = YT( IY ) + A( I, J )*X( JX ) 02896 G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) 02897 JX = JX + INCXL 02898 20 CONTINUE 02899 END IF 02900 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) 02901 G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) 02902 IY = IY + INCYL 02903 30 CONTINUE 02904 * 02905 * Compute the error ratio for this result. 02906 * 02907 ERR = ZERO 02908 DO 40 I = 1, ML 02909 ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS 02910 IF( G( I ).NE.ZERO ) 02911 $ ERRI = ERRI/G( I ) 02912 ERR = MAX( ERR, ERRI ) 02913 IF( ERR*SQRT( EPS ).GE.ONE ) 02914 $ GO TO 50 02915 40 CONTINUE 02916 * If the loop completes, all results are at least half accurate. 02917 GO TO 70 02918 * 02919 * Report fatal error. 02920 * 02921 50 FATAL = .TRUE. 02922 WRITE( NOUT, FMT = 9999 ) 02923 DO 60 I = 1, ML 02924 IF( MV )THEN 02925 WRITE( NOUT, FMT = 9998 )I, YT( I ), 02926 $ YY( 1 + ( I - 1 )*ABS( INCY ) ) 02927 ELSE 02928 WRITE( NOUT, FMT = 9998 )I, 02929 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) 02930 END IF 02931 60 CONTINUE 02932 * 02933 70 CONTINUE 02934 RETURN 02935 * 02936 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', 02937 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', 02938 $ 'TED RESULT' ) 02939 9998 FORMAT( 1X, I7, 2G18.6 ) 02940 * 02941 * End of SMVCH. 02942 * 02943 END 02944 LOGICAL FUNCTION LSE( RI, RJ, LR ) 02945 * 02946 * Tests if two arrays are identical. 02947 * 02948 * Auxiliary routine for test program for Level 2 Blas. 02949 * 02950 * -- Written on 10-August-1987. 02951 * Richard Hanson, Sandia National Labs. 02952 * Jeremy Du Croz, NAG Central Office. 02953 * 02954 * .. Scalar Arguments .. 02955 INTEGER LR 02956 * .. Array Arguments .. 02957 REAL RI( * ), RJ( * ) 02958 * .. Local Scalars .. 02959 INTEGER I 02960 * .. Executable Statements .. 02961 DO 10 I = 1, LR 02962 IF( RI( I ).NE.RJ( I ) ) 02963 $ GO TO 20 02964 10 CONTINUE 02965 LSE = .TRUE. 02966 GO TO 30 02967 20 CONTINUE 02968 LSE = .FALSE. 02969 30 RETURN 02970 * 02971 * End of LSE. 02972 * 02973 END 02974 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) 02975 * 02976 * Tests if selected elements in two arrays are equal. 02977 * 02978 * TYPE is 'GE', 'SY' or 'SP'. 02979 * 02980 * Auxiliary routine for test program for Level 2 Blas. 02981 * 02982 * -- Written on 10-August-1987. 02983 * Richard Hanson, Sandia National Labs. 02984 * Jeremy Du Croz, NAG Central Office. 02985 * 02986 * .. Scalar Arguments .. 02987 INTEGER LDA, M, N 02988 CHARACTER*1 UPLO 02989 CHARACTER*2 TYPE 02990 * .. Array Arguments .. 02991 REAL AA( LDA, * ), AS( LDA, * ) 02992 * .. Local Scalars .. 02993 INTEGER I, IBEG, IEND, J 02994 LOGICAL UPPER 02995 * .. Executable Statements .. 02996 UPPER = UPLO.EQ.'U' 02997 IF( TYPE.EQ.'GE' )THEN 02998 DO 20 J = 1, N 02999 DO 10 I = M + 1, LDA 03000 IF( AA( I, J ).NE.AS( I, J ) ) 03001 $ GO TO 70 03002 10 CONTINUE 03003 20 CONTINUE 03004 ELSE IF( TYPE.EQ.'SY' )THEN 03005 DO 50 J = 1, N 03006 IF( UPPER )THEN 03007 IBEG = 1 03008 IEND = J 03009 ELSE 03010 IBEG = J 03011 IEND = N 03012 END IF 03013 DO 30 I = 1, IBEG - 1 03014 IF( AA( I, J ).NE.AS( I, J ) ) 03015 $ GO TO 70 03016 30 CONTINUE 03017 DO 40 I = IEND + 1, LDA 03018 IF( AA( I, J ).NE.AS( I, J ) ) 03019 $ GO TO 70 03020 40 CONTINUE 03021 50 CONTINUE 03022 END IF 03023 * 03024 LSERES = .TRUE. 03025 GO TO 80 03026 70 CONTINUE 03027 LSERES = .FALSE. 03028 80 RETURN 03029 * 03030 * End of LSERES. 03031 * 03032 END 03033 REAL FUNCTION SBEG( RESET ) 03034 * 03035 * Generates random numbers uniformly distributed between -0.5 and 0.5. 03036 * 03037 * Auxiliary routine for test program for Level 2 Blas. 03038 * 03039 * -- Written on 10-August-1987. 03040 * Richard Hanson, Sandia National Labs. 03041 * Jeremy Du Croz, NAG Central Office. 03042 * 03043 * .. Scalar Arguments .. 03044 LOGICAL RESET 03045 * .. Local Scalars .. 03046 INTEGER I, IC, MI 03047 * .. Save statement .. 03048 SAVE I, IC, MI 03049 * .. Intrinsic Functions .. 03050 INTRINSIC REAL 03051 * .. Executable Statements .. 03052 IF( RESET )THEN 03053 * Initialize local variables. 03054 MI = 891 03055 I = 7 03056 IC = 0 03057 RESET = .FALSE. 03058 END IF 03059 * 03060 * The sequence of values of I is bounded between 1 and 999. 03061 * If initial I = 1,2,3,6,7 or 9, the period will be 50. 03062 * If initial I = 4 or 8, the period will be 25. 03063 * If initial I = 5, the period will be 10. 03064 * IC is used to break up the period by skipping 1 value of I in 6. 03065 * 03066 IC = IC + 1 03067 10 I = I*MI 03068 I = I - 1000*( I/1000 ) 03069 IF( IC.GE.5 )THEN 03070 IC = 0 03071 GO TO 10 03072 END IF 03073 SBEG = REAL( I - 500 )/1001.0 03074 RETURN 03075 * 03076 * End of SBEG. 03077 * 03078 END 03079 REAL FUNCTION SDIFF( X, Y ) 03080 * 03081 * Auxiliary routine for test program for Level 2 Blas. 03082 * 03083 * -- Written on 10-August-1987. 03084 * Richard Hanson, Sandia National Labs. 03085 * 03086 * .. Scalar Arguments .. 03087 REAL X, Y 03088 * .. Executable Statements .. 03089 SDIFF = X - Y 03090 RETURN 03091 * 03092 * End of SDIFF. 03093 * 03094 END 03095 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 03096 * 03097 * Tests whether XERBLA has detected an error when it should. 03098 * 03099 * Auxiliary routine for test program for Level 2 Blas. 03100 * 03101 * -- Written on 10-August-1987. 03102 * Richard Hanson, Sandia National Labs. 03103 * Jeremy Du Croz, NAG Central Office. 03104 * 03105 * .. Scalar Arguments .. 03106 INTEGER INFOT, NOUT 03107 LOGICAL LERR, OK 03108 CHARACTER*6 SRNAMT 03109 * .. Executable Statements .. 03110 IF( .NOT.LERR )THEN 03111 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT 03112 OK = .FALSE. 03113 END IF 03114 LERR = .FALSE. 03115 RETURN 03116 * 03117 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', 03118 $ 'ETECTED BY ', A6, ' *****' ) 03119 * 03120 * End of CHKXER. 03121 * 03122 END 03123 SUBROUTINE XERBLA( SRNAME, INFO ) 03124 * 03125 * This is a special version of XERBLA to be used only as part of 03126 * the test program for testing error exits from the Level 2 BLAS 03127 * routines. 03128 * 03129 * XERBLA is an error handler for the Level 2 BLAS routines. 03130 * 03131 * It is called by the Level 2 BLAS routines if an input parameter is 03132 * invalid. 03133 * 03134 * Auxiliary routine for test program for Level 2 Blas. 03135 * 03136 * -- Written on 10-August-1987. 03137 * Richard Hanson, Sandia National Labs. 03138 * Jeremy Du Croz, NAG Central Office. 03139 * 03140 * .. Scalar Arguments .. 03141 INTEGER INFO 03142 CHARACTER*6 SRNAME 03143 * .. Scalars in Common .. 03144 INTEGER INFOT, NOUT 03145 LOGICAL LERR, OK 03146 CHARACTER*6 SRNAMT 03147 * .. Common blocks .. 03148 COMMON /INFOC/INFOT, NOUT, OK, LERR 03149 COMMON /SRNAMC/SRNAMT 03150 * .. Executable Statements .. 03151 LERR = .TRUE. 03152 IF( INFO.NE.INFOT )THEN 03153 IF( INFOT.NE.0 )THEN 03154 WRITE( NOUT, FMT = 9999 )INFO, INFOT 03155 ELSE 03156 WRITE( NOUT, FMT = 9997 )INFO 03157 END IF 03158 OK = .FALSE. 03159 END IF 03160 IF( SRNAME.NE.SRNAMT )THEN 03161 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT 03162 OK = .FALSE. 03163 END IF 03164 RETURN 03165 * 03166 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', 03167 $ ' OF ', I2, ' *******' ) 03168 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', 03169 $ 'AD OF ', A6, ' *******' ) 03170 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, 03171 $ ' *******' ) 03172 * 03173 * End of XERBLA 03174 * 03175 END 03176