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