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