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