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