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