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* 41910002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) 42010001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) 42110000 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* 78810003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 789 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 790 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 79110002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 792 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 793 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 79410001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 795 $ ' (', I6, ' CALL', 'S)' ) 79610000 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* 114710003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1148 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1149 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 115010002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1151 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1152 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 115310001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1154 $ ' (', I6, ' CALL', 'S)' ) 115510000 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* 153510003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1536 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1537 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 153810002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1539 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1540 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 154110001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1542 $ ' (', I6, ' CALL', 'S)' ) 154310000 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* 181010003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 1811 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1812 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 181310002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 1814 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 1815 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 181610001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 1817 $ ' (', I6, ' CALL', 'S)' ) 181810000 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* 210410003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 2105 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2106 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 210710002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 2108 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2109 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 211010001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 2111 $ ' (', I6, ' CALL', 'S)' ) 211210000 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* 243610003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', 2437 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2438 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 243910002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', 2440 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', 2441 $ 'RATIO ', F8.2, ' - SUSPECT *******' ) 244210001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', 2443 $ ' (', I6, ' CALL', 'S)' ) 244410000 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