1 PROGRAM SBLAT3 2 * 3 * Test program for the REAL Level 3 Blas. 4 * 5 * The program must be driven by a short data file. The first 14 records 6 * of the file are read using list-directed input, the last 6 records 7 * are read using the format ( A6, L2 ). An annotated example of a data 8 * file can be obtained by deleting the first 3 characters from the 9 * following 20 lines: 10 * 'SBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE 11 * 6 UNIT NUMBER OF SUMMARY FILE 12 * 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE 13 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) 14 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. 15 * F LOGICAL FLAG, T TO STOP ON FAILURES. 16 * T LOGICAL FLAG, T TO TEST ERROR EXITS. 17 * 16.0 THRESHOLD VALUE OF TEST RATIO 18 * 6 NUMBER OF VALUES OF N 19 * 0 1 2 3 5 9 VALUES OF N 20 * 3 NUMBER OF VALUES OF ALPHA 21 * 0.0 1.0 0.7 VALUES OF ALPHA 22 * 3 NUMBER OF VALUES OF BETA 23 * 0.0 1.0 1.3 VALUES OF BETA 24 * SGEMM T PUT F FOR NO TEST. SAME COLUMNS. 25 * SSYMM T PUT F FOR NO TEST. SAME COLUMNS. 26 * STRMM T PUT F FOR NO TEST. SAME COLUMNS. 27 * STRSM T PUT F FOR NO TEST. SAME COLUMNS. 28 * SSYRK T PUT F FOR NO TEST. SAME COLUMNS. 29 * SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. 30 * 31 * See: 32 * 33 * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. 34 * A Set of Level 3 Basic Linear Algebra Subprograms. 35 * 36 * Technical Memorandum No.88 (Revision 1), Mathematics and 37 * Computer Science Division, Argonne National Laboratory, 9700 38 * South Cass Avenue, Argonne, Illinois 60439, US. 39 * 40 * -- Written on 8-February-1989. 41 * Jack Dongarra, Argonne National Laboratory. 42 * Iain Duff, AERE Harwell. 43 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 44 * Sven Hammarling, Numerical Algorithms Group Ltd. 45 * 46 * .. Parameters .. 47 INTEGER NIN 48 PARAMETER ( NIN = 5 ) 49 INTEGER NSUBS 50 PARAMETER ( NSUBS = 6 ) 51 REAL ZERO, HALF, ONE 52 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) 53 INTEGER NMAX 54 PARAMETER ( NMAX = 65 ) 55 INTEGER NIDMAX, NALMAX, NBEMAX 56 PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) 57 * .. Local Scalars .. 58 REAL EPS, ERR, THRESH 59 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA 60 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, 61 $ TSTERR 62 CHARACTER*1 TRANSA, TRANSB 63 CHARACTER*6 SNAMET 64 CHARACTER*32 SNAPS, SUMMRY 65 * .. Local Arrays .. 66 REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), 67 $ ALF( NALMAX ), AS( NMAX*NMAX ), 68 $ BB( NMAX*NMAX ), BET( NBEMAX ), 69 $ BS( NMAX*NMAX ), C( NMAX, NMAX ), 70 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), 71 $ G( NMAX ), W( 2*NMAX ) 72 INTEGER IDIM( NIDMAX ) 73 LOGICAL LTEST( NSUBS ) 74 CHARACTER*6 SNAMES( NSUBS ) 75 * .. External Functions .. 76 REAL SDIFF 77 LOGICAL LSE 78 EXTERNAL SDIFF, LSE 79 * .. External Subroutines .. 80 EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH 81 * .. Intrinsic Functions .. 82 INTRINSIC MAX, MIN 83 * .. Scalars in Common .. 84 INTEGER INFOT, NOUTC 85 LOGICAL LERR, OK 86 CHARACTER*6 SRNAMT 87 * .. Common blocks .. 88 COMMON /INFOC/INFOT, NOUTC, OK, LERR 89 COMMON /SRNAMC/SRNAMT 90 * .. Data statements .. 91 DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', 92 $ 'SSYRK ', 'SSYR2K'/ 93 * .. Executable Statements .. 94 * 95 * Read name and unit number for summary output file and open file. 96 * 97 READ( NIN, FMT = * )SUMMRY 98 READ( NIN, FMT = * )NOUT 99 OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) 100 NOUTC = NOUT 101 * 102 * Read name and unit number for snapshot output file and open file. 103 * 104 READ( NIN, FMT = * )SNAPS 105 READ( NIN, FMT = * )NTRA 106 TRACE = NTRA.GE.0 107 IF( TRACE )THEN 108 OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) 109 END IF 110 * Read the flag that directs rewinding of the snapshot file. 111 READ( NIN, FMT = * )REWI 112 REWI = REWI.AND.TRACE 113 * Read the flag that directs stopping on any failure. 114 READ( NIN, FMT = * )SFATAL 115 * Read the flag that indicates whether error exits are to be tested. 116 READ( NIN, FMT = * )TSTERR 117 * Read the threshold value of the test ratio 118 READ( NIN, FMT = * )THRESH 119 * 120 * Read and check the parameter values for the tests. 121 * 122 * Values of N 123 READ( NIN, FMT = * )NIDIM 124 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN 125 WRITE( NOUT, FMT = 9997 )'N', NIDMAX 126 GO TO 220 127 END IF 128 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) 129 DO 10 I = 1, NIDIM 130 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN 131 WRITE( NOUT, FMT = 9996 )NMAX 132 GO TO 220 133 END IF 134 10 CONTINUE 135 * Values of ALPHA 136 READ( NIN, FMT = * )NALF 137 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN 138 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX 139 GO TO 220 140 END IF 141 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) 142 * Values of BETA 143 READ( NIN, FMT = * )NBET 144 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN 145 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX 146 GO TO 220 147 END IF 148 READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) 149 * 150 * Report values of parameters. 151 * 152 WRITE( NOUT, FMT = 9995 ) 153 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) 154 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) 155 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) 156 IF( .NOT.TSTERR )THEN 157 WRITE( NOUT, FMT = * ) 158 WRITE( NOUT, FMT = 9984 ) 159 END IF 160 WRITE( NOUT, FMT = * ) 161 WRITE( NOUT, FMT = 9999 )THRESH 162 WRITE( NOUT, FMT = * ) 163 * 164 * Read names of subroutines and flags which indicate 165 * whether they are to be tested. 166 * 167 DO 20 I = 1, NSUBS 168 LTEST( I ) = .FALSE. 169 20 CONTINUE 170 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT 171 DO 40 I = 1, NSUBS 172 IF( SNAMET.EQ.SNAMES( I ) ) 173 $ GO TO 50 174 40 CONTINUE 175 WRITE( NOUT, FMT = 9990 )SNAMET 176 STOP 177 50 LTEST( I ) = LTESTT 178 GO TO 30 179 * 180 60 CONTINUE 181 CLOSE ( NIN ) 182 * 183 * Compute EPS (the machine precision). 184 * 185 EPS = ONE 186 70 CONTINUE 187 IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO ) 188 $ GO TO 80 189 EPS = HALF*EPS 190 GO TO 70 191 80 CONTINUE 192 EPS = EPS + EPS 193 WRITE( NOUT, FMT = 9998 )EPS 194 * 195 * Check the reliability of SMMCH using exact data. 196 * 197 N = MIN( 32, NMAX ) 198 DO 100 J = 1, N 199 DO 90 I = 1, N 200 AB( I, J ) = MAX( I - J + 1, 0 ) 201 90 CONTINUE 202 AB( J, NMAX + 1 ) = J 203 AB( 1, NMAX + J ) = J 204 C( J, 1 ) = ZERO 205 100 CONTINUE 206 DO 110 J = 1, N 207 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 208 110 CONTINUE 209 * CC holds the exact result. On exit from SMMCH CT holds 210 * the result computed by SMMCH. 211 TRANSA = 'N' 212 TRANSB = 'N' 213 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 214 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 215 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) 216 SAME = LSE( CC, CT, N ) 217 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 218 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 219 STOP 220 END IF 221 TRANSB = 'T' 222 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 223 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 224 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) 225 SAME = LSE( CC, CT, N ) 226 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 227 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 228 STOP 229 END IF 230 DO 120 J = 1, N 231 AB( J, NMAX + 1 ) = N - J + 1 232 AB( 1, NMAX + J ) = N - J + 1 233 120 CONTINUE 234 DO 130 J = 1, N 235 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - 236 $ ( ( J + 1 )*J*( J - 1 ) )/3 237 130 CONTINUE 238 TRANSA = 'T' 239 TRANSB = 'N' 240 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 241 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 242 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) 243 SAME = LSE( CC, CT, N ) 244 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 245 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 246 STOP 247 END IF 248 TRANSB = 'T' 249 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 250 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 251 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) 252 SAME = LSE( CC, CT, N ) 253 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 254 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 255 STOP 256 END IF 257 * 258 * Test each subroutine in turn. 259 * 260 DO 200 ISNUM = 1, NSUBS 261 WRITE( NOUT, FMT = * ) 262 IF( .NOT.LTEST( ISNUM ) )THEN 263 * Subprogram is not to be tested. 264 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) 265 ELSE 266 SRNAMT = SNAMES( ISNUM ) 267 * Test error exits. 268 IF( TSTERR )THEN 269 CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) 270 WRITE( NOUT, FMT = * ) 271 END IF 272 * Test computations. 273 INFOT = 0 274 OK = .TRUE. 275 FATAL = .FALSE. 276 GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM 277 * Test SGEMM, 01. 278 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 279 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, 280 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, 281 $ CC, CS, CT, G ) 282 GO TO 190 283 * Test SSYMM, 02. 284 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 285 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, 286 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, 287 $ CC, CS, CT, G ) 288 GO TO 190 289 * Test STRMM, 03, STRSM, 04. 290 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 291 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, 292 $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) 293 GO TO 190 294 * Test SSYRK, 05. 295 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 296 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, 297 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, 298 $ CC, CS, CT, G ) 299 GO TO 190 300 * Test SSYR2K, 06. 301 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 302 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, 303 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) 304 GO TO 190 305 * 306 190 IF( FATAL.AND.SFATAL ) 307 $ GO TO 210 308 END IF 309 200 CONTINUE 310 WRITE( NOUT, FMT = 9986 ) 311 GO TO 230 312 * 313 210 CONTINUE 314 WRITE( NOUT, FMT = 9985 ) 315 GO TO 230 316 * 317 220 CONTINUE 318 WRITE( NOUT, FMT = 9991 ) 319 * 320 230 CONTINUE 321 IF( TRACE ) 322 $ CLOSE ( NTRA ) 323 CLOSE ( NOUT ) 324 STOP 325 * 326 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', 327 $ 'S THAN', F8.2 ) 328 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 329 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', 330 $ 'THAN ', I2 ) 331 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 332 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', 333 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 334 9994 FORMAT( ' FOR N ', 9I6 ) 335 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) 336 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 337 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', 338 $ /' ******* TESTS ABANDONED *******' ) 339 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', 340 $ 'ESTS ABANDONED *******' ) 341 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', 342 $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, 343 $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', 344 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', 345 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', 346 $ '*******' ) 347 9988 FORMAT( A6, L2 ) 348 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 349 9986 FORMAT( /' END OF TESTS' ) 350 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 351 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 352 * 353 * End of SBLAT3. 354 * 355 END 356 SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 357 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 358 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) 359 * 360 * Tests SGEMM. 361 * 362 * Auxiliary routine for test program for Level 3 Blas. 363 * 364 * -- Written on 8-February-1989. 365 * Jack Dongarra, Argonne National Laboratory. 366 * Iain Duff, AERE Harwell. 367 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 368 * Sven Hammarling, Numerical Algorithms Group Ltd. 369 * 370 * .. Parameters .. 371 REAL ZERO 372 PARAMETER ( ZERO = 0.0 ) 373 * .. Scalar Arguments .. 374 REAL EPS, THRESH 375 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA 376 LOGICAL FATAL, REWI, TRACE 377 CHARACTER*6 SNAME 378 * .. Array Arguments .. 379 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 380 $ AS( NMAX*NMAX ), B( NMAX, NMAX ), 381 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), 382 $ C( NMAX, NMAX ), CC( NMAX*NMAX ), 383 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) 384 INTEGER IDIM( NIDIM ) 385 * .. Local Scalars .. 386 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX 387 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, 388 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, 389 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS 390 LOGICAL NULL, RESET, SAME, TRANA, TRANB 391 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB 392 CHARACTER*3 ICH 393 * .. Local Arrays .. 394 LOGICAL ISAME( 13 ) 395 * .. External Functions .. 396 LOGICAL LSE, LSERES 397 EXTERNAL LSE, LSERES 398 * .. External Subroutines .. 399 EXTERNAL SGEMM, SMAKE, SMMCH 400 * .. Intrinsic Functions .. 401 INTRINSIC MAX 402 * .. Scalars in Common .. 403 INTEGER INFOT, NOUTC 404 LOGICAL LERR, OK 405 * .. Common blocks .. 406 COMMON /INFOC/INFOT, NOUTC, OK, LERR 407 * .. Data statements .. 408 DATA ICH/'NTC'/ 409 * .. Executable Statements .. 410 * 411 NARGS = 13 412 NC = 0 413 RESET = .TRUE. 414 ERRMAX = ZERO 415 * 416 DO 110 IM = 1, NIDIM 417 M = IDIM( IM ) 418 * 419 DO 100 IN = 1, NIDIM 420 N = IDIM( IN ) 421 * Set LDC to 1 more than minimum value if room. 422 LDC = M 423 IF( LDC.LT.NMAX ) 424 $ LDC = LDC + 1 425 * Skip tests if not enough room. 426 IF( LDC.GT.NMAX ) 427 $ GO TO 100 428 LCC = LDC*N 429 NULL = N.LE.0.OR.M.LE.0 430 * 431 DO 90 IK = 1, NIDIM 432 K = IDIM( IK ) 433 * 434 DO 80 ICA = 1, 3 435 TRANSA = ICH( ICA: ICA ) 436 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' 437 * 438 IF( TRANA )THEN 439 MA = K 440 NA = M 441 ELSE 442 MA = M 443 NA = K 444 END IF 445 * Set LDA to 1 more than minimum value if room. 446 LDA = MA 447 IF( LDA.LT.NMAX ) 448 $ LDA = LDA + 1 449 * Skip tests if not enough room. 450 IF( LDA.GT.NMAX ) 451 $ GO TO 80 452 LAA = LDA*NA 453 * 454 * Generate the matrix A. 455 * 456 CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, 457 $ RESET, ZERO ) 458 * 459 DO 70 ICB = 1, 3 460 TRANSB = ICH( ICB: ICB ) 461 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' 462 * 463 IF( TRANB )THEN 464 MB = N 465 NB = K 466 ELSE 467 MB = K 468 NB = N 469 END IF 470 * Set LDB to 1 more than minimum value if room. 471 LDB = MB 472 IF( LDB.LT.NMAX ) 473 $ LDB = LDB + 1 474 * Skip tests if not enough room. 475 IF( LDB.GT.NMAX ) 476 $ GO TO 70 477 LBB = LDB*NB 478 * 479 * Generate the matrix B. 480 * 481 CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, 482 $ LDB, RESET, ZERO ) 483 * 484 DO 60 IA = 1, NALF 485 ALPHA = ALF( IA ) 486 * 487 DO 50 IB = 1, NBET 488 BETA = BET( IB ) 489 * 490 * Generate the matrix C. 491 * 492 CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, 493 $ CC, LDC, RESET, ZERO ) 494 * 495 NC = NC + 1 496 * 497 * Save every datum before calling the 498 * subroutine. 499 * 500 TRANAS = TRANSA 501 TRANBS = TRANSB 502 MS = M 503 NS = N 504 KS = K 505 ALS = ALPHA 506 DO 10 I = 1, LAA 507 AS( I ) = AA( I ) 508 10 CONTINUE 509 LDAS = LDA 510 DO 20 I = 1, LBB 511 BS( I ) = BB( I ) 512 20 CONTINUE 513 LDBS = LDB 514 BLS = BETA 515 DO 30 I = 1, LCC 516 CS( I ) = CC( I ) 517 30 CONTINUE 518 LDCS = LDC 519 * 520 * Call the subroutine. 521 * 522 IF( TRACE ) 523 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 524 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, 525 $ BETA, LDC 526 IF( REWI ) 527 $ REWIND NTRA 528 CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA, 529 $ AA, LDA, BB, LDB, BETA, CC, LDC ) 530 * 531 * Check if error-exit was taken incorrectly. 532 * 533 IF( .NOT.OK )THEN 534 WRITE( NOUT, FMT = 9994 ) 535 FATAL = .TRUE. 536 GO TO 120 537 END IF 538 * 539 * See what data changed inside subroutines. 540 * 541 ISAME( 1 ) = TRANSA.EQ.TRANAS 542 ISAME( 2 ) = TRANSB.EQ.TRANBS 543 ISAME( 3 ) = MS.EQ.M 544 ISAME( 4 ) = NS.EQ.N 545 ISAME( 5 ) = KS.EQ.K 546 ISAME( 6 ) = ALS.EQ.ALPHA 547 ISAME( 7 ) = LSE( AS, AA, LAA ) 548 ISAME( 8 ) = LDAS.EQ.LDA 549 ISAME( 9 ) = LSE( BS, BB, LBB ) 550 ISAME( 10 ) = LDBS.EQ.LDB 551 ISAME( 11 ) = BLS.EQ.BETA 552 IF( NULL )THEN 553 ISAME( 12 ) = LSE( CS, CC, LCC ) 554 ELSE 555 ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS, 556 $ CC, LDC ) 557 END IF 558 ISAME( 13 ) = LDCS.EQ.LDC 559 * 560 * If data was incorrectly changed, report 561 * and return. 562 * 563 SAME = .TRUE. 564 DO 40 I = 1, NARGS 565 SAME = SAME.AND.ISAME( I ) 566 IF( .NOT.ISAME( I ) ) 567 $ WRITE( NOUT, FMT = 9998 )I 568 40 CONTINUE 569 IF( .NOT.SAME )THEN 570 FATAL = .TRUE. 571 GO TO 120 572 END IF 573 * 574 IF( .NOT.NULL )THEN 575 * 576 * Check the result. 577 * 578 CALL SMMCH( TRANSA, TRANSB, M, N, K, 579 $ ALPHA, A, NMAX, B, NMAX, BETA, 580 $ C, NMAX, CT, G, CC, LDC, EPS, 581 $ ERR, FATAL, NOUT, .TRUE. ) 582 ERRMAX = MAX( ERRMAX, ERR ) 583 * If got really bad answer, report and 584 * return. 585 IF( FATAL ) 586 $ GO TO 120 587 END IF 588 * 589 50 CONTINUE 590 * 591 60 CONTINUE 592 * 593 70 CONTINUE 594 * 595 80 CONTINUE 596 * 597 90 CONTINUE 598 * 599 100 CONTINUE 600 * 601 110 CONTINUE 602 * 603 * Report result. 604 * 605 IF( ERRMAX.LT.THRESH )THEN 606 WRITE( NOUT, FMT = 9999 )SNAME, NC 607 ELSE 608 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 609 END IF 610 GO TO 130 611 * 612 120 CONTINUE 613 WRITE( NOUT, FMT = 9996 )SNAME 614 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, 615 $ ALPHA, LDA, LDB, BETA, LDC 616 * 617 130 CONTINUE 618 RETURN 619 * 620 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 621 $ 'S)' ) 622 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 623 $ 'ANGED INCORRECTLY *******' ) 624 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 625 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 626 $ ' - SUSPECT *******' ) 627 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 628 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', 629 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', 630 $ 'C,', I3, ').' ) 631 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 632 $ '******' ) 633 * 634 * End of SCHK1. 635 * 636 END 637 SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 638 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 639 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) 640 * 641 * Tests SSYMM. 642 * 643 * Auxiliary routine for test program for Level 3 Blas. 644 * 645 * -- Written on 8-February-1989. 646 * Jack Dongarra, Argonne National Laboratory. 647 * Iain Duff, AERE Harwell. 648 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 649 * Sven Hammarling, Numerical Algorithms Group Ltd. 650 * 651 * .. Parameters .. 652 REAL ZERO 653 PARAMETER ( ZERO = 0.0 ) 654 * .. Scalar Arguments .. 655 REAL EPS, THRESH 656 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA 657 LOGICAL FATAL, REWI, TRACE 658 CHARACTER*6 SNAME 659 * .. Array Arguments .. 660 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 661 $ AS( NMAX*NMAX ), B( NMAX, NMAX ), 662 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), 663 $ C( NMAX, NMAX ), CC( NMAX*NMAX ), 664 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) 665 INTEGER IDIM( NIDIM ) 666 * .. Local Scalars .. 667 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX 668 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, 669 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, 670 $ NARGS, NC, NS 671 LOGICAL LEFT, NULL, RESET, SAME 672 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS 673 CHARACTER*2 ICHS, ICHU 674 * .. Local Arrays .. 675 LOGICAL ISAME( 13 ) 676 * .. External Functions .. 677 LOGICAL LSE, LSERES 678 EXTERNAL LSE, LSERES 679 * .. External Subroutines .. 680 EXTERNAL SMAKE, SMMCH, SSYMM 681 * .. Intrinsic Functions .. 682 INTRINSIC MAX 683 * .. Scalars in Common .. 684 INTEGER INFOT, NOUTC 685 LOGICAL LERR, OK 686 * .. Common blocks .. 687 COMMON /INFOC/INFOT, NOUTC, OK, LERR 688 * .. Data statements .. 689 DATA ICHS/'LR'/, ICHU/'UL'/ 690 * .. Executable Statements .. 691 * 692 NARGS = 12 693 NC = 0 694 RESET = .TRUE. 695 ERRMAX = ZERO 696 * 697 DO 100 IM = 1, NIDIM 698 M = IDIM( IM ) 699 * 700 DO 90 IN = 1, NIDIM 701 N = IDIM( IN ) 702 * Set LDC to 1 more than minimum value if room. 703 LDC = M 704 IF( LDC.LT.NMAX ) 705 $ LDC = LDC + 1 706 * Skip tests if not enough room. 707 IF( LDC.GT.NMAX ) 708 $ GO TO 90 709 LCC = LDC*N 710 NULL = N.LE.0.OR.M.LE.0 711 * 712 * Set LDB to 1 more than minimum value if room. 713 LDB = M 714 IF( LDB.LT.NMAX ) 715 $ LDB = LDB + 1 716 * Skip tests if not enough room. 717 IF( LDB.GT.NMAX ) 718 $ GO TO 90 719 LBB = LDB*N 720 * 721 * Generate the matrix B. 722 * 723 CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, 724 $ ZERO ) 725 * 726 DO 80 ICS = 1, 2 727 SIDE = ICHS( ICS: ICS ) 728 LEFT = SIDE.EQ.'L' 729 * 730 IF( LEFT )THEN 731 NA = M 732 ELSE 733 NA = N 734 END IF 735 * Set LDA to 1 more than minimum value if room. 736 LDA = NA 737 IF( LDA.LT.NMAX ) 738 $ LDA = LDA + 1 739 * Skip tests if not enough room. 740 IF( LDA.GT.NMAX ) 741 $ GO TO 80 742 LAA = LDA*NA 743 * 744 DO 70 ICU = 1, 2 745 UPLO = ICHU( ICU: ICU ) 746 * 747 * Generate the symmetric matrix A. 748 * 749 CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, 750 $ RESET, ZERO ) 751 * 752 DO 60 IA = 1, NALF 753 ALPHA = ALF( IA ) 754 * 755 DO 50 IB = 1, NBET 756 BETA = BET( IB ) 757 * 758 * Generate the matrix C. 759 * 760 CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, 761 $ LDC, RESET, ZERO ) 762 * 763 NC = NC + 1 764 * 765 * Save every datum before calling the 766 * subroutine. 767 * 768 SIDES = SIDE 769 UPLOS = UPLO 770 MS = M 771 NS = N 772 ALS = ALPHA 773 DO 10 I = 1, LAA 774 AS( I ) = AA( I ) 775 10 CONTINUE 776 LDAS = LDA 777 DO 20 I = 1, LBB 778 BS( I ) = BB( I ) 779 20 CONTINUE 780 LDBS = LDB 781 BLS = BETA 782 DO 30 I = 1, LCC 783 CS( I ) = CC( I ) 784 30 CONTINUE 785 LDCS = LDC 786 * 787 * Call the subroutine. 788 * 789 IF( TRACE ) 790 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, 791 $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC 792 IF( REWI ) 793 $ REWIND NTRA 794 CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, 795 $ BB, LDB, BETA, CC, LDC ) 796 * 797 * Check if error-exit was taken incorrectly. 798 * 799 IF( .NOT.OK )THEN 800 WRITE( NOUT, FMT = 9994 ) 801 FATAL = .TRUE. 802 GO TO 110 803 END IF 804 * 805 * See what data changed inside subroutines. 806 * 807 ISAME( 1 ) = SIDES.EQ.SIDE 808 ISAME( 2 ) = UPLOS.EQ.UPLO 809 ISAME( 3 ) = MS.EQ.M 810 ISAME( 4 ) = NS.EQ.N 811 ISAME( 5 ) = ALS.EQ.ALPHA 812 ISAME( 6 ) = LSE( AS, AA, LAA ) 813 ISAME( 7 ) = LDAS.EQ.LDA 814 ISAME( 8 ) = LSE( BS, BB, LBB ) 815 ISAME( 9 ) = LDBS.EQ.LDB 816 ISAME( 10 ) = BLS.EQ.BETA 817 IF( NULL )THEN 818 ISAME( 11 ) = LSE( CS, CC, LCC ) 819 ELSE 820 ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS, 821 $ CC, LDC ) 822 END IF 823 ISAME( 12 ) = LDCS.EQ.LDC 824 * 825 * If data was incorrectly changed, report and 826 * return. 827 * 828 SAME = .TRUE. 829 DO 40 I = 1, NARGS 830 SAME = SAME.AND.ISAME( I ) 831 IF( .NOT.ISAME( I ) ) 832 $ WRITE( NOUT, FMT = 9998 )I 833 40 CONTINUE 834 IF( .NOT.SAME )THEN 835 FATAL = .TRUE. 836 GO TO 110 837 END IF 838 * 839 IF( .NOT.NULL )THEN 840 * 841 * Check the result. 842 * 843 IF( LEFT )THEN 844 CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A, 845 $ NMAX, B, NMAX, BETA, C, NMAX, 846 $ CT, G, CC, LDC, EPS, ERR, 847 $ FATAL, NOUT, .TRUE. ) 848 ELSE 849 CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B, 850 $ NMAX, A, NMAX, BETA, C, NMAX, 851 $ CT, G, CC, LDC, EPS, ERR, 852 $ FATAL, NOUT, .TRUE. ) 853 END IF 854 ERRMAX = MAX( ERRMAX, ERR ) 855 * If got really bad answer, report and 856 * return. 857 IF( FATAL ) 858 $ GO TO 110 859 END IF 860 * 861 50 CONTINUE 862 * 863 60 CONTINUE 864 * 865 70 CONTINUE 866 * 867 80 CONTINUE 868 * 869 90 CONTINUE 870 * 871 100 CONTINUE 872 * 873 * Report result. 874 * 875 IF( ERRMAX.LT.THRESH )THEN 876 WRITE( NOUT, FMT = 9999 )SNAME, NC 877 ELSE 878 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 879 END IF 880 GO TO 120 881 * 882 110 CONTINUE 883 WRITE( NOUT, FMT = 9996 )SNAME 884 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, 885 $ LDB, BETA, LDC 886 * 887 120 CONTINUE 888 RETURN 889 * 890 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 891 $ 'S)' ) 892 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 893 $ 'ANGED INCORRECTLY *******' ) 894 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 895 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 896 $ ' - SUSPECT *******' ) 897 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 898 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), 899 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', 900 $ ' .' ) 901 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 902 $ '******' ) 903 * 904 * End of SCHK2. 905 * 906 END 907 SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 908 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, 909 $ B, BB, BS, CT, G, C ) 910 * 911 * Tests STRMM and STRSM. 912 * 913 * Auxiliary routine for test program for Level 3 Blas. 914 * 915 * -- Written on 8-February-1989. 916 * Jack Dongarra, Argonne National Laboratory. 917 * Iain Duff, AERE Harwell. 918 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 919 * Sven Hammarling, Numerical Algorithms Group Ltd. 920 * 921 * .. Parameters .. 922 REAL ZERO, ONE 923 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 924 * .. Scalar Arguments .. 925 REAL EPS, THRESH 926 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA 927 LOGICAL FATAL, REWI, TRACE 928 CHARACTER*6 SNAME 929 * .. Array Arguments .. 930 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 931 $ AS( NMAX*NMAX ), B( NMAX, NMAX ), 932 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), 933 $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) 934 INTEGER IDIM( NIDIM ) 935 * .. Local Scalars .. 936 REAL ALPHA, ALS, ERR, ERRMAX 937 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, 938 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, 939 $ NS 940 LOGICAL LEFT, NULL, RESET, SAME 941 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, 942 $ UPLOS 943 CHARACTER*2 ICHD, ICHS, ICHU 944 CHARACTER*3 ICHT 945 * .. Local Arrays .. 946 LOGICAL ISAME( 13 ) 947 * .. External Functions .. 948 LOGICAL LSE, LSERES 949 EXTERNAL LSE, LSERES 950 * .. External Subroutines .. 951 EXTERNAL SMAKE, SMMCH, STRMM, STRSM 952 * .. Intrinsic Functions .. 953 INTRINSIC MAX 954 * .. Scalars in Common .. 955 INTEGER INFOT, NOUTC 956 LOGICAL LERR, OK 957 * .. Common blocks .. 958 COMMON /INFOC/INFOT, NOUTC, OK, LERR 959 * .. Data statements .. 960 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ 961 * .. Executable Statements .. 962 * 963 NARGS = 11 964 NC = 0 965 RESET = .TRUE. 966 ERRMAX = ZERO 967 * Set up zero matrix for SMMCH. 968 DO 20 J = 1, NMAX 969 DO 10 I = 1, NMAX 970 C( I, J ) = ZERO 971 10 CONTINUE 972 20 CONTINUE 973 * 974 DO 140 IM = 1, NIDIM 975 M = IDIM( IM ) 976 * 977 DO 130 IN = 1, NIDIM 978 N = IDIM( IN ) 979 * Set LDB to 1 more than minimum value if room. 980 LDB = M 981 IF( LDB.LT.NMAX ) 982 $ LDB = LDB + 1 983 * Skip tests if not enough room. 984 IF( LDB.GT.NMAX ) 985 $ GO TO 130 986 LBB = LDB*N 987 NULL = M.LE.0.OR.N.LE.0 988 * 989 DO 120 ICS = 1, 2 990 SIDE = ICHS( ICS: ICS ) 991 LEFT = SIDE.EQ.'L' 992 IF( LEFT )THEN 993 NA = M 994 ELSE 995 NA = N 996 END IF 997 * Set LDA to 1 more than minimum value if room. 998 LDA = NA 999 IF( LDA.LT.NMAX ) 1000 $ LDA = LDA + 1 1001 * Skip tests if not enough room. 1002 IF( LDA.GT.NMAX ) 1003 $ GO TO 130 1004 LAA = LDA*NA 1005 * 1006 DO 110 ICU = 1, 2 1007 UPLO = ICHU( ICU: ICU ) 1008 * 1009 DO 100 ICT = 1, 3 1010 TRANSA = ICHT( ICT: ICT ) 1011 * 1012 DO 90 ICD = 1, 2 1013 DIAG = ICHD( ICD: ICD ) 1014 * 1015 DO 80 IA = 1, NALF 1016 ALPHA = ALF( IA ) 1017 * 1018 * Generate the matrix A. 1019 * 1020 CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A, 1021 $ NMAX, AA, LDA, RESET, ZERO ) 1022 * 1023 * Generate the matrix B. 1024 * 1025 CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, 1026 $ BB, LDB, RESET, ZERO ) 1027 * 1028 NC = NC + 1 1029 * 1030 * Save every datum before calling the 1031 * subroutine. 1032 * 1033 SIDES = SIDE 1034 UPLOS = UPLO 1035 TRANAS = TRANSA 1036 DIAGS = DIAG 1037 MS = M 1038 NS = N 1039 ALS = ALPHA 1040 DO 30 I = 1, LAA 1041 AS( I ) = AA( I ) 1042 30 CONTINUE 1043 LDAS = LDA 1044 DO 40 I = 1, LBB 1045 BS( I ) = BB( I ) 1046 40 CONTINUE 1047 LDBS = LDB 1048 * 1049 * Call the subroutine. 1050 * 1051 IF( SNAME( 4: 5 ).EQ.'MM' )THEN 1052 IF( TRACE ) 1053 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 1054 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, 1055 $ LDA, LDB 1056 IF( REWI ) 1057 $ REWIND NTRA 1058 CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M, 1059 $ N, ALPHA, AA, LDA, BB, LDB ) 1060 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN 1061 IF( TRACE ) 1062 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 1063 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, 1064 $ LDA, LDB 1065 IF( REWI ) 1066 $ REWIND NTRA 1067 CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M, 1068 $ N, ALPHA, AA, LDA, BB, LDB ) 1069 END IF 1070 * 1071 * Check if error-exit was taken incorrectly. 1072 * 1073 IF( .NOT.OK )THEN 1074 WRITE( NOUT, FMT = 9994 ) 1075 FATAL = .TRUE. 1076 GO TO 150 1077 END IF 1078 * 1079 * See what data changed inside subroutines. 1080 * 1081 ISAME( 1 ) = SIDES.EQ.SIDE 1082 ISAME( 2 ) = UPLOS.EQ.UPLO 1083 ISAME( 3 ) = TRANAS.EQ.TRANSA 1084 ISAME( 4 ) = DIAGS.EQ.DIAG 1085 ISAME( 5 ) = MS.EQ.M 1086 ISAME( 6 ) = NS.EQ.N 1087 ISAME( 7 ) = ALS.EQ.ALPHA 1088 ISAME( 8 ) = LSE( AS, AA, LAA ) 1089 ISAME( 9 ) = LDAS.EQ.LDA 1090 IF( NULL )THEN 1091 ISAME( 10 ) = LSE( BS, BB, LBB ) 1092 ELSE 1093 ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS, 1094 $ BB, LDB ) 1095 END IF 1096 ISAME( 11 ) = LDBS.EQ.LDB 1097 * 1098 * If data was incorrectly changed, report and 1099 * return. 1100 * 1101 SAME = .TRUE. 1102 DO 50 I = 1, NARGS 1103 SAME = SAME.AND.ISAME( I ) 1104 IF( .NOT.ISAME( I ) ) 1105 $ WRITE( NOUT, FMT = 9998 )I 1106 50 CONTINUE 1107 IF( .NOT.SAME )THEN 1108 FATAL = .TRUE. 1109 GO TO 150 1110 END IF 1111 * 1112 IF( .NOT.NULL )THEN 1113 IF( SNAME( 4: 5 ).EQ.'MM' )THEN 1114 * 1115 * Check the result. 1116 * 1117 IF( LEFT )THEN 1118 CALL SMMCH( TRANSA, 'N', M, N, M, 1119 $ ALPHA, A, NMAX, B, NMAX, 1120 $ ZERO, C, NMAX, CT, G, 1121 $ BB, LDB, EPS, ERR, 1122 $ FATAL, NOUT, .TRUE. ) 1123 ELSE 1124 CALL SMMCH( 'N', TRANSA, M, N, N, 1125 $ ALPHA, B, NMAX, A, NMAX, 1126 $ ZERO, C, NMAX, CT, G, 1127 $ BB, LDB, EPS, ERR, 1128 $ FATAL, NOUT, .TRUE. ) 1129 END IF 1130 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN 1131 * 1132 * Compute approximation to original 1133 * matrix. 1134 * 1135 DO 70 J = 1, N 1136 DO 60 I = 1, M 1137 C( I, J ) = BB( I + ( J - 1 )* 1138 $ LDB ) 1139 BB( I + ( J - 1 )*LDB ) = ALPHA* 1140 $ B( I, J ) 1141 60 CONTINUE 1142 70 CONTINUE 1143 * 1144 IF( LEFT )THEN 1145 CALL SMMCH( TRANSA, 'N', M, N, M, 1146 $ ONE, A, NMAX, C, NMAX, 1147 $ ZERO, B, NMAX, CT, G, 1148 $ BB, LDB, EPS, ERR, 1149 $ FATAL, NOUT, .FALSE. ) 1150 ELSE 1151 CALL SMMCH( 'N', TRANSA, M, N, N, 1152 $ ONE, C, NMAX, A, NMAX, 1153 $ ZERO, B, NMAX, CT, G, 1154 $ BB, LDB, EPS, ERR, 1155 $ FATAL, NOUT, .FALSE. ) 1156 END IF 1157 END IF 1158 ERRMAX = MAX( ERRMAX, ERR ) 1159 * If got really bad answer, report and 1160 * return. 1161 IF( FATAL ) 1162 $ GO TO 150 1163 END IF 1164 * 1165 80 CONTINUE 1166 * 1167 90 CONTINUE 1168 * 1169 100 CONTINUE 1170 * 1171 110 CONTINUE 1172 * 1173 120 CONTINUE 1174 * 1175 130 CONTINUE 1176 * 1177 140 CONTINUE 1178 * 1179 * Report result. 1180 * 1181 IF( ERRMAX.LT.THRESH )THEN 1182 WRITE( NOUT, FMT = 9999 )SNAME, NC 1183 ELSE 1184 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1185 END IF 1186 GO TO 160 1187 * 1188 150 CONTINUE 1189 WRITE( NOUT, FMT = 9996 )SNAME 1190 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, 1191 $ N, ALPHA, LDA, LDB 1192 * 1193 160 CONTINUE 1194 RETURN 1195 * 1196 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1197 $ 'S)' ) 1198 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1199 $ 'ANGED INCORRECTLY *******' ) 1200 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1201 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1202 $ ' - SUSPECT *******' ) 1203 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1204 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), 1205 $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 1206 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1207 $ '******' ) 1208 * 1209 * End of SCHK3. 1210 * 1211 END 1212 SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1213 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 1214 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) 1215 * 1216 * Tests SSYRK. 1217 * 1218 * Auxiliary routine for test program for Level 3 Blas. 1219 * 1220 * -- Written on 8-February-1989. 1221 * Jack Dongarra, Argonne National Laboratory. 1222 * Iain Duff, AERE Harwell. 1223 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 1224 * Sven Hammarling, Numerical Algorithms Group Ltd. 1225 * 1226 * .. Parameters .. 1227 REAL ZERO 1228 PARAMETER ( ZERO = 0.0 ) 1229 * .. Scalar Arguments .. 1230 REAL EPS, THRESH 1231 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA 1232 LOGICAL FATAL, REWI, TRACE 1233 CHARACTER*6 SNAME 1234 * .. Array Arguments .. 1235 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 1236 $ AS( NMAX*NMAX ), B( NMAX, NMAX ), 1237 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), 1238 $ C( NMAX, NMAX ), CC( NMAX*NMAX ), 1239 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) 1240 INTEGER IDIM( NIDIM ) 1241 * .. Local Scalars .. 1242 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX 1243 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, 1244 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, 1245 $ NARGS, NC, NS 1246 LOGICAL NULL, RESET, SAME, TRAN, UPPER 1247 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS 1248 CHARACTER*2 ICHU 1249 CHARACTER*3 ICHT 1250 * .. Local Arrays .. 1251 LOGICAL ISAME( 13 ) 1252 * .. External Functions .. 1253 LOGICAL LSE, LSERES 1254 EXTERNAL LSE, LSERES 1255 * .. External Subroutines .. 1256 EXTERNAL SMAKE, SMMCH, SSYRK 1257 * .. Intrinsic Functions .. 1258 INTRINSIC MAX 1259 * .. Scalars in Common .. 1260 INTEGER INFOT, NOUTC 1261 LOGICAL LERR, OK 1262 * .. Common blocks .. 1263 COMMON /INFOC/INFOT, NOUTC, OK, LERR 1264 * .. Data statements .. 1265 DATA ICHT/'NTC'/, ICHU/'UL'/ 1266 * .. Executable Statements .. 1267 * 1268 NARGS = 10 1269 NC = 0 1270 RESET = .TRUE. 1271 ERRMAX = ZERO 1272 * 1273 DO 100 IN = 1, NIDIM 1274 N = IDIM( IN ) 1275 * Set LDC to 1 more than minimum value if room. 1276 LDC = N 1277 IF( LDC.LT.NMAX ) 1278 $ LDC = LDC + 1 1279 * Skip tests if not enough room. 1280 IF( LDC.GT.NMAX ) 1281 $ GO TO 100 1282 LCC = LDC*N 1283 NULL = N.LE.0 1284 * 1285 DO 90 IK = 1, NIDIM 1286 K = IDIM( IK ) 1287 * 1288 DO 80 ICT = 1, 3 1289 TRANS = ICHT( ICT: ICT ) 1290 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 1291 IF( TRAN )THEN 1292 MA = K 1293 NA = N 1294 ELSE 1295 MA = N 1296 NA = K 1297 END IF 1298 * Set LDA to 1 more than minimum value if room. 1299 LDA = MA 1300 IF( LDA.LT.NMAX ) 1301 $ LDA = LDA + 1 1302 * Skip tests if not enough room. 1303 IF( LDA.GT.NMAX ) 1304 $ GO TO 80 1305 LAA = LDA*NA 1306 * 1307 * Generate the matrix A. 1308 * 1309 CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, 1310 $ RESET, ZERO ) 1311 * 1312 DO 70 ICU = 1, 2 1313 UPLO = ICHU( ICU: ICU ) 1314 UPPER = UPLO.EQ.'U' 1315 * 1316 DO 60 IA = 1, NALF 1317 ALPHA = ALF( IA ) 1318 * 1319 DO 50 IB = 1, NBET 1320 BETA = BET( IB ) 1321 * 1322 * Generate the matrix C. 1323 * 1324 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, 1325 $ LDC, RESET, ZERO ) 1326 * 1327 NC = NC + 1 1328 * 1329 * Save every datum before calling the subroutine. 1330 * 1331 UPLOS = UPLO 1332 TRANSS = TRANS 1333 NS = N 1334 KS = K 1335 ALS = ALPHA 1336 DO 10 I = 1, LAA 1337 AS( I ) = AA( I ) 1338 10 CONTINUE 1339 LDAS = LDA 1340 BETS = BETA 1341 DO 20 I = 1, LCC 1342 CS( I ) = CC( I ) 1343 20 CONTINUE 1344 LDCS = LDC 1345 * 1346 * Call the subroutine. 1347 * 1348 IF( TRACE ) 1349 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, 1350 $ TRANS, N, K, ALPHA, LDA, BETA, LDC 1351 IF( REWI ) 1352 $ REWIND NTRA 1353 CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, 1354 $ BETA, CC, LDC ) 1355 * 1356 * Check if error-exit was taken incorrectly. 1357 * 1358 IF( .NOT.OK )THEN 1359 WRITE( NOUT, FMT = 9993 ) 1360 FATAL = .TRUE. 1361 GO TO 120 1362 END IF 1363 * 1364 * See what data changed inside subroutines. 1365 * 1366 ISAME( 1 ) = UPLOS.EQ.UPLO 1367 ISAME( 2 ) = TRANSS.EQ.TRANS 1368 ISAME( 3 ) = NS.EQ.N 1369 ISAME( 4 ) = KS.EQ.K 1370 ISAME( 5 ) = ALS.EQ.ALPHA 1371 ISAME( 6 ) = LSE( AS, AA, LAA ) 1372 ISAME( 7 ) = LDAS.EQ.LDA 1373 ISAME( 8 ) = BETS.EQ.BETA 1374 IF( NULL )THEN 1375 ISAME( 9 ) = LSE( CS, CC, LCC ) 1376 ELSE 1377 ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, 1378 $ CC, LDC ) 1379 END IF 1380 ISAME( 10 ) = LDCS.EQ.LDC 1381 * 1382 * If data was incorrectly changed, report and 1383 * return. 1384 * 1385 SAME = .TRUE. 1386 DO 30 I = 1, NARGS 1387 SAME = SAME.AND.ISAME( I ) 1388 IF( .NOT.ISAME( I ) ) 1389 $ WRITE( NOUT, FMT = 9998 )I 1390 30 CONTINUE 1391 IF( .NOT.SAME )THEN 1392 FATAL = .TRUE. 1393 GO TO 120 1394 END IF 1395 * 1396 IF( .NOT.NULL )THEN 1397 * 1398 * Check the result column by column. 1399 * 1400 JC = 1 1401 DO 40 J = 1, N 1402 IF( UPPER )THEN 1403 JJ = 1 1404 LJ = J 1405 ELSE 1406 JJ = J 1407 LJ = N - J + 1 1408 END IF 1409 IF( TRAN )THEN 1410 CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, 1411 $ A( 1, JJ ), NMAX, 1412 $ A( 1, J ), NMAX, BETA, 1413 $ C( JJ, J ), NMAX, CT, G, 1414 $ CC( JC ), LDC, EPS, ERR, 1415 $ FATAL, NOUT, .TRUE. ) 1416 ELSE 1417 CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, 1418 $ A( JJ, 1 ), NMAX, 1419 $ A( J, 1 ), NMAX, BETA, 1420 $ C( JJ, J ), NMAX, CT, G, 1421 $ CC( JC ), LDC, EPS, ERR, 1422 $ FATAL, NOUT, .TRUE. ) 1423 END IF 1424 IF( UPPER )THEN 1425 JC = JC + LDC 1426 ELSE 1427 JC = JC + LDC + 1 1428 END IF 1429 ERRMAX = MAX( ERRMAX, ERR ) 1430 * If got really bad answer, report and 1431 * return. 1432 IF( FATAL ) 1433 $ GO TO 110 1434 40 CONTINUE 1435 END IF 1436 * 1437 50 CONTINUE 1438 * 1439 60 CONTINUE 1440 * 1441 70 CONTINUE 1442 * 1443 80 CONTINUE 1444 * 1445 90 CONTINUE 1446 * 1447 100 CONTINUE 1448 * 1449 * Report result. 1450 * 1451 IF( ERRMAX.LT.THRESH )THEN 1452 WRITE( NOUT, FMT = 9999 )SNAME, NC 1453 ELSE 1454 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1455 END IF 1456 GO TO 130 1457 * 1458 110 CONTINUE 1459 IF( N.GT.1 ) 1460 $ WRITE( NOUT, FMT = 9995 )J 1461 * 1462 120 CONTINUE 1463 WRITE( NOUT, FMT = 9996 )SNAME 1464 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, 1465 $ LDA, BETA, LDC 1466 * 1467 130 CONTINUE 1468 RETURN 1469 * 1470 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1471 $ 'S)' ) 1472 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1473 $ 'ANGED INCORRECTLY *******' ) 1474 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1475 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1476 $ ' - SUSPECT *******' ) 1477 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1478 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 1479 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), 1480 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 1481 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1482 $ '******' ) 1483 * 1484 * End of SCHK4. 1485 * 1486 END 1487 SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1488 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 1489 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) 1490 * 1491 * Tests SSYR2K. 1492 * 1493 * Auxiliary routine for test program for Level 3 Blas. 1494 * 1495 * -- Written on 8-February-1989. 1496 * Jack Dongarra, Argonne National Laboratory. 1497 * Iain Duff, AERE Harwell. 1498 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 1499 * Sven Hammarling, Numerical Algorithms Group Ltd. 1500 * 1501 * .. Parameters .. 1502 REAL ZERO 1503 PARAMETER ( ZERO = 0.0 ) 1504 * .. Scalar Arguments .. 1505 REAL EPS, THRESH 1506 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA 1507 LOGICAL FATAL, REWI, TRACE 1508 CHARACTER*6 SNAME 1509 * .. Array Arguments .. 1510 REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), 1511 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), 1512 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), 1513 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), 1514 $ G( NMAX ), W( 2*NMAX ) 1515 INTEGER IDIM( NIDIM ) 1516 * .. Local Scalars .. 1517 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX 1518 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, 1519 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, 1520 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS 1521 LOGICAL NULL, RESET, SAME, TRAN, UPPER 1522 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS 1523 CHARACTER*2 ICHU 1524 CHARACTER*3 ICHT 1525 * .. Local Arrays .. 1526 LOGICAL ISAME( 13 ) 1527 * .. External Functions .. 1528 LOGICAL LSE, LSERES 1529 EXTERNAL LSE, LSERES 1530 * .. External Subroutines .. 1531 EXTERNAL SMAKE, SMMCH, SSYR2K 1532 * .. Intrinsic Functions .. 1533 INTRINSIC MAX 1534 * .. Scalars in Common .. 1535 INTEGER INFOT, NOUTC 1536 LOGICAL LERR, OK 1537 * .. Common blocks .. 1538 COMMON /INFOC/INFOT, NOUTC, OK, LERR 1539 * .. Data statements .. 1540 DATA ICHT/'NTC'/, ICHU/'UL'/ 1541 * .. Executable Statements .. 1542 * 1543 NARGS = 12 1544 NC = 0 1545 RESET = .TRUE. 1546 ERRMAX = ZERO 1547 * 1548 DO 130 IN = 1, NIDIM 1549 N = IDIM( IN ) 1550 * Set LDC to 1 more than minimum value if room. 1551 LDC = N 1552 IF( LDC.LT.NMAX ) 1553 $ LDC = LDC + 1 1554 * Skip tests if not enough room. 1555 IF( LDC.GT.NMAX ) 1556 $ GO TO 130 1557 LCC = LDC*N 1558 NULL = N.LE.0 1559 * 1560 DO 120 IK = 1, NIDIM 1561 K = IDIM( IK ) 1562 * 1563 DO 110 ICT = 1, 3 1564 TRANS = ICHT( ICT: ICT ) 1565 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 1566 IF( TRAN )THEN 1567 MA = K 1568 NA = N 1569 ELSE 1570 MA = N 1571 NA = K 1572 END IF 1573 * Set LDA to 1 more than minimum value if room. 1574 LDA = MA 1575 IF( LDA.LT.NMAX ) 1576 $ LDA = LDA + 1 1577 * Skip tests if not enough room. 1578 IF( LDA.GT.NMAX ) 1579 $ GO TO 110 1580 LAA = LDA*NA 1581 * 1582 * Generate the matrix A. 1583 * 1584 IF( TRAN )THEN 1585 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, 1586 $ LDA, RESET, ZERO ) 1587 ELSE 1588 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, 1589 $ RESET, ZERO ) 1590 END IF 1591 * 1592 * Generate the matrix B. 1593 * 1594 LDB = LDA 1595 LBB = LAA 1596 IF( TRAN )THEN 1597 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), 1598 $ 2*NMAX, BB, LDB, RESET, ZERO ) 1599 ELSE 1600 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), 1601 $ NMAX, BB, LDB, RESET, ZERO ) 1602 END IF 1603 * 1604 DO 100 ICU = 1, 2 1605 UPLO = ICHU( ICU: ICU ) 1606 UPPER = UPLO.EQ.'U' 1607 * 1608 DO 90 IA = 1, NALF 1609 ALPHA = ALF( IA ) 1610 * 1611 DO 80 IB = 1, NBET 1612 BETA = BET( IB ) 1613 * 1614 * Generate the matrix C. 1615 * 1616 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, 1617 $ LDC, RESET, ZERO ) 1618 * 1619 NC = NC + 1 1620 * 1621 * Save every datum before calling the subroutine. 1622 * 1623 UPLOS = UPLO 1624 TRANSS = TRANS 1625 NS = N 1626 KS = K 1627 ALS = ALPHA 1628 DO 10 I = 1, LAA 1629 AS( I ) = AA( I ) 1630 10 CONTINUE 1631 LDAS = LDA 1632 DO 20 I = 1, LBB 1633 BS( I ) = BB( I ) 1634 20 CONTINUE 1635 LDBS = LDB 1636 BETS = BETA 1637 DO 30 I = 1, LCC 1638 CS( I ) = CC( I ) 1639 30 CONTINUE 1640 LDCS = LDC 1641 * 1642 * Call the subroutine. 1643 * 1644 IF( TRACE ) 1645 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, 1646 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC 1647 IF( REWI ) 1648 $ REWIND NTRA 1649 CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, 1650 $ BB, LDB, BETA, CC, LDC ) 1651 * 1652 * Check if error-exit was taken incorrectly. 1653 * 1654 IF( .NOT.OK )THEN 1655 WRITE( NOUT, FMT = 9993 ) 1656 FATAL = .TRUE. 1657 GO TO 150 1658 END IF 1659 * 1660 * See what data changed inside subroutines. 1661 * 1662 ISAME( 1 ) = UPLOS.EQ.UPLO 1663 ISAME( 2 ) = TRANSS.EQ.TRANS 1664 ISAME( 3 ) = NS.EQ.N 1665 ISAME( 4 ) = KS.EQ.K 1666 ISAME( 5 ) = ALS.EQ.ALPHA 1667 ISAME( 6 ) = LSE( AS, AA, LAA ) 1668 ISAME( 7 ) = LDAS.EQ.LDA 1669 ISAME( 8 ) = LSE( BS, BB, LBB ) 1670 ISAME( 9 ) = LDBS.EQ.LDB 1671 ISAME( 10 ) = BETS.EQ.BETA 1672 IF( NULL )THEN 1673 ISAME( 11 ) = LSE( CS, CC, LCC ) 1674 ELSE 1675 ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, 1676 $ CC, LDC ) 1677 END IF 1678 ISAME( 12 ) = LDCS.EQ.LDC 1679 * 1680 * If data was incorrectly changed, report and 1681 * return. 1682 * 1683 SAME = .TRUE. 1684 DO 40 I = 1, NARGS 1685 SAME = SAME.AND.ISAME( I ) 1686 IF( .NOT.ISAME( I ) ) 1687 $ WRITE( NOUT, FMT = 9998 )I 1688 40 CONTINUE 1689 IF( .NOT.SAME )THEN 1690 FATAL = .TRUE. 1691 GO TO 150 1692 END IF 1693 * 1694 IF( .NOT.NULL )THEN 1695 * 1696 * Check the result column by column. 1697 * 1698 JJAB = 1 1699 JC = 1 1700 DO 70 J = 1, N 1701 IF( UPPER )THEN 1702 JJ = 1 1703 LJ = J 1704 ELSE 1705 JJ = J 1706 LJ = N - J + 1 1707 END IF 1708 IF( TRAN )THEN 1709 DO 50 I = 1, K 1710 W( I ) = AB( ( J - 1 )*2*NMAX + K + 1711 $ I ) 1712 W( K + I ) = AB( ( J - 1 )*2*NMAX + 1713 $ I ) 1714 50 CONTINUE 1715 CALL SMMCH( 'T', 'N', LJ, 1, 2*K, 1716 $ ALPHA, AB( JJAB ), 2*NMAX, 1717 $ W, 2*NMAX, BETA, 1718 $ C( JJ, J ), NMAX, CT, G, 1719 $ CC( JC ), LDC, EPS, ERR, 1720 $ FATAL, NOUT, .TRUE. ) 1721 ELSE 1722 DO 60 I = 1, K 1723 W( I ) = AB( ( K + I - 1 )*NMAX + 1724 $ J ) 1725 W( K + I ) = AB( ( I - 1 )*NMAX + 1726 $ J ) 1727 60 CONTINUE 1728 CALL SMMCH( 'N', 'N', LJ, 1, 2*K, 1729 $ ALPHA, AB( JJ ), NMAX, W, 1730 $ 2*NMAX, BETA, C( JJ, J ), 1731 $ NMAX, CT, G, CC( JC ), LDC, 1732 $ EPS, ERR, FATAL, NOUT, 1733 $ .TRUE. ) 1734 END IF 1735 IF( UPPER )THEN 1736 JC = JC + LDC 1737 ELSE 1738 JC = JC + LDC + 1 1739 IF( TRAN ) 1740 $ JJAB = JJAB + 2*NMAX 1741 END IF 1742 ERRMAX = MAX( ERRMAX, ERR ) 1743 * If got really bad answer, report and 1744 * return. 1745 IF( FATAL ) 1746 $ GO TO 140 1747 70 CONTINUE 1748 END IF 1749 * 1750 80 CONTINUE 1751 * 1752 90 CONTINUE 1753 * 1754 100 CONTINUE 1755 * 1756 110 CONTINUE 1757 * 1758 120 CONTINUE 1759 * 1760 130 CONTINUE 1761 * 1762 * Report result. 1763 * 1764 IF( ERRMAX.LT.THRESH )THEN 1765 WRITE( NOUT, FMT = 9999 )SNAME, NC 1766 ELSE 1767 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1768 END IF 1769 GO TO 160 1770 * 1771 140 CONTINUE 1772 IF( N.GT.1 ) 1773 $ WRITE( NOUT, FMT = 9995 )J 1774 * 1775 150 CONTINUE 1776 WRITE( NOUT, FMT = 9996 )SNAME 1777 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, 1778 $ LDA, LDB, BETA, LDC 1779 * 1780 160 CONTINUE 1781 RETURN 1782 * 1783 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1784 $ 'S)' ) 1785 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1786 $ 'ANGED INCORRECTLY *******' ) 1787 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1788 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1789 $ ' - SUSPECT *******' ) 1790 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1791 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 1792 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), 1793 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', 1794 $ ' .' ) 1795 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1796 $ '******' ) 1797 * 1798 * End of SCHK5. 1799 * 1800 END 1801 SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) 1802 * 1803 * Tests the error exits from the Level 3 Blas. 1804 * Requires a special version of the error-handling routine XERBLA. 1805 * ALPHA, BETA, A, B and C should not need to be defined. 1806 * 1807 * Auxiliary routine for test program for Level 3 Blas. 1808 * 1809 * -- Written on 8-February-1989. 1810 * Jack Dongarra, Argonne National Laboratory. 1811 * Iain Duff, AERE Harwell. 1812 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 1813 * Sven Hammarling, Numerical Algorithms Group Ltd. 1814 * 1815 * .. Scalar Arguments .. 1816 INTEGER ISNUM, NOUT 1817 CHARACTER*6 SRNAMT 1818 * .. Scalars in Common .. 1819 INTEGER INFOT, NOUTC 1820 LOGICAL LERR, OK 1821 * .. Local Scalars .. 1822 REAL ALPHA, BETA 1823 * .. Local Arrays .. 1824 REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) 1825 * .. External Subroutines .. 1826 EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, 1827 $ STRSM 1828 * .. Common blocks .. 1829 COMMON /INFOC/INFOT, NOUTC, OK, LERR 1830 * .. Executable Statements .. 1831 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER 1832 * if anything is wrong. 1833 OK = .TRUE. 1834 * LERR is set to .TRUE. by the special version of XERBLA each time 1835 * it is called, and is then tested and re-set by CHKXER. 1836 LERR = .FALSE. 1837 GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM 1838 10 INFOT = 1 1839 CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1840 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1841 INFOT = 1 1842 CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1843 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1844 INFOT = 2 1845 CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1846 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1847 INFOT = 2 1848 CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1849 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1850 INFOT = 3 1851 CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1852 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1853 INFOT = 3 1854 CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1855 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1856 INFOT = 3 1857 CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1858 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1859 INFOT = 3 1860 CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1861 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1862 INFOT = 4 1863 CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1864 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1865 INFOT = 4 1866 CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1867 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1868 INFOT = 4 1869 CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1870 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1871 INFOT = 4 1872 CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1873 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1874 INFOT = 5 1875 CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1876 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1877 INFOT = 5 1878 CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1879 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1880 INFOT = 5 1881 CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1882 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1883 INFOT = 5 1884 CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1885 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1886 INFOT = 8 1887 CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) 1888 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1889 INFOT = 8 1890 CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) 1891 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1892 INFOT = 8 1893 CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) 1894 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1895 INFOT = 8 1896 CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1897 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1898 INFOT = 10 1899 CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1900 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1901 INFOT = 10 1902 CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) 1903 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1904 INFOT = 10 1905 CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1906 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1907 INFOT = 10 1908 CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1909 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1910 INFOT = 13 1911 CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) 1912 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1913 INFOT = 13 1914 CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) 1915 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1916 INFOT = 13 1917 CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1918 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1919 INFOT = 13 1920 CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1921 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1922 GO TO 70 1923 20 INFOT = 1 1924 CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1925 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1926 INFOT = 2 1927 CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1928 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1929 INFOT = 3 1930 CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1931 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1932 INFOT = 3 1933 CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1934 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1935 INFOT = 3 1936 CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1937 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1938 INFOT = 3 1939 CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1940 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1941 INFOT = 4 1942 CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1943 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1944 INFOT = 4 1945 CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1946 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1947 INFOT = 4 1948 CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1949 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1950 INFOT = 4 1951 CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1952 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1953 INFOT = 7 1954 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) 1955 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1956 INFOT = 7 1957 CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1958 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1959 INFOT = 7 1960 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) 1961 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1962 INFOT = 7 1963 CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1964 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1965 INFOT = 9 1966 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) 1967 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1968 INFOT = 9 1969 CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1970 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1971 INFOT = 9 1972 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) 1973 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1974 INFOT = 9 1975 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 1976 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1977 INFOT = 12 1978 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) 1979 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1980 INFOT = 12 1981 CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) 1982 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1983 INFOT = 12 1984 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) 1985 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1986 INFOT = 12 1987 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) 1988 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1989 GO TO 70 1990 30 INFOT = 1 1991 CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 1992 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1993 INFOT = 2 1994 CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 1995 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1996 INFOT = 3 1997 CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 1998 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 1999 INFOT = 4 2000 CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) 2001 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2002 INFOT = 5 2003 CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2004 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2005 INFOT = 5 2006 CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2007 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2008 INFOT = 5 2009 CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2010 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2011 INFOT = 5 2012 CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2013 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2014 INFOT = 5 2015 CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2016 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2017 INFOT = 5 2018 CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2019 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2020 INFOT = 5 2021 CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2022 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2023 INFOT = 5 2024 CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2025 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2026 INFOT = 6 2027 CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2028 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2029 INFOT = 6 2030 CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2031 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2032 INFOT = 6 2033 CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2034 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2035 INFOT = 6 2036 CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2037 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2038 INFOT = 6 2039 CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2040 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2041 INFOT = 6 2042 CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2043 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2044 INFOT = 6 2045 CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2046 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2047 INFOT = 6 2048 CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2049 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2050 INFOT = 9 2051 CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2052 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2053 INFOT = 9 2054 CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2055 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2056 INFOT = 9 2057 CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2058 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2059 INFOT = 9 2060 CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2061 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2062 INFOT = 9 2063 CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2064 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2065 INFOT = 9 2066 CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2067 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2068 INFOT = 9 2069 CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2070 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2071 INFOT = 9 2072 CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2073 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2074 INFOT = 11 2075 CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2076 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2077 INFOT = 11 2078 CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2079 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2080 INFOT = 11 2081 CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2082 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2083 INFOT = 11 2084 CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2085 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2086 INFOT = 11 2087 CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2088 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2089 INFOT = 11 2090 CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2091 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2092 INFOT = 11 2093 CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2094 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2095 INFOT = 11 2096 CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2097 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2098 GO TO 70 2099 40 INFOT = 1 2100 CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 2101 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2102 INFOT = 2 2103 CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 2104 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2105 INFOT = 3 2106 CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) 2107 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2108 INFOT = 4 2109 CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) 2110 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2111 INFOT = 5 2112 CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2113 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2114 INFOT = 5 2115 CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2116 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2117 INFOT = 5 2118 CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2119 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2120 INFOT = 5 2121 CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2122 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2123 INFOT = 5 2124 CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2125 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2126 INFOT = 5 2127 CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2128 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2129 INFOT = 5 2130 CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2131 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2132 INFOT = 5 2133 CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) 2134 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2135 INFOT = 6 2136 CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2137 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2138 INFOT = 6 2139 CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2140 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2141 INFOT = 6 2142 CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2143 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2144 INFOT = 6 2145 CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2146 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2147 INFOT = 6 2148 CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2149 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2150 INFOT = 6 2151 CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2152 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2153 INFOT = 6 2154 CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2155 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2156 INFOT = 6 2157 CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) 2158 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2159 INFOT = 9 2160 CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2161 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2162 INFOT = 9 2163 CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2164 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2165 INFOT = 9 2166 CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2167 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2168 INFOT = 9 2169 CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2170 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2171 INFOT = 9 2172 CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2173 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2174 INFOT = 9 2175 CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) 2176 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2177 INFOT = 9 2178 CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2179 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2180 INFOT = 9 2181 CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) 2182 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2183 INFOT = 11 2184 CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2185 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2186 INFOT = 11 2187 CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2188 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2189 INFOT = 11 2190 CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2191 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2192 INFOT = 11 2193 CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2194 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2195 INFOT = 11 2196 CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2197 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2198 INFOT = 11 2199 CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) 2200 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2201 INFOT = 11 2202 CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2203 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2204 INFOT = 11 2205 CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) 2206 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2207 GO TO 70 2208 50 INFOT = 1 2209 CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) 2210 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2211 INFOT = 2 2212 CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) 2213 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2214 INFOT = 3 2215 CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) 2216 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2217 INFOT = 3 2218 CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) 2219 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2220 INFOT = 3 2221 CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) 2222 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2223 INFOT = 3 2224 CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) 2225 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2226 INFOT = 4 2227 CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) 2228 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2229 INFOT = 4 2230 CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) 2231 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2232 INFOT = 4 2233 CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) 2234 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2235 INFOT = 4 2236 CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) 2237 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2238 INFOT = 7 2239 CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) 2240 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2241 INFOT = 7 2242 CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) 2243 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2244 INFOT = 7 2245 CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) 2246 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2247 INFOT = 7 2248 CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) 2249 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2250 INFOT = 10 2251 CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) 2252 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2253 INFOT = 10 2254 CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) 2255 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2256 INFOT = 10 2257 CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) 2258 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2259 INFOT = 10 2260 CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) 2261 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2262 GO TO 70 2263 60 INFOT = 1 2264 CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2265 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2266 INFOT = 2 2267 CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2268 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2269 INFOT = 3 2270 CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2271 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2272 INFOT = 3 2273 CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2274 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2275 INFOT = 3 2276 CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2277 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2278 INFOT = 3 2279 CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2280 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2281 INFOT = 4 2282 CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2283 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2284 INFOT = 4 2285 CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2286 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2287 INFOT = 4 2288 CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2289 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2290 INFOT = 4 2291 CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2292 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2293 INFOT = 7 2294 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) 2295 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2296 INFOT = 7 2297 CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2298 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2299 INFOT = 7 2300 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) 2301 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2302 INFOT = 7 2303 CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2304 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2305 INFOT = 9 2306 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) 2307 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2308 INFOT = 9 2309 CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) 2310 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2311 INFOT = 9 2312 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) 2313 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2314 INFOT = 9 2315 CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) 2316 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2317 INFOT = 12 2318 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) 2319 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2320 INFOT = 12 2321 CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2322 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2323 INFOT = 12 2324 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) 2325 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2326 INFOT = 12 2327 CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) 2328 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2329 * 2330 70 IF( OK )THEN 2331 WRITE( NOUT, FMT = 9999 )SRNAMT 2332 ELSE 2333 WRITE( NOUT, FMT = 9998 )SRNAMT 2334 END IF 2335 RETURN 2336 * 2337 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 2338 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', 2339 $ '**' ) 2340 * 2341 * End of SCHKE. 2342 * 2343 END 2344 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, 2345 $ TRANSL ) 2346 * 2347 * Generates values for an M by N matrix A. 2348 * Stores the values in the array AA in the data structure required 2349 * by the routine, with unwanted elements set to rogue value. 2350 * 2351 * TYPE is 'GE', 'SY' or 'TR'. 2352 * 2353 * Auxiliary routine for test program for Level 3 Blas. 2354 * 2355 * -- Written on 8-February-1989. 2356 * Jack Dongarra, Argonne National Laboratory. 2357 * Iain Duff, AERE Harwell. 2358 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2359 * Sven Hammarling, Numerical Algorithms Group Ltd. 2360 * 2361 * .. Parameters .. 2362 REAL ZERO, ONE 2363 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 2364 REAL ROGUE 2365 PARAMETER ( ROGUE = -1.0E10 ) 2366 * .. Scalar Arguments .. 2367 REAL TRANSL 2368 INTEGER LDA, M, N, NMAX 2369 LOGICAL RESET 2370 CHARACTER*1 DIAG, UPLO 2371 CHARACTER*2 TYPE 2372 * .. Array Arguments .. 2373 REAL A( NMAX, * ), AA( * ) 2374 * .. Local Scalars .. 2375 INTEGER I, IBEG, IEND, J 2376 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER 2377 * .. External Functions .. 2378 REAL SBEG 2379 EXTERNAL SBEG 2380 * .. Executable Statements .. 2381 GEN = TYPE.EQ.'GE' 2382 SYM = TYPE.EQ.'SY' 2383 TRI = TYPE.EQ.'TR' 2384 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' 2385 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' 2386 UNIT = TRI.AND.DIAG.EQ.'U' 2387 * 2388 * Generate data in array A. 2389 * 2390 DO 20 J = 1, N 2391 DO 10 I = 1, M 2392 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) 2393 $ THEN 2394 A( I, J ) = SBEG( RESET ) + TRANSL 2395 IF( I.NE.J )THEN 2396 * Set some elements to zero 2397 IF( N.GT.3.AND.J.EQ.N/2 ) 2398 $ A( I, J ) = ZERO 2399 IF( SYM )THEN 2400 A( J, I ) = A( I, J ) 2401 ELSE IF( TRI )THEN 2402 A( J, I ) = ZERO 2403 END IF 2404 END IF 2405 END IF 2406 10 CONTINUE 2407 IF( TRI ) 2408 $ A( J, J ) = A( J, J ) + ONE 2409 IF( UNIT ) 2410 $ A( J, J ) = ONE 2411 20 CONTINUE 2412 * 2413 * Store elements in array AS in data structure required by routine. 2414 * 2415 IF( TYPE.EQ.'GE' )THEN 2416 DO 50 J = 1, N 2417 DO 30 I = 1, M 2418 AA( I + ( J - 1 )*LDA ) = A( I, J ) 2419 30 CONTINUE 2420 DO 40 I = M + 1, LDA 2421 AA( I + ( J - 1 )*LDA ) = ROGUE 2422 40 CONTINUE 2423 50 CONTINUE 2424 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN 2425 DO 90 J = 1, N 2426 IF( UPPER )THEN 2427 IBEG = 1 2428 IF( UNIT )THEN 2429 IEND = J - 1 2430 ELSE 2431 IEND = J 2432 END IF 2433 ELSE 2434 IF( UNIT )THEN 2435 IBEG = J + 1 2436 ELSE 2437 IBEG = J 2438 END IF 2439 IEND = N 2440 END IF 2441 DO 60 I = 1, IBEG - 1 2442 AA( I + ( J - 1 )*LDA ) = ROGUE 2443 60 CONTINUE 2444 DO 70 I = IBEG, IEND 2445 AA( I + ( J - 1 )*LDA ) = A( I, J ) 2446 70 CONTINUE 2447 DO 80 I = IEND + 1, LDA 2448 AA( I + ( J - 1 )*LDA ) = ROGUE 2449 80 CONTINUE 2450 90 CONTINUE 2451 END IF 2452 RETURN 2453 * 2454 * End of SMAKE. 2455 * 2456 END 2457 SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, 2458 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, 2459 $ NOUT, MV ) 2460 * 2461 * Checks the results of the computational tests. 2462 * 2463 * Auxiliary routine for test program for Level 3 Blas. 2464 * 2465 * -- Written on 8-February-1989. 2466 * Jack Dongarra, Argonne National Laboratory. 2467 * Iain Duff, AERE Harwell. 2468 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2469 * Sven Hammarling, Numerical Algorithms Group Ltd. 2470 * 2471 * .. Parameters .. 2472 REAL ZERO, ONE 2473 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 2474 * .. Scalar Arguments .. 2475 REAL ALPHA, BETA, EPS, ERR 2476 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT 2477 LOGICAL FATAL, MV 2478 CHARACTER*1 TRANSA, TRANSB 2479 * .. Array Arguments .. 2480 REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), 2481 $ CC( LDCC, * ), CT( * ), G( * ) 2482 * .. Local Scalars .. 2483 REAL ERRI 2484 INTEGER I, J, K 2485 LOGICAL TRANA, TRANB 2486 * .. Intrinsic Functions .. 2487 INTRINSIC ABS, MAX, SQRT 2488 * .. Executable Statements .. 2489 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' 2490 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' 2491 * 2492 * Compute expected result, one column at a time, in CT using data 2493 * in A, B and C. 2494 * Compute gauges in G. 2495 * 2496 DO 120 J = 1, N 2497 * 2498 DO 10 I = 1, M 2499 CT( I ) = ZERO 2500 G( I ) = ZERO 2501 10 CONTINUE 2502 IF( .NOT.TRANA.AND..NOT.TRANB )THEN 2503 DO 30 K = 1, KK 2504 DO 20 I = 1, M 2505 CT( I ) = CT( I ) + A( I, K )*B( K, J ) 2506 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) 2507 20 CONTINUE 2508 30 CONTINUE 2509 ELSE IF( TRANA.AND..NOT.TRANB )THEN 2510 DO 50 K = 1, KK 2511 DO 40 I = 1, M 2512 CT( I ) = CT( I ) + A( K, I )*B( K, J ) 2513 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) 2514 40 CONTINUE 2515 50 CONTINUE 2516 ELSE IF( .NOT.TRANA.AND.TRANB )THEN 2517 DO 70 K = 1, KK 2518 DO 60 I = 1, M 2519 CT( I ) = CT( I ) + A( I, K )*B( J, K ) 2520 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) 2521 60 CONTINUE 2522 70 CONTINUE 2523 ELSE IF( TRANA.AND.TRANB )THEN 2524 DO 90 K = 1, KK 2525 DO 80 I = 1, M 2526 CT( I ) = CT( I ) + A( K, I )*B( J, K ) 2527 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) 2528 80 CONTINUE 2529 90 CONTINUE 2530 END IF 2531 DO 100 I = 1, M 2532 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) 2533 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) 2534 100 CONTINUE 2535 * 2536 * Compute the error ratio for this result. 2537 * 2538 ERR = ZERO 2539 DO 110 I = 1, M 2540 ERRI = ABS( CT( I ) - CC( I, J ) )/EPS 2541 IF( G( I ).NE.ZERO ) 2542 $ ERRI = ERRI/G( I ) 2543 ERR = MAX( ERR, ERRI ) 2544 IF( ERR*SQRT( EPS ).GE.ONE ) 2545 $ GO TO 130 2546 110 CONTINUE 2547 * 2548 120 CONTINUE 2549 * 2550 * If the loop completes, all results are at least half accurate. 2551 GO TO 150 2552 * 2553 * Report fatal error. 2554 * 2555 130 FATAL = .TRUE. 2556 WRITE( NOUT, FMT = 9999 ) 2557 DO 140 I = 1, M 2558 IF( MV )THEN 2559 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) 2560 ELSE 2561 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) 2562 END IF 2563 140 CONTINUE 2564 IF( N.GT.1 ) 2565 $ WRITE( NOUT, FMT = 9997 )J 2566 * 2567 150 CONTINUE 2568 RETURN 2569 * 2570 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', 2571 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', 2572 $ 'TED RESULT' ) 2573 9998 FORMAT( 1X, I7, 2G18.6 ) 2574 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 2575 * 2576 * End of SMMCH. 2577 * 2578 END 2579 LOGICAL FUNCTION LSE( RI, RJ, LR ) 2580 * 2581 * Tests if two arrays are identical. 2582 * 2583 * Auxiliary routine for test program for Level 3 Blas. 2584 * 2585 * -- Written on 8-February-1989. 2586 * Jack Dongarra, Argonne National Laboratory. 2587 * Iain Duff, AERE Harwell. 2588 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2589 * Sven Hammarling, Numerical Algorithms Group Ltd. 2590 * 2591 * .. Scalar Arguments .. 2592 INTEGER LR 2593 * .. Array Arguments .. 2594 REAL RI( * ), RJ( * ) 2595 * .. Local Scalars .. 2596 INTEGER I 2597 * .. Executable Statements .. 2598 DO 10 I = 1, LR 2599 IF( RI( I ).NE.RJ( I ) ) 2600 $ GO TO 20 2601 10 CONTINUE 2602 LSE = .TRUE. 2603 GO TO 30 2604 20 CONTINUE 2605 LSE = .FALSE. 2606 30 RETURN 2607 * 2608 * End of LSE. 2609 * 2610 END 2611 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) 2612 * 2613 * Tests if selected elements in two arrays are equal. 2614 * 2615 * TYPE is 'GE' or 'SY'. 2616 * 2617 * Auxiliary routine for test program for Level 3 Blas. 2618 * 2619 * -- Written on 8-February-1989. 2620 * Jack Dongarra, Argonne National Laboratory. 2621 * Iain Duff, AERE Harwell. 2622 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2623 * Sven Hammarling, Numerical Algorithms Group Ltd. 2624 * 2625 * .. Scalar Arguments .. 2626 INTEGER LDA, M, N 2627 CHARACTER*1 UPLO 2628 CHARACTER*2 TYPE 2629 * .. Array Arguments .. 2630 REAL AA( LDA, * ), AS( LDA, * ) 2631 * .. Local Scalars .. 2632 INTEGER I, IBEG, IEND, J 2633 LOGICAL UPPER 2634 * .. Executable Statements .. 2635 UPPER = UPLO.EQ.'U' 2636 IF( TYPE.EQ.'GE' )THEN 2637 DO 20 J = 1, N 2638 DO 10 I = M + 1, LDA 2639 IF( AA( I, J ).NE.AS( I, J ) ) 2640 $ GO TO 70 2641 10 CONTINUE 2642 20 CONTINUE 2643 ELSE IF( TYPE.EQ.'SY' )THEN 2644 DO 50 J = 1, N 2645 IF( UPPER )THEN 2646 IBEG = 1 2647 IEND = J 2648 ELSE 2649 IBEG = J 2650 IEND = N 2651 END IF 2652 DO 30 I = 1, IBEG - 1 2653 IF( AA( I, J ).NE.AS( I, J ) ) 2654 $ GO TO 70 2655 30 CONTINUE 2656 DO 40 I = IEND + 1, LDA 2657 IF( AA( I, J ).NE.AS( I, J ) ) 2658 $ GO TO 70 2659 40 CONTINUE 2660 50 CONTINUE 2661 END IF 2662 * 2663 60 CONTINUE 2664 LSERES = .TRUE. 2665 GO TO 80 2666 70 CONTINUE 2667 LSERES = .FALSE. 2668 80 RETURN 2669 * 2670 * End of LSERES. 2671 * 2672 END 2673 REAL FUNCTION SBEG( RESET ) 2674 * 2675 * Generates random numbers uniformly distributed between -0.5 and 0.5. 2676 * 2677 * Auxiliary routine for test program for Level 3 Blas. 2678 * 2679 * -- Written on 8-February-1989. 2680 * Jack Dongarra, Argonne National Laboratory. 2681 * Iain Duff, AERE Harwell. 2682 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2683 * Sven Hammarling, Numerical Algorithms Group Ltd. 2684 * 2685 * .. Scalar Arguments .. 2686 LOGICAL RESET 2687 * .. Local Scalars .. 2688 INTEGER I, IC, MI 2689 * .. Save statement .. 2690 SAVE I, IC, MI 2691 * .. Executable Statements .. 2692 IF( RESET )THEN 2693 * Initialize local variables. 2694 MI = 891 2695 I = 7 2696 IC = 0 2697 RESET = .FALSE. 2698 END IF 2699 * 2700 * The sequence of values of I is bounded between 1 and 999. 2701 * If initial I = 1,2,3,6,7 or 9, the period will be 50. 2702 * If initial I = 4 or 8, the period will be 25. 2703 * If initial I = 5, the period will be 10. 2704 * IC is used to break up the period by skipping 1 value of I in 6. 2705 * 2706 IC = IC + 1 2707 10 I = I*MI 2708 I = I - 1000*( I/1000 ) 2709 IF( IC.GE.5 )THEN 2710 IC = 0 2711 GO TO 10 2712 END IF 2713 SBEG = ( I - 500 )/1001.0 2714 RETURN 2715 * 2716 * End of SBEG. 2717 * 2718 END 2719 REAL FUNCTION SDIFF( X, Y ) 2720 * 2721 * Auxiliary routine for test program for Level 3 Blas. 2722 * 2723 * -- Written on 8-February-1989. 2724 * Jack Dongarra, Argonne National Laboratory. 2725 * Iain Duff, AERE Harwell. 2726 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2727 * Sven Hammarling, Numerical Algorithms Group Ltd. 2728 * 2729 * .. Scalar Arguments .. 2730 REAL X, Y 2731 * .. Executable Statements .. 2732 SDIFF = X - Y 2733 RETURN 2734 * 2735 * End of SDIFF. 2736 * 2737 END 2738 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2739 * 2740 * Tests whether XERBLA has detected an error when it should. 2741 * 2742 * Auxiliary routine for test program for Level 3 Blas. 2743 * 2744 * -- Written on 8-February-1989. 2745 * Jack Dongarra, Argonne National Laboratory. 2746 * Iain Duff, AERE Harwell. 2747 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2748 * Sven Hammarling, Numerical Algorithms Group Ltd. 2749 * 2750 * .. Scalar Arguments .. 2751 INTEGER INFOT, NOUT 2752 LOGICAL LERR, OK 2753 CHARACTER*6 SRNAMT 2754 * .. Executable Statements .. 2755 IF( .NOT.LERR )THEN 2756 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT 2757 OK = .FALSE. 2758 END IF 2759 LERR = .FALSE. 2760 RETURN 2761 * 2762 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', 2763 $ 'ETECTED BY ', A6, ' *****' ) 2764 * 2765 * End of CHKXER. 2766 * 2767 END 2768 SUBROUTINE XERBLA( SRNAME, INFO ) 2769 * 2770 * This is a special version of XERBLA to be used only as part of 2771 * the test program for testing error exits from the Level 3 BLAS 2772 * routines. 2773 * 2774 * XERBLA is an error handler for the Level 3 BLAS routines. 2775 * 2776 * It is called by the Level 3 BLAS routines if an input parameter is 2777 * invalid. 2778 * 2779 * Auxiliary routine for test program for Level 3 Blas. 2780 * 2781 * -- Written on 8-February-1989. 2782 * Jack Dongarra, Argonne National Laboratory. 2783 * Iain Duff, AERE Harwell. 2784 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 2785 * Sven Hammarling, Numerical Algorithms Group Ltd. 2786 * 2787 * .. Scalar Arguments .. 2788 INTEGER INFO 2789 CHARACTER*6 SRNAME 2790 * .. Scalars in Common .. 2791 INTEGER INFOT, NOUT 2792 LOGICAL LERR, OK 2793 CHARACTER*6 SRNAMT 2794 * .. Common blocks .. 2795 COMMON /INFOC/INFOT, NOUT, OK, LERR 2796 COMMON /SRNAMC/SRNAMT 2797 * .. Executable Statements .. 2798 LERR = .TRUE. 2799 IF( INFO.NE.INFOT )THEN 2800 IF( INFOT.NE.0 )THEN 2801 WRITE( NOUT, FMT = 9999 )INFO, INFOT 2802 ELSE 2803 WRITE( NOUT, FMT = 9997 )INFO 2804 END IF 2805 OK = .FALSE. 2806 END IF 2807 IF( SRNAME.NE.SRNAMT )THEN 2808 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT 2809 OK = .FALSE. 2810 END IF 2811 RETURN 2812 * 2813 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', 2814 $ ' OF ', I2, ' *******' ) 2815 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', 2816 $ 'AD OF ', A6, ' *******' ) 2817 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, 2818 $ ' *******' ) 2819 * 2820 * End of XERBLA 2821 * 2822 END 2823 2824
