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