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