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