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* 38410002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) 38510001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) 38610000 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* 68410003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 685 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 686 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 68710002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 688 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 689 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 69010001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 691 $ ' (', I6, ' CALL', 'S)' ) 69210000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', 693 $ ' (', I6, ' CALL', 'S)' ) 694 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 695 $ 'ANGED INCORRECTLY *******' ) 696 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) 697 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', 698 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', 699 $ 'C,', I3, ').' ) 700 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 701 $ '******' ) 702* 703* End of 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* 99710003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 998 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 999 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 100010002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1001 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1002 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 100310001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1004 $ ' (', I6, ' CALL', 'S)' ) 100510000 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* 134410003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1345 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1346 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 134710002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1348 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1349 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 135010001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1351 $ ' (', I6, ' CALL', 'S)' ) 135210000 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* 166910003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1670 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1671 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 167210002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1673 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1674 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 167510001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1676 $ ' (', I6, ' CALL', 'S)' ) 167710000 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* 202510003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 2026 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2027 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 202810002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 2029 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2030 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 203110001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 2032 $ ' (', I6, ' CALL', 'S)' ) 203310000 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