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