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