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