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