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 CALL CPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, 1369 $ M, N, ALPHA, LDA, LDB) 1370* 1371 160 CONTINUE 1372 RETURN 1373* 137410003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1375 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1376 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 137710002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1378 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1379 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 138010001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1381 $ ' (', I6, ' CALL', 'S)' ) 138210000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', 1383 $ ' (', I6, ' CALL', 'S)' ) 1384 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1385 $ 'ANGED INCORRECTLY *******' ) 1386 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' ) 1387 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), 1388 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', 1389 $ ' .' ) 1390 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1391 $ '******' ) 1392* 1393* End of CCHK3. 1394* 1395 END 1396* 1397 SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, 1398 $ DIAG, M, N, ALPHA, LDA, LDB) 1399 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB 1400 COMPLEX ALPHA 1401 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG 1402 CHARACTER*12 SNAME 1403 CHARACTER*14 CRC, CS, CU, CA, CD 1404 1405 IF (SIDE.EQ.'L')THEN 1406 CS = ' CblasLeft' 1407 ELSE 1408 CS = ' CblasRight' 1409 END IF 1410 IF (UPLO.EQ.'U')THEN 1411 CU = ' CblasUpper' 1412 ELSE 1413 CU = ' CblasLower' 1414 END IF 1415 IF (TRANSA.EQ.'N')THEN 1416 CA = ' CblasNoTrans' 1417 ELSE IF (TRANSA.EQ.'T')THEN 1418 CA = ' CblasTrans' 1419 ELSE 1420 CA = 'CblasConjTrans' 1421 END IF 1422 IF (DIAG.EQ.'N')THEN 1423 CD = ' CblasNonUnit' 1424 ELSE 1425 CD = ' CblasUnit' 1426 END IF 1427 IF (IORDER.EQ.1)THEN 1428 CRC = ' CblasRowMajor' 1429 ELSE 1430 CRC = ' CblasColMajor' 1431 END IF 1432 WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU 1433 WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB 1434 1435 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') 1436 9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',', 1437 $ F4.1, '), A,', I3, ', B,', I3, ').' ) 1438 END 1439* 1440 SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1441 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 1442 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, 1443 $ IORDER ) 1444* 1445* Tests CHERK and CSYRK. 1446* 1447* Auxiliary routine for test program for Level 3 Blas. 1448* 1449* -- Written on 8-February-1989. 1450* Jack Dongarra, Argonne National Laboratory. 1451* Iain Duff, AERE Harwell. 1452* Jeremy Du Croz, Numerical Algorithms Group Ltd. 1453* Sven Hammarling, Numerical Algorithms Group Ltd. 1454* 1455* .. Parameters .. 1456 COMPLEX ZERO 1457 PARAMETER ( ZERO = ( 0.0, 0.0 ) ) 1458 REAL RONE, RZERO 1459 PARAMETER ( RONE = 1.0, RZERO = 0.0 ) 1460* .. Scalar Arguments .. 1461 REAL EPS, THRESH 1462 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER 1463 LOGICAL FATAL, REWI, TRACE 1464 CHARACTER*12 SNAME 1465* .. Array Arguments .. 1466 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 1467 $ AS( NMAX*NMAX ), B( NMAX, NMAX ), 1468 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), 1469 $ C( NMAX, NMAX ), CC( NMAX*NMAX ), 1470 $ CS( NMAX*NMAX ), CT( NMAX ) 1471 REAL G( NMAX ) 1472 INTEGER IDIM( NIDIM ) 1473* .. Local Scalars .. 1474 COMPLEX ALPHA, ALS, BETA, BETS 1475 REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS 1476 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, 1477 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, 1478 $ NARGS, NC, NS 1479 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER 1480 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS 1481 CHARACTER*2 ICHT, ICHU 1482* .. Local Arrays .. 1483 LOGICAL ISAME( 13 ) 1484* .. External Functions .. 1485 LOGICAL LCE, LCERES 1486 EXTERNAL LCE, LCERES 1487* .. External Subroutines .. 1488 EXTERNAL CCHERK, CMAKE, CMMCH, CCSYRK 1489* .. Intrinsic Functions .. 1490 INTRINSIC CMPLX, MAX, REAL 1491* .. Scalars in Common .. 1492 INTEGER INFOT, NOUTC 1493 LOGICAL LERR, OK 1494* .. Common blocks .. 1495 COMMON /INFOC/INFOT, NOUTC, OK, LERR 1496* .. Data statements .. 1497 DATA ICHT/'NC'/, ICHU/'UL'/ 1498* .. Executable Statements .. 1499 CONJ = SNAME( 8: 9 ).EQ.'he' 1500* 1501 NARGS = 10 1502 NC = 0 1503 RESET = .TRUE. 1504 ERRMAX = RZERO 1505* 1506 DO 100 IN = 1, NIDIM 1507 N = IDIM( IN ) 1508* Set LDC to 1 more than minimum value if room. 1509 LDC = N 1510 IF( LDC.LT.NMAX ) 1511 $ LDC = LDC + 1 1512* Skip tests if not enough room. 1513 IF( LDC.GT.NMAX ) 1514 $ GO TO 100 1515 LCC = LDC*N 1516* 1517 DO 90 IK = 1, NIDIM 1518 K = IDIM( IK ) 1519* 1520 DO 80 ICT = 1, 2 1521 TRANS = ICHT( ICT: ICT ) 1522 TRAN = TRANS.EQ.'C' 1523 IF( TRAN.AND..NOT.CONJ ) 1524 $ TRANS = 'T' 1525 IF( TRAN )THEN 1526 MA = K 1527 NA = N 1528 ELSE 1529 MA = N 1530 NA = K 1531 END IF 1532* Set LDA to 1 more than minimum value if room. 1533 LDA = MA 1534 IF( LDA.LT.NMAX ) 1535 $ LDA = LDA + 1 1536* Skip tests if not enough room. 1537 IF( LDA.GT.NMAX ) 1538 $ GO TO 80 1539 LAA = LDA*NA 1540* 1541* Generate the matrix A. 1542* 1543 CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA, 1544 $ RESET, ZERO ) 1545* 1546 DO 70 ICU = 1, 2 1547 UPLO = ICHU( ICU: ICU ) 1548 UPPER = UPLO.EQ.'U' 1549* 1550 DO 60 IA = 1, NALF 1551 ALPHA = ALF( IA ) 1552 IF( CONJ )THEN 1553 RALPHA = REAL( ALPHA ) 1554 ALPHA = CMPLX( RALPHA, RZERO ) 1555 END IF 1556* 1557 DO 50 IB = 1, NBET 1558 BETA = BET( IB ) 1559 IF( CONJ )THEN 1560 RBETA = REAL( BETA ) 1561 BETA = CMPLX( RBETA, RZERO ) 1562 END IF 1563 NULL = N.LE.0 1564 IF( CONJ ) 1565 $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. 1566 $ RZERO ).AND.RBETA.EQ.RONE ) 1567* 1568* Generate the matrix C. 1569* 1570 CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, 1571 $ NMAX, CC, LDC, RESET, ZERO ) 1572* 1573 NC = NC + 1 1574* 1575* Save every datum before calling the subroutine. 1576* 1577 UPLOS = UPLO 1578 TRANSS = TRANS 1579 NS = N 1580 KS = K 1581 IF( CONJ )THEN 1582 RALS = RALPHA 1583 ELSE 1584 ALS = ALPHA 1585 END IF 1586 DO 10 I = 1, LAA 1587 AS( I ) = AA( I ) 1588 10 CONTINUE 1589 LDAS = LDA 1590 IF( CONJ )THEN 1591 RBETS = RBETA 1592 ELSE 1593 BETS = BETA 1594 END IF 1595 DO 20 I = 1, LCC 1596 CS( I ) = CC( I ) 1597 20 CONTINUE 1598 LDCS = LDC 1599* 1600* Call the subroutine. 1601* 1602 IF( CONJ )THEN 1603 IF( TRACE ) 1604 $ CALL CPRCN6( NTRA, NC, SNAME, IORDER, 1605 $ UPLO, TRANS, N, K, RALPHA, LDA, RBETA, 1606 $ LDC) 1607 IF( REWI ) 1608 $ REWIND NTRA 1609 CALL CCHERK( IORDER, UPLO, TRANS, N, K, 1610 $ RALPHA, AA, LDA, RBETA, CC, 1611 $ LDC ) 1612 ELSE 1613 IF( TRACE ) 1614 $ CALL CPRCN4( NTRA, NC, SNAME, IORDER, 1615 $ UPLO, TRANS, N, K, ALPHA, LDA, BETA, LDC) 1616 IF( REWI ) 1617 $ REWIND NTRA 1618 CALL CCSYRK( IORDER, UPLO, TRANS, N, K, 1619 $ ALPHA, AA, LDA, BETA, CC, LDC ) 1620 END IF 1621* 1622* Check if error-exit was taken incorrectly. 1623* 1624 IF( .NOT.OK )THEN 1625 WRITE( NOUT, FMT = 9992 ) 1626 FATAL = .TRUE. 1627 GO TO 120 1628 END IF 1629* 1630* See what data changed inside subroutines. 1631* 1632 ISAME( 1 ) = UPLOS.EQ.UPLO 1633 ISAME( 2 ) = TRANSS.EQ.TRANS 1634 ISAME( 3 ) = NS.EQ.N 1635 ISAME( 4 ) = KS.EQ.K 1636 IF( CONJ )THEN 1637 ISAME( 5 ) = RALS.EQ.RALPHA 1638 ELSE 1639 ISAME( 5 ) = ALS.EQ.ALPHA 1640 END IF 1641 ISAME( 6 ) = LCE( AS, AA, LAA ) 1642 ISAME( 7 ) = LDAS.EQ.LDA 1643 IF( CONJ )THEN 1644 ISAME( 8 ) = RBETS.EQ.RBETA 1645 ELSE 1646 ISAME( 8 ) = BETS.EQ.BETA 1647 END IF 1648 IF( NULL )THEN 1649 ISAME( 9 ) = LCE( CS, CC, LCC ) 1650 ELSE 1651 ISAME( 9 ) = LCERES( SNAME( 8: 9 ), UPLO, N, 1652 $ N, CS, CC, LDC ) 1653 END IF 1654 ISAME( 10 ) = LDCS.EQ.LDC 1655* 1656* If data was incorrectly changed, report and 1657* return. 1658* 1659 SAME = .TRUE. 1660 DO 30 I = 1, NARGS 1661 SAME = SAME.AND.ISAME( I ) 1662 IF( .NOT.ISAME( I ) ) 1663 $ WRITE( NOUT, FMT = 9998 )I 1664 30 CONTINUE 1665 IF( .NOT.SAME )THEN 1666 FATAL = .TRUE. 1667 GO TO 120 1668 END IF 1669* 1670 IF( .NOT.NULL )THEN 1671* 1672* Check the result column by column. 1673* 1674 IF( CONJ )THEN 1675 TRANST = 'C' 1676 ELSE 1677 TRANST = 'T' 1678 END IF 1679 JC = 1 1680 DO 40 J = 1, N 1681 IF( UPPER )THEN 1682 JJ = 1 1683 LJ = J 1684 ELSE 1685 JJ = J 1686 LJ = N - J + 1 1687 END IF 1688 IF( TRAN )THEN 1689 CALL CMMCH( TRANST, 'N', LJ, 1, K, 1690 $ ALPHA, A( 1, JJ ), NMAX, 1691 $ A( 1, J ), NMAX, BETA, 1692 $ C( JJ, J ), NMAX, CT, G, 1693 $ CC( JC ), LDC, EPS, ERR, 1694 $ FATAL, NOUT, .TRUE. ) 1695 ELSE 1696 CALL CMMCH( 'N', TRANST, LJ, 1, K, 1697 $ ALPHA, A( JJ, 1 ), NMAX, 1698 $ A( J, 1 ), NMAX, BETA, 1699 $ C( JJ, J ), NMAX, CT, G, 1700 $ CC( JC ), LDC, EPS, ERR, 1701 $ FATAL, NOUT, .TRUE. ) 1702 END IF 1703 IF( UPPER )THEN 1704 JC = JC + LDC 1705 ELSE 1706 JC = JC + LDC + 1 1707 END IF 1708 ERRMAX = MAX( ERRMAX, ERR ) 1709* If got really bad answer, report and 1710* return. 1711 IF( FATAL ) 1712 $ GO TO 110 1713 40 CONTINUE 1714 END IF 1715* 1716 50 CONTINUE 1717* 1718 60 CONTINUE 1719* 1720 70 CONTINUE 1721* 1722 80 CONTINUE 1723* 1724 90 CONTINUE 1725* 1726 100 CONTINUE 1727* 1728* Report result. 1729* 1730 IF( ERRMAX.LT.THRESH )THEN 1731 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC 1732 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC 1733 ELSE 1734 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX 1735 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX 1736 END IF 1737 GO TO 130 1738* 1739 110 CONTINUE 1740 IF( N.GT.1 ) 1741 $ WRITE( NOUT, FMT = 9995 )J 1742* 1743 120 CONTINUE 1744 WRITE( NOUT, FMT = 9996 )SNAME 1745 IF( CONJ )THEN 1746 CALL CPRCN6( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, RALPHA, 1747 $ LDA, rBETA, LDC) 1748 ELSE 1749 CALL CPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, 1750 $ LDA, BETA, LDC) 1751 END IF 1752* 1753 130 CONTINUE 1754 RETURN 1755* 175610003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1757 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1758 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 175910002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1760 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1761 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 176210001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1763 $ ' (', I6, ' CALL', 'S)' ) 176410000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', 1765 $ ' (', I6, ' CALL', 'S)' ) 1766 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1767 $ 'ANGED INCORRECTLY *******' ) 1768 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) 1769 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 1770 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), 1771 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', 1772 $ ' .' ) 1773 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), 1774 $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, 1775 $ '), C,', I3, ') .' ) 1776 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1777 $ '******' ) 1778* 1779* End of CCHK4. 1780* 1781 END 1782* 1783 SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, 1784 $ N, K, ALPHA, LDA, BETA, LDC) 1785 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC 1786 COMPLEX ALPHA, BETA 1787 CHARACTER*1 UPLO, TRANSA 1788 CHARACTER*12 SNAME 1789 CHARACTER*14 CRC, CU, CA 1790 1791 IF (UPLO.EQ.'U')THEN 1792 CU = ' CblasUpper' 1793 ELSE 1794 CU = ' CblasLower' 1795 END IF 1796 IF (TRANSA.EQ.'N')THEN 1797 CA = ' CblasNoTrans' 1798 ELSE IF (TRANSA.EQ.'T')THEN 1799 CA = ' CblasTrans' 1800 ELSE 1801 CA = 'CblasConjTrans' 1802 END IF 1803 IF (IORDER.EQ.1)THEN 1804 CRC = ' CblasRowMajor' 1805 ELSE 1806 CRC = ' CblasColMajor' 1807 END IF 1808 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA 1809 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC 1810 1811 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) 1812 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,', 1813 $ I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' ) 1814 END 1815* 1816* 1817 SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, 1818 $ N, K, ALPHA, LDA, BETA, LDC) 1819 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC 1820 REAL ALPHA, BETA 1821 CHARACTER*1 UPLO, TRANSA 1822 CHARACTER*12 SNAME 1823 CHARACTER*14 CRC, CU, CA 1824 1825 IF (UPLO.EQ.'U')THEN 1826 CU = ' CblasUpper' 1827 ELSE 1828 CU = ' CblasLower' 1829 END IF 1830 IF (TRANSA.EQ.'N')THEN 1831 CA = ' CblasNoTrans' 1832 ELSE IF (TRANSA.EQ.'T')THEN 1833 CA = ' CblasTrans' 1834 ELSE 1835 CA = 'CblasConjTrans' 1836 END IF 1837 IF (IORDER.EQ.1)THEN 1838 CRC = ' CblasRowMajor' 1839 ELSE 1840 CRC = ' CblasColMajor' 1841 END IF 1842 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA 1843 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC 1844 1845 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) 1846 9994 FORMAT( 10X, 2( I3, ',' ), 1847 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) 1848 END 1849* 1850 SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1851 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, 1852 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, 1853 $ IORDER ) 1854* 1855* Tests CHER2K and CSYR2K. 1856* 1857* Auxiliary routine for test program for Level 3 Blas. 1858* 1859* -- Written on 8-February-1989. 1860* Jack Dongarra, Argonne National Laboratory. 1861* Iain Duff, AERE Harwell. 1862* Jeremy Du Croz, Numerical Algorithms Group Ltd. 1863* Sven Hammarling, Numerical Algorithms Group Ltd. 1864* 1865* .. Parameters .. 1866 COMPLEX ZERO, ONE 1867 PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 1868 REAL RONE, RZERO 1869 PARAMETER ( RONE = 1.0, RZERO = 0.0 ) 1870* .. Scalar Arguments .. 1871 REAL EPS, THRESH 1872 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER 1873 LOGICAL FATAL, REWI, TRACE 1874 CHARACTER*12 SNAME 1875* .. Array Arguments .. 1876 COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), 1877 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), 1878 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), 1879 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), 1880 $ W( 2*NMAX ) 1881 REAL G( NMAX ) 1882 INTEGER IDIM( NIDIM ) 1883* .. Local Scalars .. 1884 COMPLEX ALPHA, ALS, BETA, BETS 1885 REAL ERR, ERRMAX, RBETA, RBETS 1886 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, 1887 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, 1888 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS 1889 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER 1890 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS 1891 CHARACTER*2 ICHT, ICHU 1892* .. Local Arrays .. 1893 LOGICAL ISAME( 13 ) 1894* .. External Functions .. 1895 LOGICAL LCE, LCERES 1896 EXTERNAL LCE, LCERES 1897* .. External Subroutines .. 1898 EXTERNAL CCHER2K, CMAKE, CMMCH, CCSYR2K 1899* .. Intrinsic Functions .. 1900 INTRINSIC CMPLX, CONJG, MAX, REAL 1901* .. Scalars in Common .. 1902 INTEGER INFOT, NOUTC 1903 LOGICAL LERR, OK 1904* .. Common blocks .. 1905 COMMON /INFOC/INFOT, NOUTC, OK, LERR 1906* .. Data statements .. 1907 DATA ICHT/'NC'/, ICHU/'UL'/ 1908* .. Executable Statements .. 1909 CONJ = SNAME( 8: 9 ).EQ.'he' 1910* 1911 NARGS = 12 1912 NC = 0 1913 RESET = .TRUE. 1914 ERRMAX = RZERO 1915* 1916 DO 130 IN = 1, NIDIM 1917 N = IDIM( IN ) 1918* Set LDC to 1 more than minimum value if room. 1919 LDC = N 1920 IF( LDC.LT.NMAX ) 1921 $ LDC = LDC + 1 1922* Skip tests if not enough room. 1923 IF( LDC.GT.NMAX ) 1924 $ GO TO 130 1925 LCC = LDC*N 1926* 1927 DO 120 IK = 1, NIDIM 1928 K = IDIM( IK ) 1929* 1930 DO 110 ICT = 1, 2 1931 TRANS = ICHT( ICT: ICT ) 1932 TRAN = TRANS.EQ.'C' 1933 IF( TRAN.AND..NOT.CONJ ) 1934 $ TRANS = 'T' 1935 IF( TRAN )THEN 1936 MA = K 1937 NA = N 1938 ELSE 1939 MA = N 1940 NA = K 1941 END IF 1942* Set LDA to 1 more than minimum value if room. 1943 LDA = MA 1944 IF( LDA.LT.NMAX ) 1945 $ LDA = LDA + 1 1946* Skip tests if not enough room. 1947 IF( LDA.GT.NMAX ) 1948 $ GO TO 110 1949 LAA = LDA*NA 1950* 1951* Generate the matrix A. 1952* 1953 IF( TRAN )THEN 1954 CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, 2*NMAX, AA, 1955 $ LDA, RESET, ZERO ) 1956 ELSE 1957 CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, 1958 $ RESET, ZERO ) 1959 END IF 1960* 1961* Generate the matrix B. 1962* 1963 LDB = LDA 1964 LBB = LAA 1965 IF( TRAN )THEN 1966 CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K + 1 ), 1967 $ 2*NMAX, BB, LDB, RESET, ZERO ) 1968 ELSE 1969 CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), 1970 $ NMAX, BB, LDB, RESET, ZERO ) 1971 END IF 1972* 1973 DO 100 ICU = 1, 2 1974 UPLO = ICHU( ICU: ICU ) 1975 UPPER = UPLO.EQ.'U' 1976* 1977 DO 90 IA = 1, NALF 1978 ALPHA = ALF( IA ) 1979* 1980 DO 80 IB = 1, NBET 1981 BETA = BET( IB ) 1982 IF( CONJ )THEN 1983 RBETA = REAL( BETA ) 1984 BETA = CMPLX( RBETA, RZERO ) 1985 END IF 1986 NULL = N.LE.0 1987 IF( CONJ ) 1988 $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. 1989 $ ZERO ).AND.RBETA.EQ.RONE ) 1990* 1991* Generate the matrix C. 1992* 1993 CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, 1994 $ NMAX, CC, LDC, RESET, ZERO ) 1995* 1996 NC = NC + 1 1997* 1998* Save every datum before calling the subroutine. 1999* 2000 UPLOS = UPLO 2001 TRANSS = TRANS 2002 NS = N 2003 KS = K 2004 ALS = ALPHA 2005 DO 10 I = 1, LAA 2006 AS( I ) = AA( I ) 2007 10 CONTINUE 2008 LDAS = LDA 2009 DO 20 I = 1, LBB 2010 BS( I ) = BB( I ) 2011 20 CONTINUE 2012 LDBS = LDB 2013 IF( CONJ )THEN 2014 RBETS = RBETA 2015 ELSE 2016 BETS = BETA 2017 END IF 2018 DO 30 I = 1, LCC 2019 CS( I ) = CC( I ) 2020 30 CONTINUE 2021 LDCS = LDC 2022* 2023* Call the subroutine. 2024* 2025 IF( CONJ )THEN 2026 IF( TRACE ) 2027 $ CALL CPRCN7( NTRA, NC, SNAME, IORDER, 2028 $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, 2029 $ RBETA, LDC) 2030 IF( REWI ) 2031 $ REWIND NTRA 2032 CALL CCHER2K( IORDER, UPLO, TRANS, N, K, 2033 $ ALPHA, AA, LDA, BB, LDB, RBETA, 2034 $ CC, LDC ) 2035 ELSE 2036 IF( TRACE ) 2037 $ CALL CPRCN5( NTRA, NC, SNAME, IORDER, 2038 $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, 2039 $ BETA, LDC) 2040 IF( REWI ) 2041 $ REWIND NTRA 2042 CALL CCSYR2K( IORDER, UPLO, TRANS, N, K, 2043 $ ALPHA, AA, LDA, BB, LDB, BETA, 2044 $ CC, LDC ) 2045 END IF 2046* 2047* Check if error-exit was taken incorrectly. 2048* 2049 IF( .NOT.OK )THEN 2050 WRITE( NOUT, FMT = 9992 ) 2051 FATAL = .TRUE. 2052 GO TO 150 2053 END IF 2054* 2055* See what data changed inside subroutines. 2056* 2057 ISAME( 1 ) = UPLOS.EQ.UPLO 2058 ISAME( 2 ) = TRANSS.EQ.TRANS 2059 ISAME( 3 ) = NS.EQ.N 2060 ISAME( 4 ) = KS.EQ.K 2061 ISAME( 5 ) = ALS.EQ.ALPHA 2062 ISAME( 6 ) = LCE( AS, AA, LAA ) 2063 ISAME( 7 ) = LDAS.EQ.LDA 2064 ISAME( 8 ) = LCE( BS, BB, LBB ) 2065 ISAME( 9 ) = LDBS.EQ.LDB 2066 IF( CONJ )THEN 2067 ISAME( 10 ) = RBETS.EQ.RBETA 2068 ELSE 2069 ISAME( 10 ) = BETS.EQ.BETA 2070 END IF 2071 IF( NULL )THEN 2072 ISAME( 11 ) = LCE( CS, CC, LCC ) 2073 ELSE 2074 ISAME( 11 ) = LCERES( 'he', UPLO, N, N, CS, 2075 $ CC, LDC ) 2076 END IF 2077 ISAME( 12 ) = LDCS.EQ.LDC 2078* 2079* If data was incorrectly changed, report and 2080* return. 2081* 2082 SAME = .TRUE. 2083 DO 40 I = 1, NARGS 2084 SAME = SAME.AND.ISAME( I ) 2085 IF( .NOT.ISAME( I ) ) 2086 $ WRITE( NOUT, FMT = 9998 )I 2087 40 CONTINUE 2088 IF( .NOT.SAME )THEN 2089 FATAL = .TRUE. 2090 GO TO 150 2091 END IF 2092* 2093 IF( .NOT.NULL )THEN 2094* 2095* Check the result column by column. 2096* 2097 IF( CONJ )THEN 2098 TRANST = 'C' 2099 ELSE 2100 TRANST = 'T' 2101 END IF 2102 JJAB = 1 2103 JC = 1 2104 DO 70 J = 1, N 2105 IF( UPPER )THEN 2106 JJ = 1 2107 LJ = J 2108 ELSE 2109 JJ = J 2110 LJ = N - J + 1 2111 END IF 2112 IF( TRAN )THEN 2113 DO 50 I = 1, K 2114 W( I ) = ALPHA*AB( ( J - 1 )*2* 2115 $ NMAX + K + I ) 2116 IF( CONJ )THEN 2117 W( K + I ) = CONJG( ALPHA )* 2118 $ AB( ( J - 1 )*2* 2119 $ NMAX + I ) 2120 ELSE 2121 W( K + I ) = ALPHA* 2122 $ AB( ( J - 1 )*2* 2123 $ NMAX + I ) 2124 END IF 2125 50 CONTINUE 2126 CALL CMMCH( TRANST, 'N', LJ, 1, 2*K, 2127 $ ONE, AB( JJAB ), 2*NMAX, W, 2128 $ 2*NMAX, BETA, C( JJ, J ), 2129 $ NMAX, CT, G, CC( JC ), LDC, 2130 $ EPS, ERR, FATAL, NOUT, 2131 $ .TRUE. ) 2132 ELSE 2133 DO 60 I = 1, K 2134 IF( CONJ )THEN 2135 W( I ) = ALPHA*CONJG( AB( ( K + 2136 $ I - 1 )*NMAX + J ) ) 2137 W( K + I ) = CONJG( ALPHA* 2138 $ AB( ( I - 1 )*NMAX + 2139 $ J ) ) 2140 ELSE 2141 W( I ) = ALPHA*AB( ( K + I - 1 )* 2142 $ NMAX + J ) 2143 W( K + I ) = ALPHA* 2144 $ AB( ( I - 1 )*NMAX + 2145 $ J ) 2146 END IF 2147 60 CONTINUE 2148 CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, 2149 $ AB( JJ ), NMAX, W, 2*NMAX, 2150 $ BETA, C( JJ, J ), NMAX, CT, 2151 $ G, CC( JC ), LDC, EPS, ERR, 2152 $ FATAL, NOUT, .TRUE. ) 2153 END IF 2154 IF( UPPER )THEN 2155 JC = JC + LDC 2156 ELSE 2157 JC = JC + LDC + 1 2158 IF( TRAN ) 2159 $ JJAB = JJAB + 2*NMAX 2160 END IF 2161 ERRMAX = MAX( ERRMAX, ERR ) 2162* If got really bad answer, report and 2163* return. 2164 IF( FATAL ) 2165 $ GO TO 140 2166 70 CONTINUE 2167 END IF 2168* 2169 80 CONTINUE 2170* 2171 90 CONTINUE 2172* 2173 100 CONTINUE 2174* 2175 110 CONTINUE 2176* 2177 120 CONTINUE 2178* 2179 130 CONTINUE 2180* 2181* Report result. 2182* 2183 IF( ERRMAX.LT.THRESH )THEN 2184 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC 2185 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC 2186 ELSE 2187 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX 2188 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX 2189 END IF 2190 GO TO 160 2191* 2192 140 CONTINUE 2193 IF( N.GT.1 ) 2194 $ WRITE( NOUT, FMT = 9995 )J 2195* 2196 150 CONTINUE 2197 WRITE( NOUT, FMT = 9996 )SNAME 2198 IF( CONJ )THEN 2199 CALL CPRCN7( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, 2200 $ ALPHA, LDA, LDB, RBETA, LDC) 2201 ELSE 2202 CALL CPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, 2203 $ ALPHA, LDA, LDB, BETA, LDC) 2204 END IF 2205* 2206 160 CONTINUE 2207 RETURN 2208* 220910003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 2210 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2211 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 221210002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 2213 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2214 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 221510001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 2216 $ ' (', I6, ' CALL', 'S)' ) 221710000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', 2218 $ ' (', I6, ' CALL', 'S)' ) 2219 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 2220 $ 'ANGED INCORRECTLY *******' ) 2221 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) 2222 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 2223 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), 2224 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, 2225 $ ', C,', I3, ') .' ) 2226 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), 2227 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, 2228 $ ',', F4.1, '), C,', I3, ') .' ) 2229 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 2230 $ '******' ) 2231* 2232* End of CCHK5. 2233* 2234 END 2235* 2236 SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, 2237 $ N, K, ALPHA, LDA, LDB, BETA, LDC) 2238 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC 2239 COMPLEX ALPHA, BETA 2240 CHARACTER*1 UPLO, TRANSA 2241 CHARACTER*12 SNAME 2242 CHARACTER*14 CRC, CU, CA 2243 2244 IF (UPLO.EQ.'U')THEN 2245 CU = ' CblasUpper' 2246 ELSE 2247 CU = ' CblasLower' 2248 END IF 2249 IF (TRANSA.EQ.'N')THEN 2250 CA = ' CblasNoTrans' 2251 ELSE IF (TRANSA.EQ.'T')THEN 2252 CA = ' CblasTrans' 2253 ELSE 2254 CA = 'CblasConjTrans' 2255 END IF 2256 IF (IORDER.EQ.1)THEN 2257 CRC = ' CblasRowMajor' 2258 ELSE 2259 CRC = ' CblasColMajor' 2260 END IF 2261 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA 2262 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC 2263 2264 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) 2265 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', 2266 $ I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' ) 2267 END 2268* 2269* 2270 SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, 2271 $ N, K, ALPHA, LDA, LDB, BETA, LDC) 2272 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC 2273 COMPLEX ALPHA 2274 REAL BETA 2275 CHARACTER*1 UPLO, TRANSA 2276 CHARACTER*12 SNAME 2277 CHARACTER*14 CRC, CU, CA 2278 2279 IF (UPLO.EQ.'U')THEN 2280 CU = ' CblasUpper' 2281 ELSE 2282 CU = ' CblasLower' 2283 END IF 2284 IF (TRANSA.EQ.'N')THEN 2285 CA = ' CblasNoTrans' 2286 ELSE IF (TRANSA.EQ.'T')THEN 2287 CA = ' CblasTrans' 2288 ELSE 2289 CA = 'CblasConjTrans' 2290 END IF 2291 IF (IORDER.EQ.1)THEN 2292 CRC = ' CblasRowMajor' 2293 ELSE 2294 CRC = ' CblasColMajor' 2295 END IF 2296 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA 2297 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC 2298 2299 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) 2300 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', 2301 $ I3, ', B', I3, ',', F4.1, ', C,', I3, ').' ) 2302 END 2303* 2304 SUBROUTINE CMAKE(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, 2305 $ TRANSL ) 2306* 2307* Generates values for an M by N matrix A. 2308* Stores the values in the array AA in the data structure required 2309* by the routine, with unwanted elements set to rogue value. 2310* 2311* TYPE is 'ge', 'he', 'sy' or 'tr'. 2312* 2313* Auxiliary routine for test program for Level 3 Blas. 2314* 2315* -- Written on 8-February-1989. 2316* Jack Dongarra, Argonne National Laboratory. 2317* Iain Duff, AERE Harwell. 2318* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2319* Sven Hammarling, Numerical Algorithms Group Ltd. 2320* 2321* .. Parameters .. 2322 COMPLEX ZERO, ONE 2323 PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 2324 COMPLEX ROGUE 2325 PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) 2326 REAL RZERO 2327 PARAMETER ( RZERO = 0.0 ) 2328 REAL RROGUE 2329 PARAMETER ( RROGUE = -1.0E10 ) 2330* .. Scalar Arguments .. 2331 COMPLEX TRANSL 2332 INTEGER LDA, M, N, NMAX 2333 LOGICAL RESET 2334 CHARACTER*1 DIAG, UPLO 2335 CHARACTER*2 TYPE 2336* .. Array Arguments .. 2337 COMPLEX A( NMAX, * ), AA( * ) 2338* .. Local Scalars .. 2339 INTEGER I, IBEG, IEND, J, JJ 2340 LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER 2341* .. External Functions .. 2342 COMPLEX CBEG 2343 EXTERNAL CBEG 2344* .. Intrinsic Functions .. 2345 INTRINSIC CMPLX, CONJG, REAL 2346* .. Executable Statements .. 2347 GEN = TYPE.EQ.'ge' 2348 HER = TYPE.EQ.'he' 2349 SYM = TYPE.EQ.'sy' 2350 TRI = TYPE.EQ.'tr' 2351 UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' 2352 LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' 2353 UNIT = TRI.AND.DIAG.EQ.'U' 2354* 2355* Generate data in array A. 2356* 2357 DO 20 J = 1, N 2358 DO 10 I = 1, M 2359 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) 2360 $ THEN 2361 A( I, J ) = CBEG( RESET ) + TRANSL 2362 IF( I.NE.J )THEN 2363* Set some elements to zero 2364 IF( N.GT.3.AND.J.EQ.N/2 ) 2365 $ A( I, J ) = ZERO 2366 IF( HER )THEN 2367 A( J, I ) = CONJG( A( I, J ) ) 2368 ELSE IF( SYM )THEN 2369 A( J, I ) = A( I, J ) 2370 ELSE IF( TRI )THEN 2371 A( J, I ) = ZERO 2372 END IF 2373 END IF 2374 END IF 2375 10 CONTINUE 2376 IF( HER ) 2377 $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) 2378 IF( TRI ) 2379 $ A( J, J ) = A( J, J ) + ONE 2380 IF( UNIT ) 2381 $ A( J, J ) = ONE 2382 20 CONTINUE 2383* 2384* Store elements in array AS in data structure required by routine. 2385* 2386 IF( TYPE.EQ.'ge' )THEN 2387 DO 50 J = 1, N 2388 DO 30 I = 1, M 2389 AA( I + ( J - 1 )*LDA ) = A( I, J ) 2390 30 CONTINUE 2391 DO 40 I = M + 1, LDA 2392 AA( I + ( J - 1 )*LDA ) = ROGUE 2393 40 CONTINUE 2394 50 CONTINUE 2395 ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN 2396 DO 90 J = 1, N 2397 IF( UPPER )THEN 2398 IBEG = 1 2399 IF( UNIT )THEN 2400 IEND = J - 1 2401 ELSE 2402 IEND = J 2403 END IF 2404 ELSE 2405 IF( UNIT )THEN 2406 IBEG = J + 1 2407 ELSE 2408 IBEG = J 2409 END IF 2410 IEND = N 2411 END IF 2412 DO 60 I = 1, IBEG - 1 2413 AA( I + ( J - 1 )*LDA ) = ROGUE 2414 60 CONTINUE 2415 DO 70 I = IBEG, IEND 2416 AA( I + ( J - 1 )*LDA ) = A( I, J ) 2417 70 CONTINUE 2418 DO 80 I = IEND + 1, LDA 2419 AA( I + ( J - 1 )*LDA ) = ROGUE 2420 80 CONTINUE 2421 IF( HER )THEN 2422 JJ = J + ( J - 1 )*LDA 2423 AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) 2424 END IF 2425 90 CONTINUE 2426 END IF 2427 RETURN 2428* 2429* End of CMAKE. 2430* 2431 END 2432 SUBROUTINE CMMCH(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, 2433 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, 2434 $ NOUT, MV ) 2435* 2436* Checks the results of the computational tests. 2437* 2438* Auxiliary routine for test program for Level 3 Blas. 2439* 2440* -- Written on 8-February-1989. 2441* Jack Dongarra, Argonne National Laboratory. 2442* Iain Duff, AERE Harwell. 2443* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2444* Sven Hammarling, Numerical Algorithms Group Ltd. 2445* 2446* .. Parameters .. 2447 COMPLEX ZERO 2448 PARAMETER ( ZERO = ( 0.0, 0.0 ) ) 2449 REAL RZERO, RONE 2450 PARAMETER ( RZERO = 0.0, RONE = 1.0 ) 2451* .. Scalar Arguments .. 2452 COMPLEX ALPHA, BETA 2453 REAL EPS, ERR 2454 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT 2455 LOGICAL FATAL, MV 2456 CHARACTER*1 TRANSA, TRANSB 2457* .. Array Arguments .. 2458 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), 2459 $ CC( LDCC, * ), CT( * ) 2460 REAL G( * ) 2461* .. Local Scalars .. 2462 COMPLEX CL 2463 REAL ERRI 2464 INTEGER I, J, K 2465 LOGICAL CTRANA, CTRANB, TRANA, TRANB 2466* .. Intrinsic Functions .. 2467 INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT 2468* .. Statement Functions .. 2469 REAL ABS1 2470* .. Statement Function definitions .. 2471 ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) 2472* .. Executable Statements .. 2473 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' 2474 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' 2475 CTRANA = TRANSA.EQ.'C' 2476 CTRANB = TRANSB.EQ.'C' 2477* 2478* Compute expected result, one column at a time, in CT using data 2479* in A, B and C. 2480* Compute gauges in G. 2481* 2482 DO 220 J = 1, N 2483* 2484 DO 10 I = 1, M 2485 CT( I ) = ZERO 2486 G( I ) = RZERO 2487 10 CONTINUE 2488 IF( .NOT.TRANA.AND..NOT.TRANB )THEN 2489 DO 30 K = 1, KK 2490 DO 20 I = 1, M 2491 CT( I ) = CT( I ) + A( I, K )*B( K, J ) 2492 G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) 2493 20 CONTINUE 2494 30 CONTINUE 2495 ELSE IF( TRANA.AND..NOT.TRANB )THEN 2496 IF( CTRANA )THEN 2497 DO 50 K = 1, KK 2498 DO 40 I = 1, M 2499 CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) 2500 G( I ) = G( I ) + ABS1( A( K, I ) )* 2501 $ ABS1( B( K, J ) ) 2502 40 CONTINUE 2503 50 CONTINUE 2504 ELSE 2505 DO 70 K = 1, KK 2506 DO 60 I = 1, M 2507 CT( I ) = CT( I ) + A( K, I )*B( K, J ) 2508 G( I ) = G( I ) + ABS1( A( K, I ) )* 2509 $ ABS1( B( K, J ) ) 2510 60 CONTINUE 2511 70 CONTINUE 2512 END IF 2513 ELSE IF( .NOT.TRANA.AND.TRANB )THEN 2514 IF( CTRANB )THEN 2515 DO 90 K = 1, KK 2516 DO 80 I = 1, M 2517 CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) 2518 G( I ) = G( I ) + ABS1( A( I, K ) )* 2519 $ ABS1( B( J, K ) ) 2520 80 CONTINUE 2521 90 CONTINUE 2522 ELSE 2523 DO 110 K = 1, KK 2524 DO 100 I = 1, M 2525 CT( I ) = CT( I ) + A( I, K )*B( J, K ) 2526 G( I ) = G( I ) + ABS1( A( I, K ) )* 2527 $ ABS1( B( J, K ) ) 2528 100 CONTINUE 2529 110 CONTINUE 2530 END IF 2531 ELSE IF( TRANA.AND.TRANB )THEN 2532 IF( CTRANA )THEN 2533 IF( CTRANB )THEN 2534 DO 130 K = 1, KK 2535 DO 120 I = 1, M 2536 CT( I ) = CT( I ) + CONJG( A( K, I ) )* 2537 $ CONJG( B( J, K ) ) 2538 G( I ) = G( I ) + ABS1( A( K, I ) )* 2539 $ ABS1( B( J, K ) ) 2540 120 CONTINUE 2541 130 CONTINUE 2542 ELSE 2543 DO 150 K = 1, KK 2544 DO 140 I = 1, M 2545 CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) 2546 G( I ) = G( I ) + ABS1( A( K, I ) )* 2547 $ ABS1( B( J, K ) ) 2548 140 CONTINUE 2549 150 CONTINUE 2550 END IF 2551 ELSE 2552 IF( CTRANB )THEN 2553 DO 170 K = 1, KK 2554 DO 160 I = 1, M 2555 CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) 2556 G( I ) = G( I ) + ABS1( A( K, I ) )* 2557 $ ABS1( B( J, K ) ) 2558 160 CONTINUE 2559 170 CONTINUE 2560 ELSE 2561 DO 190 K = 1, KK 2562 DO 180 I = 1, M 2563 CT( I ) = CT( I ) + A( K, I )*B( J, K ) 2564 G( I ) = G( I ) + ABS1( A( K, I ) )* 2565 $ ABS1( B( J, K ) ) 2566 180 CONTINUE 2567 190 CONTINUE 2568 END IF 2569 END IF 2570 END IF 2571 DO 200 I = 1, M 2572 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) 2573 G( I ) = ABS1( ALPHA )*G( I ) + 2574 $ ABS1( BETA )*ABS1( C( I, J ) ) 2575 200 CONTINUE 2576* 2577* Compute the error ratio for this result. 2578* 2579 ERR = ZERO 2580 DO 210 I = 1, M 2581 ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS 2582 IF( G( I ).NE.RZERO ) 2583 $ ERRI = ERRI/G( I ) 2584 ERR = MAX( ERR, ERRI ) 2585 IF( ERR*SQRT( EPS ).GE.RONE ) 2586 $ GO TO 230 2587 210 CONTINUE 2588* 2589 220 CONTINUE 2590* 2591* If the loop completes, all results are at least half accurate. 2592 GO TO 250 2593* 2594* Report fatal error. 2595* 2596 230 FATAL = .TRUE. 2597 WRITE( NOUT, FMT = 9999 ) 2598 DO 240 I = 1, M 2599 IF( MV )THEN 2600 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) 2601 ELSE 2602 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) 2603 END IF 2604 240 CONTINUE 2605 IF( N.GT.1 ) 2606 $ WRITE( NOUT, FMT = 9997 )J 2607* 2608 250 CONTINUE 2609 RETURN 2610* 2611 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', 2612 $ 'F ACCURATE *******', /' EXPECTED RE', 2613 $ 'SULT COMPUTED RESULT' ) 2614 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 2615 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 2616* 2617* End of CMMCH. 2618* 2619 END 2620 LOGICAL FUNCTION LCE( RI, RJ, LR ) 2621* 2622* Tests if two arrays are identical. 2623* 2624* Auxiliary routine for test program for Level 3 Blas. 2625* 2626* -- Written on 8-February-1989. 2627* Jack Dongarra, Argonne National Laboratory. 2628* Iain Duff, AERE Harwell. 2629* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2630* Sven Hammarling, Numerical Algorithms Group Ltd. 2631* 2632* .. Scalar Arguments .. 2633 INTEGER LR 2634* .. Array Arguments .. 2635 COMPLEX RI( * ), RJ( * ) 2636* .. Local Scalars .. 2637 INTEGER I 2638* .. Executable Statements .. 2639 DO 10 I = 1, LR 2640 IF( RI( I ).NE.RJ( I ) ) 2641 $ GO TO 20 2642 10 CONTINUE 2643 LCE = .TRUE. 2644 GO TO 30 2645 20 CONTINUE 2646 LCE = .FALSE. 2647 30 RETURN 2648* 2649* End of LCE. 2650* 2651 END 2652 LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) 2653* 2654* Tests if selected elements in two arrays are equal. 2655* 2656* TYPE is 'ge' or 'he' or 'sy'. 2657* 2658* Auxiliary routine for test program for Level 3 Blas. 2659* 2660* -- Written on 8-February-1989. 2661* Jack Dongarra, Argonne National Laboratory. 2662* Iain Duff, AERE Harwell. 2663* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2664* Sven Hammarling, Numerical Algorithms Group Ltd. 2665* 2666* .. Scalar Arguments .. 2667 INTEGER LDA, M, N 2668 CHARACTER*1 UPLO 2669 CHARACTER*2 TYPE 2670* .. Array Arguments .. 2671 COMPLEX AA( LDA, * ), AS( LDA, * ) 2672* .. Local Scalars .. 2673 INTEGER I, IBEG, IEND, J 2674 LOGICAL UPPER 2675* .. Executable Statements .. 2676 UPPER = UPLO.EQ.'U' 2677 IF( TYPE.EQ.'ge' )THEN 2678 DO 20 J = 1, N 2679 DO 10 I = M + 1, LDA 2680 IF( AA( I, J ).NE.AS( I, J ) ) 2681 $ GO TO 70 2682 10 CONTINUE 2683 20 CONTINUE 2684 ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy' )THEN 2685 DO 50 J = 1, N 2686 IF( UPPER )THEN 2687 IBEG = 1 2688 IEND = J 2689 ELSE 2690 IBEG = J 2691 IEND = N 2692 END IF 2693 DO 30 I = 1, IBEG - 1 2694 IF( AA( I, J ).NE.AS( I, J ) ) 2695 $ GO TO 70 2696 30 CONTINUE 2697 DO 40 I = IEND + 1, LDA 2698 IF( AA( I, J ).NE.AS( I, J ) ) 2699 $ GO TO 70 2700 40 CONTINUE 2701 50 CONTINUE 2702 END IF 2703* 2704 60 CONTINUE 2705 LCERES = .TRUE. 2706 GO TO 80 2707 70 CONTINUE 2708 LCERES = .FALSE. 2709 80 RETURN 2710* 2711* End of LCERES. 2712* 2713 END 2714 COMPLEX FUNCTION CBEG( RESET ) 2715* 2716* Generates complex numbers as pairs of random numbers uniformly 2717* distributed between -0.5 and 0.5. 2718* 2719* Auxiliary routine for test program for Level 3 Blas. 2720* 2721* -- Written on 8-February-1989. 2722* Jack Dongarra, Argonne National Laboratory. 2723* Iain Duff, AERE Harwell. 2724* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2725* Sven Hammarling, Numerical Algorithms Group Ltd. 2726* 2727* .. Scalar Arguments .. 2728 LOGICAL RESET 2729* .. Local Scalars .. 2730 INTEGER I, IC, J, MI, MJ 2731* .. Save statement .. 2732 SAVE I, IC, J, MI, MJ 2733* .. Intrinsic Functions .. 2734 INTRINSIC CMPLX 2735* .. Executable Statements .. 2736 IF( RESET )THEN 2737* Initialize local variables. 2738 MI = 891 2739 MJ = 457 2740 I = 7 2741 J = 7 2742 IC = 0 2743 RESET = .FALSE. 2744 END IF 2745* 2746* The sequence of values of I or J is bounded between 1 and 999. 2747* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. 2748* If initial I or J = 4 or 8, the period will be 25. 2749* If initial I or J = 5, the period will be 10. 2750* IC is used to break up the period by skipping 1 value of I or J 2751* in 6. 2752* 2753 IC = IC + 1 2754 10 I = I*MI 2755 J = J*MJ 2756 I = I - 1000*( I/1000 ) 2757 J = J - 1000*( J/1000 ) 2758 IF( IC.GE.5 )THEN 2759 IC = 0 2760 GO TO 10 2761 END IF 2762 CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) 2763 RETURN 2764* 2765* End of CBEG. 2766* 2767 END 2768 REAL FUNCTION SDIFF( X, Y ) 2769* 2770* Auxiliary routine for test program for Level 3 Blas. 2771* 2772* -- Written on 8-February-1989. 2773* Jack Dongarra, Argonne National Laboratory. 2774* Iain Duff, AERE Harwell. 2775* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2776* Sven Hammarling, Numerical Algorithms Group Ltd. 2777* 2778* .. Scalar Arguments .. 2779 REAL X, Y 2780* .. Executable Statements .. 2781 SDIFF = X - Y 2782 RETURN 2783* 2784* End of SDIFF. 2785* 2786 END 2787