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