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