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