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