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