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 * 383 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) 384 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) 385 10000 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 * 684 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 685 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 686 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 687 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 688 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 689 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 690 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 691 $ ' (', I6, ' CALL', 'S)' ) 692 10000 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 * 1001 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1002 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1003 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1004 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1005 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1006 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1007 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1008 $ ' (', I6, ' CALL', 'S)' ) 1009 10000 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 * 1348 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1349 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1350 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1351 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1352 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1353 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1354 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1355 $ ' (', I6, ' CALL', 'S)' ) 1356 10000 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 * 1674 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1675 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1676 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1677 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1678 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1679 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 1680 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1681 $ ' (', I6, ' CALL', 'S)' ) 1682 10000 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 * 2029 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 2030 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2031 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 2032 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 2033 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2034 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 2035 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 2036 $ ' (', I6, ' CALL', 'S)' ) 2037 10000 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
