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