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