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