 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 PROGRAM CBLAT2 00002 * 00003 * Test program for the COMPLEX Level 2 Blas. 00004 * 00005 * The program must be driven by a short data file. The first 18 records 00006 * of the file are read using list-directed input, the last 17 records 00007 * are read using the format ( A6, L2 ). An annotated example of a data 00008 * file can be obtained by deleting the first 3 characters from the 00009 * following 35 lines: 00010 * 'cblat2.out' NAME OF SUMMARY OUTPUT FILE 00011 * 6 UNIT NUMBER OF SUMMARY FILE 00012 * 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE 00013 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) 00014 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. 00015 * F LOGICAL FLAG, T TO STOP ON FAILURES. 00016 * T LOGICAL FLAG, T TO TEST ERROR EXITS. 00017 * 16.0 THRESHOLD VALUE OF TEST RATIO 00018 * 6 NUMBER OF VALUES OF N 00019 * 0 1 2 3 5 9 VALUES OF N 00020 * 4 NUMBER OF VALUES OF K 00021 * 0 1 2 4 VALUES OF K 00022 * 4 NUMBER OF VALUES OF INCX AND INCY 00023 * 1 2 -1 -2 VALUES OF INCX AND INCY 00024 * 3 NUMBER OF VALUES OF ALPHA 00025 * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA 00026 * 3 NUMBER OF VALUES OF BETA 00027 * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA 00028 * CGEMV T PUT F FOR NO TEST. SAME COLUMNS. 00029 * CGBMV T PUT F FOR NO TEST. SAME COLUMNS. 00030 * CHEMV T PUT F FOR NO TEST. SAME COLUMNS. 00031 * CHBMV T PUT F FOR NO TEST. SAME COLUMNS. 00032 * CHPMV T PUT F FOR NO TEST. SAME COLUMNS. 00033 * CTRMV T PUT F FOR NO TEST. SAME COLUMNS. 00034 * CTBMV T PUT F FOR NO TEST. SAME COLUMNS. 00035 * CTPMV T PUT F FOR NO TEST. SAME COLUMNS. 00036 * CTRSV T PUT F FOR NO TEST. SAME COLUMNS. 00037 * CTBSV T PUT F FOR NO TEST. SAME COLUMNS. 00038 * CTPSV T PUT F FOR NO TEST. SAME COLUMNS. 00039 * CGERC T PUT F FOR NO TEST. SAME COLUMNS. 00040 * CGERU T PUT F FOR NO TEST. SAME COLUMNS. 00041 * CHER T PUT F FOR NO TEST. SAME COLUMNS. 00042 * CHPR T PUT F FOR NO TEST. SAME COLUMNS. 00043 * CHER2 T PUT F FOR NO TEST. SAME COLUMNS. 00044 * CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. 00045 * 00046 * See: 00047 * 00048 * Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. 00049 * An extended set of Fortran Basic Linear Algebra Subprograms. 00050 * 00051 * Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics 00052 * and Computer Science Division, Argonne National Laboratory, 00053 * 9700 South Cass Avenue, Argonne, Illinois 60439, US. 00054 * 00055 * Or 00056 * 00057 * NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms 00058 * Group Ltd., NAG Central Office, 256 Banbury Road, Oxford 00059 * OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st 00060 * Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. 00061 * 00062 * 00063 * -- Written on 10-August-1987. 00064 * Richard Hanson, Sandia National Labs. 00065 * Jeremy Du Croz, NAG Central Office. 00066 * 00067 * 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers 00068 * can be run multiple times without deleting generated 00069 * output files (susan) 00070 * 00071 * .. Parameters .. 00072 INTEGER NIN 00073 PARAMETER ( NIN = 5 ) 00074 INTEGER NSUBS 00075 PARAMETER ( NSUBS = 17 ) 00076 COMPLEX ZERO, ONE 00077 PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 00078 REAL RZERO, RHALF, RONE 00079 PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 ) 00080 INTEGER NMAX, INCMAX 00081 PARAMETER ( NMAX = 65, INCMAX = 2 ) 00082 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX 00083 PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, 00084 $ NALMAX = 7, NBEMAX = 7 ) 00085 * .. Local Scalars .. 00086 REAL EPS, ERR, THRESH 00087 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, 00088 $ NOUT, NTRA 00089 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, 00090 $ TSTERR 00091 CHARACTER*1 TRANS 00092 CHARACTER*6 SNAMET 00093 CHARACTER*32 SNAPS, SUMMRY 00094 * .. Local Arrays .. 00095 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), 00096 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), 00097 $ X( NMAX ), XS( NMAX*INCMAX ), 00098 $ XX( NMAX*INCMAX ), Y( NMAX ), 00099 $ YS( NMAX*INCMAX ), YT( NMAX ), 00100 $ YY( NMAX*INCMAX ), Z( 2*NMAX ) 00101 REAL G( NMAX ) 00102 INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) 00103 LOGICAL LTEST( NSUBS ) 00104 CHARACTER*6 SNAMES( NSUBS ) 00105 * .. External Functions .. 00106 REAL SDIFF 00107 LOGICAL LCE 00108 EXTERNAL SDIFF, LCE 00109 * .. External Subroutines .. 00110 EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, 00111 $ CCHKE, CMVCH 00112 * .. Intrinsic Functions .. 00113 INTRINSIC ABS, MAX, MIN 00114 * .. Scalars in Common .. 00115 INTEGER INFOT, NOUTC 00116 LOGICAL LERR, OK 00117 CHARACTER*6 SRNAMT 00118 * .. Common blocks .. 00119 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00120 COMMON /SRNAMC/SRNAMT 00121 * .. Data statements .. 00122 DATA SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ', 00123 $ 'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ', 00124 $ 'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ', 00125 $ 'CGERU ', 'CHER ', 'CHPR ', 'CHER2 ', 00126 $ 'CHPR2 '/ 00127 * .. Executable Statements .. 00128 * 00129 * Read name and unit number for summary output file and open file. 00130 * 00131 READ( NIN, FMT = * )SUMMRY 00132 READ( NIN, FMT = * )NOUT 00133 OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) 00134 NOUTC = NOUT 00135 * 00136 * Read name and unit number for snapshot output file and open file. 00137 * 00138 READ( NIN, FMT = * )SNAPS 00139 READ( NIN, FMT = * )NTRA 00140 TRACE = NTRA.GE.0 00141 IF( TRACE )THEN 00142 OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) 00143 END IF 00144 * Read the flag that directs rewinding of the snapshot file. 00145 READ( NIN, FMT = * )REWI 00146 REWI = REWI.AND.TRACE 00147 * Read the flag that directs stopping on any failure. 00148 READ( NIN, FMT = * )SFATAL 00149 * Read the flag that indicates whether error exits are to be tested. 00150 READ( NIN, FMT = * )TSTERR 00151 * Read the threshold value of the test ratio 00152 READ( NIN, FMT = * )THRESH 00153 * 00154 * Read and check the parameter values for the tests. 00155 * 00156 * Values of N 00157 READ( NIN, FMT = * )NIDIM 00158 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN 00159 WRITE( NOUT, FMT = 9997 )'N', NIDMAX 00160 GO TO 230 00161 END IF 00162 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) 00163 DO 10 I = 1, NIDIM 00164 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN 00165 WRITE( NOUT, FMT = 9996 )NMAX 00166 GO TO 230 00167 END IF 00168 10 CONTINUE 00169 * Values of K 00170 READ( NIN, FMT = * )NKB 00171 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN 00172 WRITE( NOUT, FMT = 9997 )'K', NKBMAX 00173 GO TO 230 00174 END IF 00175 READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) 00176 DO 20 I = 1, NKB 00177 IF( KB( I ).LT.0 )THEN 00178 WRITE( NOUT, FMT = 9995 ) 00179 GO TO 230 00180 END IF 00181 20 CONTINUE 00182 * Values of INCX and INCY 00183 READ( NIN, FMT = * )NINC 00184 IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN 00185 WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX 00186 GO TO 230 00187 END IF 00188 READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) 00189 DO 30 I = 1, NINC 00190 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN 00191 WRITE( NOUT, FMT = 9994 )INCMAX 00192 GO TO 230 00193 END IF 00194 30 CONTINUE 00195 * Values of ALPHA 00196 READ( NIN, FMT = * )NALF 00197 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN 00198 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX 00199 GO TO 230 00200 END IF 00201 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) 00202 * Values of BETA 00203 READ( NIN, FMT = * )NBET 00204 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN 00205 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX 00206 GO TO 230 00207 END IF 00208 READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) 00209 * 00210 * Report values of parameters. 00211 * 00212 WRITE( NOUT, FMT = 9993 ) 00213 WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) 00214 WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) 00215 WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) 00216 WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) 00217 WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) 00218 IF( .NOT.TSTERR )THEN 00219 WRITE( NOUT, FMT = * ) 00220 WRITE( NOUT, FMT = 9980 ) 00221 END IF 00222 WRITE( NOUT, FMT = * ) 00223 WRITE( NOUT, FMT = 9999 )THRESH 00224 WRITE( NOUT, FMT = * ) 00225 * 00226 * Read names of subroutines and flags which indicate 00227 * whether they are to be tested. 00228 * 00229 DO 40 I = 1, NSUBS 00230 LTEST( I ) = .FALSE. 00231 40 CONTINUE 00232 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT 00233 DO 60 I = 1, NSUBS 00234 IF( SNAMET.EQ.SNAMES( I ) ) 00235 $ GO TO 70 00236 60 CONTINUE 00237 WRITE( NOUT, FMT = 9986 )SNAMET 00238 STOP 00239 70 LTEST( I ) = LTESTT 00240 GO TO 50 00241 * 00242 80 CONTINUE 00243 CLOSE ( NIN ) 00244 * 00245 * Compute EPS (the machine precision). 00246 * 00247 EPS = RONE 00248 90 CONTINUE 00249 IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO ) 00250 $ GO TO 100 00251 EPS = RHALF*EPS 00252 GO TO 90 00253 100 CONTINUE 00254 EPS = EPS + EPS 00255 WRITE( NOUT, FMT = 9998 )EPS 00256 * 00257 * Check the reliability of CMVCH using exact data. 00258 * 00259 N = MIN( 32, NMAX ) 00260 DO 120 J = 1, N 00261 DO 110 I = 1, N 00262 A( I, J ) = MAX( I - J + 1, 0 ) 00263 110 CONTINUE 00264 X( J ) = J 00265 Y( J ) = ZERO 00266 120 CONTINUE 00267 DO 130 J = 1, N 00268 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 00269 130 CONTINUE 00270 * YY holds the exact result. On exit from CMVCH YT holds 00271 * the result computed by CMVCH. 00272 TRANS = 'N' 00273 CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, 00274 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 00275 SAME = LCE( YY, YT, N ) 00276 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN 00277 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 00278 STOP 00279 END IF 00280 TRANS = 'T' 00281 CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, 00282 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 00283 SAME = LCE( YY, YT, N ) 00284 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN 00285 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 00286 STOP 00287 END IF 00288 * 00289 * Test each subroutine in turn. 00290 * 00291 DO 210 ISNUM = 1, NSUBS 00292 WRITE( NOUT, FMT = * ) 00293 IF( .NOT.LTEST( ISNUM ) )THEN 00294 * Subprogram is not to be tested. 00295 WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) 00296 ELSE 00297 SRNAMT = SNAMES( ISNUM ) 00298 * Test error exits. 00299 IF( TSTERR )THEN 00300 CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) 00301 WRITE( NOUT, FMT = * ) 00302 END IF 00303 * Test computations. 00304 INFOT = 0 00305 OK = .TRUE. 00306 FATAL = .FALSE. 00307 GO TO ( 140, 140, 150, 150, 150, 160, 160, 00308 $ 160, 160, 160, 160, 170, 170, 180, 00309 $ 180, 190, 190 )ISNUM 00310 * Test CGEMV, 01, and CGBMV, 02. 00311 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00312 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 00313 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 00314 $ X, XX, XS, Y, YY, YS, YT, G ) 00315 GO TO 200 00316 * Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. 00317 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00318 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 00319 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 00320 $ X, XX, XS, Y, YY, YS, YT, G ) 00321 GO TO 200 00322 * Test CTRMV, 06, CTBMV, 07, CTPMV, 08, 00323 * CTRSV, 09, CTBSV, 10, and CTPSV, 11. 00324 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00325 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, 00326 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) 00327 GO TO 200 00328 * Test CGERC, 12, CGERU, 13. 00329 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00330 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00331 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00332 $ YT, G, Z ) 00333 GO TO 200 00334 * Test CHER, 14, and CHPR, 15. 00335 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00336 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00337 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00338 $ YT, G, Z ) 00339 GO TO 200 00340 * Test CHER2, 16, and CHPR2, 17. 00341 190 CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 00342 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 00343 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 00344 $ YT, G, Z ) 00345 * 00346 200 IF( FATAL.AND.SFATAL ) 00347 $ GO TO 220 00348 END IF 00349 210 CONTINUE 00350 WRITE( NOUT, FMT = 9982 ) 00351 GO TO 240 00352 * 00353 220 CONTINUE 00354 WRITE( NOUT, FMT = 9981 ) 00355 GO TO 240 00356 * 00357 230 CONTINUE 00358 WRITE( NOUT, FMT = 9987 ) 00359 * 00360 240 CONTINUE 00361 IF( TRACE ) 00362 $ CLOSE ( NTRA ) 00363 CLOSE ( NOUT ) 00364 STOP 00365 * 00366 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', 00367 $ 'S THAN', F8.2 ) 00368 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 00369 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', 00370 $ 'THAN ', I2 ) 00371 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 00372 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) 00373 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', 00374 $ I2 ) 00375 9993 FORMAT( ' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', 00376 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 00377 9992 FORMAT( ' FOR N ', 9I6 ) 00378 9991 FORMAT( ' FOR K ', 7I6 ) 00379 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) 00380 9989 FORMAT( ' FOR ALPHA ', 00381 $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 00382 9988 FORMAT( ' FOR BETA ', 00383 $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 00384 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', 00385 $ /' ******* TESTS ABANDONED *******' ) 00386 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', 00387 $ 'ESTS ABANDONED *******' ) 00388 9985 FORMAT( ' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', 00389 $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, 00390 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / 00391 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' 00392 $ , /' ******* TESTS ABANDONED *******' ) 00393 9984 FORMAT( A6, L2 ) 00394 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 00395 9982 FORMAT( /' END OF TESTS' ) 00396 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 00397 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 00398 * 00399 * End of CBLAT2. 00400 * 00401 END 00402 SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 00403 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 00404 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 00405 $ XS, Y, YY, YS, YT, G ) 00406 * 00407 * Tests CGEMV and CGBMV. 00408 * 00409 * Auxiliary routine for test program for Level 2 Blas. 00410 * 00411 * -- Written on 10-August-1987. 00412 * Richard Hanson, Sandia National Labs. 00413 * Jeremy Du Croz, NAG Central Office. 00414 * 00415 * .. Parameters .. 00416 COMPLEX ZERO, HALF 00417 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) 00418 REAL RZERO 00419 PARAMETER ( RZERO = 0.0 ) 00420 * .. Scalar Arguments .. 00421 REAL EPS, THRESH 00422 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 00423 $ NOUT, NTRA 00424 LOGICAL FATAL, REWI, TRACE 00425 CHARACTER*6 SNAME 00426 * .. Array Arguments .. 00427 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 00428 $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), 00429 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 00430 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 00431 $ YY( NMAX*INCMAX ) 00432 REAL G( NMAX ) 00433 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 00434 * .. Local Scalars .. 00435 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL 00436 REAL ERR, ERRMAX 00437 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, 00438 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, 00439 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, 00440 $ NL, NS 00441 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN 00442 CHARACTER*1 TRANS, TRANSS 00443 CHARACTER*3 ICH 00444 * .. Local Arrays .. 00445 LOGICAL ISAME( 13 ) 00446 * .. External Functions .. 00447 LOGICAL LCE, LCERES 00448 EXTERNAL LCE, LCERES 00449 * .. External Subroutines .. 00450 EXTERNAL CGBMV, CGEMV, CMAKE, CMVCH 00451 * .. Intrinsic Functions .. 00452 INTRINSIC ABS, MAX, MIN 00453 * .. Scalars in Common .. 00454 INTEGER INFOT, NOUTC 00455 LOGICAL LERR, OK 00456 * .. Common blocks .. 00457 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00458 * .. Data statements .. 00459 DATA ICH/'NTC'/ 00460 * .. Executable Statements .. 00461 FULL = SNAME( 3: 3 ).EQ.'E' 00462 BANDED = SNAME( 3: 3 ).EQ.'B' 00463 * Define the number of arguments. 00464 IF( FULL )THEN 00465 NARGS = 11 00466 ELSE IF( BANDED )THEN 00467 NARGS = 13 00468 END IF 00469 * 00470 NC = 0 00471 RESET = .TRUE. 00472 ERRMAX = RZERO 00473 * 00474 DO 120 IN = 1, NIDIM 00475 N = IDIM( IN ) 00476 ND = N/2 + 1 00477 * 00478 DO 110 IM = 1, 2 00479 IF( IM.EQ.1 ) 00480 $ M = MAX( N - ND, 0 ) 00481 IF( IM.EQ.2 ) 00482 $ M = MIN( N + ND, NMAX ) 00483 * 00484 IF( BANDED )THEN 00485 NK = NKB 00486 ELSE 00487 NK = 1 00488 END IF 00489 DO 100 IKU = 1, NK 00490 IF( BANDED )THEN 00491 KU = KB( IKU ) 00492 KL = MAX( KU - 1, 0 ) 00493 ELSE 00494 KU = N - 1 00495 KL = M - 1 00496 END IF 00497 * Set LDA to 1 more than minimum value if room. 00498 IF( BANDED )THEN 00499 LDA = KL + KU + 1 00500 ELSE 00501 LDA = M 00502 END IF 00503 IF( LDA.LT.NMAX ) 00504 $ LDA = LDA + 1 00505 * Skip tests if not enough room. 00506 IF( LDA.GT.NMAX ) 00507 $ GO TO 100 00508 LAA = LDA*N 00509 NULL = N.LE.0.OR.M.LE.0 00510 * 00511 * Generate the matrix A. 00512 * 00513 TRANSL = ZERO 00514 CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, 00515 $ LDA, KL, KU, RESET, TRANSL ) 00516 * 00517 DO 90 IC = 1, 3 00518 TRANS = ICH( IC: IC ) 00519 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 00520 * 00521 IF( TRAN )THEN 00522 ML = N 00523 NL = M 00524 ELSE 00525 ML = M 00526 NL = N 00527 END IF 00528 * 00529 DO 80 IX = 1, NINC 00530 INCX = INC( IX ) 00531 LX = ABS( INCX )*NL 00532 * 00533 * Generate the vector X. 00534 * 00535 TRANSL = HALF 00536 CALL CMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, 00537 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) 00538 IF( NL.GT.1 )THEN 00539 X( NL/2 ) = ZERO 00540 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO 00541 END IF 00542 * 00543 DO 70 IY = 1, NINC 00544 INCY = INC( IY ) 00545 LY = ABS( INCY )*ML 00546 * 00547 DO 60 IA = 1, NALF 00548 ALPHA = ALF( IA ) 00549 * 00550 DO 50 IB = 1, NBET 00551 BETA = BET( IB ) 00552 * 00553 * Generate the vector Y. 00554 * 00555 TRANSL = ZERO 00556 CALL CMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, 00557 $ YY, ABS( INCY ), 0, ML - 1, 00558 $ RESET, TRANSL ) 00559 * 00560 NC = NC + 1 00561 * 00562 * Save every datum before calling the 00563 * subroutine. 00564 * 00565 TRANSS = TRANS 00566 MS = M 00567 NS = N 00568 KLS = KL 00569 KUS = KU 00570 ALS = ALPHA 00571 DO 10 I = 1, LAA 00572 AS( I ) = AA( I ) 00573 10 CONTINUE 00574 LDAS = LDA 00575 DO 20 I = 1, LX 00576 XS( I ) = XX( I ) 00577 20 CONTINUE 00578 INCXS = INCX 00579 BLS = BETA 00580 DO 30 I = 1, LY 00581 YS( I ) = YY( I ) 00582 30 CONTINUE 00583 INCYS = INCY 00584 * 00585 * Call the subroutine. 00586 * 00587 IF( FULL )THEN 00588 IF( TRACE ) 00589 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 00590 $ TRANS, M, N, ALPHA, LDA, INCX, BETA, 00591 $ INCY 00592 IF( REWI ) 00593 $ REWIND NTRA 00594 CALL CGEMV( TRANS, M, N, ALPHA, AA, 00595 $ LDA, XX, INCX, BETA, YY, 00596 $ INCY ) 00597 ELSE IF( BANDED )THEN 00598 IF( TRACE ) 00599 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 00600 $ TRANS, M, N, KL, KU, ALPHA, LDA, 00601 $ INCX, BETA, INCY 00602 IF( REWI ) 00603 $ REWIND NTRA 00604 CALL CGBMV( TRANS, M, N, KL, KU, ALPHA, 00605 $ AA, LDA, XX, INCX, BETA, 00606 $ YY, INCY ) 00607 END IF 00608 * 00609 * Check if error-exit was taken incorrectly. 00610 * 00611 IF( .NOT.OK )THEN 00612 WRITE( NOUT, FMT = 9993 ) 00613 FATAL = .TRUE. 00614 GO TO 130 00615 END IF 00616 * 00617 * See what data changed inside subroutines. 00618 * 00619 ISAME( 1 ) = TRANS.EQ.TRANSS 00620 ISAME( 2 ) = MS.EQ.M 00621 ISAME( 3 ) = NS.EQ.N 00622 IF( FULL )THEN 00623 ISAME( 4 ) = ALS.EQ.ALPHA 00624 ISAME( 5 ) = LCE( AS, AA, LAA ) 00625 ISAME( 6 ) = LDAS.EQ.LDA 00626 ISAME( 7 ) = LCE( XS, XX, LX ) 00627 ISAME( 8 ) = INCXS.EQ.INCX 00628 ISAME( 9 ) = BLS.EQ.BETA 00629 IF( NULL )THEN 00630 ISAME( 10 ) = LCE( YS, YY, LY ) 00631 ELSE 00632 ISAME( 10 ) = LCERES( 'GE', ' ', 1, 00633 $ ML, YS, YY, 00634 $ ABS( INCY ) ) 00635 END IF 00636 ISAME( 11 ) = INCYS.EQ.INCY 00637 ELSE IF( BANDED )THEN 00638 ISAME( 4 ) = KLS.EQ.KL 00639 ISAME( 5 ) = KUS.EQ.KU 00640 ISAME( 6 ) = ALS.EQ.ALPHA 00641 ISAME( 7 ) = LCE( AS, AA, LAA ) 00642 ISAME( 8 ) = LDAS.EQ.LDA 00643 ISAME( 9 ) = LCE( XS, XX, LX ) 00644 ISAME( 10 ) = INCXS.EQ.INCX 00645 ISAME( 11 ) = BLS.EQ.BETA 00646 IF( NULL )THEN 00647 ISAME( 12 ) = LCE( YS, YY, LY ) 00648 ELSE 00649 ISAME( 12 ) = LCERES( 'GE', ' ', 1, 00650 $ ML, YS, YY, 00651 $ ABS( INCY ) ) 00652 END IF 00653 ISAME( 13 ) = INCYS.EQ.INCY 00654 END IF 00655 * 00656 * If data was incorrectly changed, report 00657 * and return. 00658 * 00659 SAME = .TRUE. 00660 DO 40 I = 1, NARGS 00661 SAME = SAME.AND.ISAME( I ) 00662 IF( .NOT.ISAME( I ) ) 00663 $ WRITE( NOUT, FMT = 9998 )I 00664 40 CONTINUE 00665 IF( .NOT.SAME )THEN 00666 FATAL = .TRUE. 00667 GO TO 130 00668 END IF 00669 * 00670 IF( .NOT.NULL )THEN 00671 * 00672 * Check the result. 00673 * 00674 CALL CMVCH( TRANS, M, N, ALPHA, A, 00675 $ NMAX, X, INCX, BETA, Y, 00676 $ INCY, YT, G, YY, EPS, ERR, 00677 $ FATAL, NOUT, .TRUE. ) 00678 ERRMAX = MAX( ERRMAX, ERR ) 00679 * If got really bad answer, report and 00680 * return. 00681 IF( FATAL ) 00682 $ GO TO 130 00683 ELSE 00684 * Avoid repeating tests with M.le.0 or 00685 * N.le.0. 00686 GO TO 110 00687 END IF 00688 * 00689 50 CONTINUE 00690 * 00691 60 CONTINUE 00692 * 00693 70 CONTINUE 00694 * 00695 80 CONTINUE 00696 * 00697 90 CONTINUE 00698 * 00699 100 CONTINUE 00700 * 00701 110 CONTINUE 00702 * 00703 120 CONTINUE 00704 * 00705 * Report result. 00706 * 00707 IF( ERRMAX.LT.THRESH )THEN 00708 WRITE( NOUT, FMT = 9999 )SNAME, NC 00709 ELSE 00710 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 00711 END IF 00712 GO TO 140 00713 * 00714 130 CONTINUE 00715 WRITE( NOUT, FMT = 9996 )SNAME 00716 IF( FULL )THEN 00717 WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, 00718 $ INCX, BETA, INCY 00719 ELSE IF( BANDED )THEN 00720 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, 00721 $ ALPHA, LDA, INCX, BETA, INCY 00722 END IF 00723 * 00724 140 CONTINUE 00725 RETURN 00726 * 00727 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 00728 $ 'S)' ) 00729 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 00730 $ 'ANGED INCORRECTLY *******' ) 00731 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 00732 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 00733 $ ' - SUSPECT *******' ) 00734 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 00735 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', 00736 $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 00737 $ F4.1, '), Y,', I2, ') .' ) 00738 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', 00739 $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 00740 $ F4.1, '), Y,', I2, ') .' ) 00741 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 00742 $ '******' ) 00743 * 00744 * End of CCHK1. 00745 * 00746 END 00747 SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 00748 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 00749 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 00750 $ XS, Y, YY, YS, YT, G ) 00751 * 00752 * Tests CHEMV, CHBMV and CHPMV. 00753 * 00754 * Auxiliary routine for test program for Level 2 Blas. 00755 * 00756 * -- Written on 10-August-1987. 00757 * Richard Hanson, Sandia National Labs. 00758 * Jeremy Du Croz, NAG Central Office. 00759 * 00760 * .. Parameters .. 00761 COMPLEX ZERO, HALF 00762 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) 00763 REAL RZERO 00764 PARAMETER ( RZERO = 0.0 ) 00765 * .. Scalar Arguments .. 00766 REAL EPS, THRESH 00767 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 00768 $ NOUT, NTRA 00769 LOGICAL FATAL, REWI, TRACE 00770 CHARACTER*6 SNAME 00771 * .. Array Arguments .. 00772 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 00773 $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), 00774 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 00775 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 00776 $ YY( NMAX*INCMAX ) 00777 REAL G( NMAX ) 00778 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 00779 * .. Local Scalars .. 00780 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL 00781 REAL ERR, ERRMAX 00782 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, 00783 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, 00784 $ N, NARGS, NC, NK, NS 00785 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 00786 CHARACTER*1 UPLO, UPLOS 00787 CHARACTER*2 ICH 00788 * .. Local Arrays .. 00789 LOGICAL ISAME( 13 ) 00790 * .. External Functions .. 00791 LOGICAL LCE, LCERES 00792 EXTERNAL LCE, LCERES 00793 * .. External Subroutines .. 00794 EXTERNAL CHBMV, CHEMV, CHPMV, CMAKE, CMVCH 00795 * .. Intrinsic Functions .. 00796 INTRINSIC ABS, MAX 00797 * .. Scalars in Common .. 00798 INTEGER INFOT, NOUTC 00799 LOGICAL LERR, OK 00800 * .. Common blocks .. 00801 COMMON /INFOC/INFOT, NOUTC, OK, LERR 00802 * .. Data statements .. 00803 DATA ICH/'UL'/ 00804 * .. Executable Statements .. 00805 FULL = SNAME( 3: 3 ).EQ.'E' 00806 BANDED = SNAME( 3: 3 ).EQ.'B' 00807 PACKED = SNAME( 3: 3 ).EQ.'P' 00808 * Define the number of arguments. 00809 IF( FULL )THEN 00810 NARGS = 10 00811 ELSE IF( BANDED )THEN 00812 NARGS = 11 00813 ELSE IF( PACKED )THEN 00814 NARGS = 9 00815 END IF 00816 * 00817 NC = 0 00818 RESET = .TRUE. 00819 ERRMAX = RZERO 00820 * 00821 DO 110 IN = 1, NIDIM 00822 N = IDIM( IN ) 00823 * 00824 IF( BANDED )THEN 00825 NK = NKB 00826 ELSE 00827 NK = 1 00828 END IF 00829 DO 100 IK = 1, NK 00830 IF( BANDED )THEN 00831 K = KB( IK ) 00832 ELSE 00833 K = N - 1 00834 END IF 00835 * Set LDA to 1 more than minimum value if room. 00836 IF( BANDED )THEN 00837 LDA = K + 1 00838 ELSE 00839 LDA = N 00840 END IF 00841 IF( LDA.LT.NMAX ) 00842 $ LDA = LDA + 1 00843 * Skip tests if not enough room. 00844 IF( LDA.GT.NMAX ) 00845 $ GO TO 100 00846 IF( PACKED )THEN 00847 LAA = ( N*( N + 1 ) )/2 00848 ELSE 00849 LAA = LDA*N 00850 END IF 00851 NULL = N.LE.0 00852 * 00853 DO 90 IC = 1, 2 00854 UPLO = ICH( IC: IC ) 00855 * 00856 * Generate the matrix A. 00857 * 00858 TRANSL = ZERO 00859 CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, 00860 $ LDA, K, K, RESET, TRANSL ) 00861 * 00862 DO 80 IX = 1, NINC 00863 INCX = INC( IX ) 00864 LX = ABS( INCX )*N 00865 * 00866 * Generate the vector X. 00867 * 00868 TRANSL = HALF 00869 CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 00870 $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) 00871 IF( N.GT.1 )THEN 00872 X( N/2 ) = ZERO 00873 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 00874 END IF 00875 * 00876 DO 70 IY = 1, NINC 00877 INCY = INC( IY ) 00878 LY = ABS( INCY )*N 00879 * 00880 DO 60 IA = 1, NALF 00881 ALPHA = ALF( IA ) 00882 * 00883 DO 50 IB = 1, NBET 00884 BETA = BET( IB ) 00885 * 00886 * Generate the vector Y. 00887 * 00888 TRANSL = ZERO 00889 CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 00890 $ ABS( INCY ), 0, N - 1, RESET, 00891 $ TRANSL ) 00892 * 00893 NC = NC + 1 00894 * 00895 * Save every datum before calling the 00896 * subroutine. 00897 * 00898 UPLOS = UPLO 00899 NS = N 00900 KS = K 00901 ALS = ALPHA 00902 DO 10 I = 1, LAA 00903 AS( I ) = AA( I ) 00904 10 CONTINUE 00905 LDAS = LDA 00906 DO 20 I = 1, LX 00907 XS( I ) = XX( I ) 00908 20 CONTINUE 00909 INCXS = INCX 00910 BLS = BETA 00911 DO 30 I = 1, LY 00912 YS( I ) = YY( I ) 00913 30 CONTINUE 00914 INCYS = INCY 00915 * 00916 * Call the subroutine. 00917 * 00918 IF( FULL )THEN 00919 IF( TRACE ) 00920 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 00921 $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY 00922 IF( REWI ) 00923 $ REWIND NTRA 00924 CALL CHEMV( UPLO, N, ALPHA, AA, LDA, XX, 00925 $ INCX, BETA, YY, INCY ) 00926 ELSE IF( BANDED )THEN 00927 IF( TRACE ) 00928 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 00929 $ UPLO, N, K, ALPHA, LDA, INCX, BETA, 00930 $ INCY 00931 IF( REWI ) 00932 $ REWIND NTRA 00933 CALL CHBMV( UPLO, N, K, ALPHA, AA, LDA, 00934 $ XX, INCX, BETA, YY, INCY ) 00935 ELSE IF( PACKED )THEN 00936 IF( TRACE ) 00937 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 00938 $ UPLO, N, ALPHA, INCX, BETA, INCY 00939 IF( REWI ) 00940 $ REWIND NTRA 00941 CALL CHPMV( UPLO, N, ALPHA, AA, XX, INCX, 00942 $ BETA, YY, INCY ) 00943 END IF 00944 * 00945 * Check if error-exit was taken incorrectly. 00946 * 00947 IF( .NOT.OK )THEN 00948 WRITE( NOUT, FMT = 9992 ) 00949 FATAL = .TRUE. 00950 GO TO 120 00951 END IF 00952 * 00953 * See what data changed inside subroutines. 00954 * 00955 ISAME( 1 ) = UPLO.EQ.UPLOS 00956 ISAME( 2 ) = NS.EQ.N 00957 IF( FULL )THEN 00958 ISAME( 3 ) = ALS.EQ.ALPHA 00959 ISAME( 4 ) = LCE( AS, AA, LAA ) 00960 ISAME( 5 ) = LDAS.EQ.LDA 00961 ISAME( 6 ) = LCE( XS, XX, LX ) 00962 ISAME( 7 ) = INCXS.EQ.INCX 00963 ISAME( 8 ) = BLS.EQ.BETA 00964 IF( NULL )THEN 00965 ISAME( 9 ) = LCE( YS, YY, LY ) 00966 ELSE 00967 ISAME( 9 ) = LCERES( 'GE', ' ', 1, N, 00968 $ YS, YY, ABS( INCY ) ) 00969 END IF 00970 ISAME( 10 ) = INCYS.EQ.INCY 00971 ELSE IF( BANDED )THEN 00972 ISAME( 3 ) = KS.EQ.K 00973 ISAME( 4 ) = ALS.EQ.ALPHA 00974 ISAME( 5 ) = LCE( AS, AA, LAA ) 00975 ISAME( 6 ) = LDAS.EQ.LDA 00976 ISAME( 7 ) = LCE( XS, XX, LX ) 00977 ISAME( 8 ) = INCXS.EQ.INCX 00978 ISAME( 9 ) = BLS.EQ.BETA 00979 IF( NULL )THEN 00980 ISAME( 10 ) = LCE( YS, YY, LY ) 00981 ELSE 00982 ISAME( 10 ) = LCERES( 'GE', ' ', 1, N, 00983 $ YS, YY, ABS( INCY ) ) 00984 END IF 00985 ISAME( 11 ) = INCYS.EQ.INCY 00986 ELSE IF( PACKED )THEN 00987 ISAME( 3 ) = ALS.EQ.ALPHA 00988 ISAME( 4 ) = LCE( AS, AA, LAA ) 00989 ISAME( 5 ) = LCE( XS, XX, LX ) 00990 ISAME( 6 ) = INCXS.EQ.INCX 00991 ISAME( 7 ) = BLS.EQ.BETA 00992 IF( NULL )THEN 00993 ISAME( 8 ) = LCE( YS, YY, LY ) 00994 ELSE 00995 ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, 00996 $ YS, YY, ABS( INCY ) ) 00997 END IF 00998 ISAME( 9 ) = INCYS.EQ.INCY 00999 END IF 01000 * 01001 * If data was incorrectly changed, report and 01002 * return. 01003 * 01004 SAME = .TRUE. 01005 DO 40 I = 1, NARGS 01006 SAME = SAME.AND.ISAME( I ) 01007 IF( .NOT.ISAME( I ) ) 01008 $ WRITE( NOUT, FMT = 9998 )I 01009 40 CONTINUE 01010 IF( .NOT.SAME )THEN 01011 FATAL = .TRUE. 01012 GO TO 120 01013 END IF 01014 * 01015 IF( .NOT.NULL )THEN 01016 * 01017 * Check the result. 01018 * 01019 CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X, 01020 $ INCX, BETA, Y, INCY, YT, G, 01021 $ YY, EPS, ERR, FATAL, NOUT, 01022 $ .TRUE. ) 01023 ERRMAX = MAX( ERRMAX, ERR ) 01024 * If got really bad answer, report and 01025 * return. 01026 IF( FATAL ) 01027 $ GO TO 120 01028 ELSE 01029 * Avoid repeating tests with N.le.0 01030 GO TO 110 01031 END IF 01032 * 01033 50 CONTINUE 01034 * 01035 60 CONTINUE 01036 * 01037 70 CONTINUE 01038 * 01039 80 CONTINUE 01040 * 01041 90 CONTINUE 01042 * 01043 100 CONTINUE 01044 * 01045 110 CONTINUE 01046 * 01047 * Report result. 01048 * 01049 IF( ERRMAX.LT.THRESH )THEN 01050 WRITE( NOUT, FMT = 9999 )SNAME, NC 01051 ELSE 01052 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01053 END IF 01054 GO TO 130 01055 * 01056 120 CONTINUE 01057 WRITE( NOUT, FMT = 9996 )SNAME 01058 IF( FULL )THEN 01059 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, 01060 $ BETA, INCY 01061 ELSE IF( BANDED )THEN 01062 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, 01063 $ INCX, BETA, INCY 01064 ELSE IF( PACKED )THEN 01065 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, 01066 $ BETA, INCY 01067 END IF 01068 * 01069 130 CONTINUE 01070 RETURN 01071 * 01072 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01073 $ 'S)' ) 01074 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01075 $ 'ANGED INCORRECTLY *******' ) 01076 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01077 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01078 $ ' - SUSPECT *******' ) 01079 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01080 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 01081 $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, 01082 $ ') .' ) 01083 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', 01084 $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 01085 $ F4.1, '), Y,', I2, ') .' ) 01086 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 01087 $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', 01088 $ 'Y,', I2, ') .' ) 01089 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01090 $ '******' ) 01091 * 01092 * End of CCHK2. 01093 * 01094 END 01095 SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01096 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, 01097 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) 01098 * 01099 * Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. 01100 * 01101 * Auxiliary routine for test program for Level 2 Blas. 01102 * 01103 * -- Written on 10-August-1987. 01104 * Richard Hanson, Sandia National Labs. 01105 * Jeremy Du Croz, NAG Central Office. 01106 * 01107 * .. Parameters .. 01108 COMPLEX ZERO, HALF, ONE 01109 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 01110 $ ONE = ( 1.0, 0.0 ) ) 01111 REAL RZERO 01112 PARAMETER ( RZERO = 0.0 ) 01113 * .. Scalar Arguments .. 01114 REAL EPS, THRESH 01115 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA 01116 LOGICAL FATAL, REWI, TRACE 01117 CHARACTER*6 SNAME 01118 * .. Array Arguments .. 01119 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), 01120 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 01121 $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) 01122 REAL G( NMAX ) 01123 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 01124 * .. Local Scalars .. 01125 COMPLEX TRANSL 01126 REAL ERR, ERRMAX 01127 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, 01128 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS 01129 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 01130 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS 01131 CHARACTER*2 ICHD, ICHU 01132 CHARACTER*3 ICHT 01133 * .. Local Arrays .. 01134 LOGICAL ISAME( 13 ) 01135 * .. External Functions .. 01136 LOGICAL LCE, LCERES 01137 EXTERNAL LCE, LCERES 01138 * .. External Subroutines .. 01139 EXTERNAL CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, 01140 $ CTRMV, CTRSV 01141 * .. Intrinsic Functions .. 01142 INTRINSIC ABS, MAX 01143 * .. Scalars in Common .. 01144 INTEGER INFOT, NOUTC 01145 LOGICAL LERR, OK 01146 * .. Common blocks .. 01147 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01148 * .. Data statements .. 01149 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ 01150 * .. Executable Statements .. 01151 FULL = SNAME( 3: 3 ).EQ.'R' 01152 BANDED = SNAME( 3: 3 ).EQ.'B' 01153 PACKED = SNAME( 3: 3 ).EQ.'P' 01154 * Define the number of arguments. 01155 IF( FULL )THEN 01156 NARGS = 8 01157 ELSE IF( BANDED )THEN 01158 NARGS = 9 01159 ELSE IF( PACKED )THEN 01160 NARGS = 7 01161 END IF 01162 * 01163 NC = 0 01164 RESET = .TRUE. 01165 ERRMAX = RZERO 01166 * Set up zero vector for CMVCH. 01167 DO 10 I = 1, NMAX 01168 Z( I ) = ZERO 01169 10 CONTINUE 01170 * 01171 DO 110 IN = 1, NIDIM 01172 N = IDIM( IN ) 01173 * 01174 IF( BANDED )THEN 01175 NK = NKB 01176 ELSE 01177 NK = 1 01178 END IF 01179 DO 100 IK = 1, NK 01180 IF( BANDED )THEN 01181 K = KB( IK ) 01182 ELSE 01183 K = N - 1 01184 END IF 01185 * Set LDA to 1 more than minimum value if room. 01186 IF( BANDED )THEN 01187 LDA = K + 1 01188 ELSE 01189 LDA = N 01190 END IF 01191 IF( LDA.LT.NMAX ) 01192 $ LDA = LDA + 1 01193 * Skip tests if not enough room. 01194 IF( LDA.GT.NMAX ) 01195 $ GO TO 100 01196 IF( PACKED )THEN 01197 LAA = ( N*( N + 1 ) )/2 01198 ELSE 01199 LAA = LDA*N 01200 END IF 01201 NULL = N.LE.0 01202 * 01203 DO 90 ICU = 1, 2 01204 UPLO = ICHU( ICU: ICU ) 01205 * 01206 DO 80 ICT = 1, 3 01207 TRANS = ICHT( ICT: ICT ) 01208 * 01209 DO 70 ICD = 1, 2 01210 DIAG = ICHD( ICD: ICD ) 01211 * 01212 * Generate the matrix A. 01213 * 01214 TRANSL = ZERO 01215 CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, 01216 $ NMAX, AA, LDA, K, K, RESET, TRANSL ) 01217 * 01218 DO 60 IX = 1, NINC 01219 INCX = INC( IX ) 01220 LX = ABS( INCX )*N 01221 * 01222 * Generate the vector X. 01223 * 01224 TRANSL = HALF 01225 CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 01226 $ ABS( INCX ), 0, N - 1, RESET, 01227 $ TRANSL ) 01228 IF( N.GT.1 )THEN 01229 X( N/2 ) = ZERO 01230 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 01231 END IF 01232 * 01233 NC = NC + 1 01234 * 01235 * Save every datum before calling the subroutine. 01236 * 01237 UPLOS = UPLO 01238 TRANSS = TRANS 01239 DIAGS = DIAG 01240 NS = N 01241 KS = K 01242 DO 20 I = 1, LAA 01243 AS( I ) = AA( I ) 01244 20 CONTINUE 01245 LDAS = LDA 01246 DO 30 I = 1, LX 01247 XS( I ) = XX( I ) 01248 30 CONTINUE 01249 INCXS = INCX 01250 * 01251 * Call the subroutine. 01252 * 01253 IF( SNAME( 4: 5 ).EQ.'MV' )THEN 01254 IF( FULL )THEN 01255 IF( TRACE ) 01256 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 01257 $ UPLO, TRANS, DIAG, N, LDA, INCX 01258 IF( REWI ) 01259 $ REWIND NTRA 01260 CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA, 01261 $ XX, INCX ) 01262 ELSE IF( BANDED )THEN 01263 IF( TRACE ) 01264 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 01265 $ UPLO, TRANS, DIAG, N, K, LDA, INCX 01266 IF( REWI ) 01267 $ REWIND NTRA 01268 CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA, 01269 $ LDA, XX, INCX ) 01270 ELSE IF( PACKED )THEN 01271 IF( TRACE ) 01272 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 01273 $ UPLO, TRANS, DIAG, N, INCX 01274 IF( REWI ) 01275 $ REWIND NTRA 01276 CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX, 01277 $ INCX ) 01278 END IF 01279 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 01280 IF( FULL )THEN 01281 IF( TRACE ) 01282 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 01283 $ UPLO, TRANS, DIAG, N, LDA, INCX 01284 IF( REWI ) 01285 $ REWIND NTRA 01286 CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA, 01287 $ XX, INCX ) 01288 ELSE IF( BANDED )THEN 01289 IF( TRACE ) 01290 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 01291 $ UPLO, TRANS, DIAG, N, K, LDA, INCX 01292 IF( REWI ) 01293 $ REWIND NTRA 01294 CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA, 01295 $ LDA, XX, INCX ) 01296 ELSE IF( PACKED )THEN 01297 IF( TRACE ) 01298 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 01299 $ UPLO, TRANS, DIAG, N, INCX 01300 IF( REWI ) 01301 $ REWIND NTRA 01302 CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX, 01303 $ INCX ) 01304 END IF 01305 END IF 01306 * 01307 * Check if error-exit was taken incorrectly. 01308 * 01309 IF( .NOT.OK )THEN 01310 WRITE( NOUT, FMT = 9992 ) 01311 FATAL = .TRUE. 01312 GO TO 120 01313 END IF 01314 * 01315 * See what data changed inside subroutines. 01316 * 01317 ISAME( 1 ) = UPLO.EQ.UPLOS 01318 ISAME( 2 ) = TRANS.EQ.TRANSS 01319 ISAME( 3 ) = DIAG.EQ.DIAGS 01320 ISAME( 4 ) = NS.EQ.N 01321 IF( FULL )THEN 01322 ISAME( 5 ) = LCE( AS, AA, LAA ) 01323 ISAME( 6 ) = LDAS.EQ.LDA 01324 IF( NULL )THEN 01325 ISAME( 7 ) = LCE( XS, XX, LX ) 01326 ELSE 01327 ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS, 01328 $ XX, ABS( INCX ) ) 01329 END IF 01330 ISAME( 8 ) = INCXS.EQ.INCX 01331 ELSE IF( BANDED )THEN 01332 ISAME( 5 ) = KS.EQ.K 01333 ISAME( 6 ) = LCE( AS, AA, LAA ) 01334 ISAME( 7 ) = LDAS.EQ.LDA 01335 IF( NULL )THEN 01336 ISAME( 8 ) = LCE( XS, XX, LX ) 01337 ELSE 01338 ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS, 01339 $ XX, ABS( INCX ) ) 01340 END IF 01341 ISAME( 9 ) = INCXS.EQ.INCX 01342 ELSE IF( PACKED )THEN 01343 ISAME( 5 ) = LCE( AS, AA, LAA ) 01344 IF( NULL )THEN 01345 ISAME( 6 ) = LCE( XS, XX, LX ) 01346 ELSE 01347 ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS, 01348 $ XX, ABS( INCX ) ) 01349 END IF 01350 ISAME( 7 ) = INCXS.EQ.INCX 01351 END IF 01352 * 01353 * If data was incorrectly changed, report and 01354 * return. 01355 * 01356 SAME = .TRUE. 01357 DO 40 I = 1, NARGS 01358 SAME = SAME.AND.ISAME( I ) 01359 IF( .NOT.ISAME( I ) ) 01360 $ WRITE( NOUT, FMT = 9998 )I 01361 40 CONTINUE 01362 IF( .NOT.SAME )THEN 01363 FATAL = .TRUE. 01364 GO TO 120 01365 END IF 01366 * 01367 IF( .NOT.NULL )THEN 01368 IF( SNAME( 4: 5 ).EQ.'MV' )THEN 01369 * 01370 * Check the result. 01371 * 01372 CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 01373 $ INCX, ZERO, Z, INCX, XT, G, 01374 $ XX, EPS, ERR, FATAL, NOUT, 01375 $ .TRUE. ) 01376 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 01377 * 01378 * Compute approximation to original vector. 01379 * 01380 DO 50 I = 1, N 01381 Z( I ) = XX( 1 + ( I - 1 )* 01382 $ ABS( INCX ) ) 01383 XX( 1 + ( I - 1 )*ABS( INCX ) ) 01384 $ = X( I ) 01385 50 CONTINUE 01386 CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z, 01387 $ INCX, ZERO, X, INCX, XT, G, 01388 $ XX, EPS, ERR, FATAL, NOUT, 01389 $ .FALSE. ) 01390 END IF 01391 ERRMAX = MAX( ERRMAX, ERR ) 01392 * If got really bad answer, report and return. 01393 IF( FATAL ) 01394 $ GO TO 120 01395 ELSE 01396 * Avoid repeating tests with N.le.0. 01397 GO TO 110 01398 END IF 01399 * 01400 60 CONTINUE 01401 * 01402 70 CONTINUE 01403 * 01404 80 CONTINUE 01405 * 01406 90 CONTINUE 01407 * 01408 100 CONTINUE 01409 * 01410 110 CONTINUE 01411 * 01412 * Report result. 01413 * 01414 IF( ERRMAX.LT.THRESH )THEN 01415 WRITE( NOUT, FMT = 9999 )SNAME, NC 01416 ELSE 01417 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01418 END IF 01419 GO TO 130 01420 * 01421 120 CONTINUE 01422 WRITE( NOUT, FMT = 9996 )SNAME 01423 IF( FULL )THEN 01424 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, 01425 $ INCX 01426 ELSE IF( BANDED )THEN 01427 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, 01428 $ LDA, INCX 01429 ELSE IF( PACKED )THEN 01430 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX 01431 END IF 01432 * 01433 130 CONTINUE 01434 RETURN 01435 * 01436 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01437 $ 'S)' ) 01438 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01439 $ 'ANGED INCORRECTLY *******' ) 01440 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01441 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01442 $ ' - SUSPECT *******' ) 01443 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01444 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', 01445 $ 'X,', I2, ') .' ) 01446 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), 01447 $ ' A,', I3, ', X,', I2, ') .' ) 01448 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', 01449 $ I3, ', X,', I2, ') .' ) 01450 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01451 $ '******' ) 01452 * 01453 * End of CCHK3. 01454 * 01455 END 01456 SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01457 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 01458 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 01459 $ Z ) 01460 * 01461 * Tests CGERC and CGERU. 01462 * 01463 * Auxiliary routine for test program for Level 2 Blas. 01464 * 01465 * -- Written on 10-August-1987. 01466 * Richard Hanson, Sandia National Labs. 01467 * Jeremy Du Croz, NAG Central Office. 01468 * 01469 * .. Parameters .. 01470 COMPLEX ZERO, HALF, ONE 01471 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 01472 $ ONE = ( 1.0, 0.0 ) ) 01473 REAL RZERO 01474 PARAMETER ( RZERO = 0.0 ) 01475 * .. Scalar Arguments .. 01476 REAL EPS, THRESH 01477 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 01478 LOGICAL FATAL, REWI, TRACE 01479 CHARACTER*6 SNAME 01480 * .. Array Arguments .. 01481 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 01482 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 01483 $ XX( NMAX*INCMAX ), Y( NMAX ), 01484 $ YS( NMAX*INCMAX ), YT( NMAX ), 01485 $ YY( NMAX*INCMAX ), Z( NMAX ) 01486 REAL G( NMAX ) 01487 INTEGER IDIM( NIDIM ), INC( NINC ) 01488 * .. Local Scalars .. 01489 COMPLEX ALPHA, ALS, TRANSL 01490 REAL ERR, ERRMAX 01491 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, 01492 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, 01493 $ NC, ND, NS 01494 LOGICAL CONJ, NULL, RESET, SAME 01495 * .. Local Arrays .. 01496 COMPLEX W( 1 ) 01497 LOGICAL ISAME( 13 ) 01498 * .. External Functions .. 01499 LOGICAL LCE, LCERES 01500 EXTERNAL LCE, LCERES 01501 * .. External Subroutines .. 01502 EXTERNAL CGERC, CGERU, CMAKE, CMVCH 01503 * .. Intrinsic Functions .. 01504 INTRINSIC ABS, CONJG, MAX, MIN 01505 * .. Scalars in Common .. 01506 INTEGER INFOT, NOUTC 01507 LOGICAL LERR, OK 01508 * .. Common blocks .. 01509 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01510 * .. Executable Statements .. 01511 CONJ = SNAME( 5: 5 ).EQ.'C' 01512 * Define the number of arguments. 01513 NARGS = 9 01514 * 01515 NC = 0 01516 RESET = .TRUE. 01517 ERRMAX = RZERO 01518 * 01519 DO 120 IN = 1, NIDIM 01520 N = IDIM( IN ) 01521 ND = N/2 + 1 01522 * 01523 DO 110 IM = 1, 2 01524 IF( IM.EQ.1 ) 01525 $ M = MAX( N - ND, 0 ) 01526 IF( IM.EQ.2 ) 01527 $ M = MIN( N + ND, NMAX ) 01528 * 01529 * Set LDA to 1 more than minimum value if room. 01530 LDA = M 01531 IF( LDA.LT.NMAX ) 01532 $ LDA = LDA + 1 01533 * Skip tests if not enough room. 01534 IF( LDA.GT.NMAX ) 01535 $ GO TO 110 01536 LAA = LDA*N 01537 NULL = N.LE.0.OR.M.LE.0 01538 * 01539 DO 100 IX = 1, NINC 01540 INCX = INC( IX ) 01541 LX = ABS( INCX )*M 01542 * 01543 * Generate the vector X. 01544 * 01545 TRANSL = HALF 01546 CALL CMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), 01547 $ 0, M - 1, RESET, TRANSL ) 01548 IF( M.GT.1 )THEN 01549 X( M/2 ) = ZERO 01550 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO 01551 END IF 01552 * 01553 DO 90 IY = 1, NINC 01554 INCY = INC( IY ) 01555 LY = ABS( INCY )*N 01556 * 01557 * Generate the vector Y. 01558 * 01559 TRANSL = ZERO 01560 CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 01561 $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 01562 IF( N.GT.1 )THEN 01563 Y( N/2 ) = ZERO 01564 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 01565 END IF 01566 * 01567 DO 80 IA = 1, NALF 01568 ALPHA = ALF( IA ) 01569 * 01570 * Generate the matrix A. 01571 * 01572 TRANSL = ZERO 01573 CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, 01574 $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) 01575 * 01576 NC = NC + 1 01577 * 01578 * Save every datum before calling the subroutine. 01579 * 01580 MS = M 01581 NS = N 01582 ALS = ALPHA 01583 DO 10 I = 1, LAA 01584 AS( I ) = AA( I ) 01585 10 CONTINUE 01586 LDAS = LDA 01587 DO 20 I = 1, LX 01588 XS( I ) = XX( I ) 01589 20 CONTINUE 01590 INCXS = INCX 01591 DO 30 I = 1, LY 01592 YS( I ) = YY( I ) 01593 30 CONTINUE 01594 INCYS = INCY 01595 * 01596 * Call the subroutine. 01597 * 01598 IF( TRACE ) 01599 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, 01600 $ ALPHA, INCX, INCY, LDA 01601 IF( CONJ )THEN 01602 IF( REWI ) 01603 $ REWIND NTRA 01604 CALL CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, 01605 $ LDA ) 01606 ELSE 01607 IF( REWI ) 01608 $ REWIND NTRA 01609 CALL CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, 01610 $ LDA ) 01611 END IF 01612 * 01613 * Check if error-exit was taken incorrectly. 01614 * 01615 IF( .NOT.OK )THEN 01616 WRITE( NOUT, FMT = 9993 ) 01617 FATAL = .TRUE. 01618 GO TO 140 01619 END IF 01620 * 01621 * See what data changed inside subroutine. 01622 * 01623 ISAME( 1 ) = MS.EQ.M 01624 ISAME( 2 ) = NS.EQ.N 01625 ISAME( 3 ) = ALS.EQ.ALPHA 01626 ISAME( 4 ) = LCE( XS, XX, LX ) 01627 ISAME( 5 ) = INCXS.EQ.INCX 01628 ISAME( 6 ) = LCE( YS, YY, LY ) 01629 ISAME( 7 ) = INCYS.EQ.INCY 01630 IF( NULL )THEN 01631 ISAME( 8 ) = LCE( AS, AA, LAA ) 01632 ELSE 01633 ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA, 01634 $ LDA ) 01635 END IF 01636 ISAME( 9 ) = LDAS.EQ.LDA 01637 * 01638 * If data was incorrectly changed, report and return. 01639 * 01640 SAME = .TRUE. 01641 DO 40 I = 1, NARGS 01642 SAME = SAME.AND.ISAME( I ) 01643 IF( .NOT.ISAME( I ) ) 01644 $ WRITE( NOUT, FMT = 9998 )I 01645 40 CONTINUE 01646 IF( .NOT.SAME )THEN 01647 FATAL = .TRUE. 01648 GO TO 140 01649 END IF 01650 * 01651 IF( .NOT.NULL )THEN 01652 * 01653 * Check the result column by column. 01654 * 01655 IF( INCX.GT.0 )THEN 01656 DO 50 I = 1, M 01657 Z( I ) = X( I ) 01658 50 CONTINUE 01659 ELSE 01660 DO 60 I = 1, M 01661 Z( I ) = X( M - I + 1 ) 01662 60 CONTINUE 01663 END IF 01664 DO 70 J = 1, N 01665 IF( INCY.GT.0 )THEN 01666 W( 1 ) = Y( J ) 01667 ELSE 01668 W( 1 ) = Y( N - J + 1 ) 01669 END IF 01670 IF( CONJ ) 01671 $ W( 1 ) = CONJG( W( 1 ) ) 01672 CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, 01673 $ ONE, A( 1, J ), 1, YT, G, 01674 $ AA( 1 + ( J - 1 )*LDA ), EPS, 01675 $ ERR, FATAL, NOUT, .TRUE. ) 01676 ERRMAX = MAX( ERRMAX, ERR ) 01677 * If got really bad answer, report and return. 01678 IF( FATAL ) 01679 $ GO TO 130 01680 70 CONTINUE 01681 ELSE 01682 * Avoid repeating tests with M.le.0 or N.le.0. 01683 GO TO 110 01684 END IF 01685 * 01686 80 CONTINUE 01687 * 01688 90 CONTINUE 01689 * 01690 100 CONTINUE 01691 * 01692 110 CONTINUE 01693 * 01694 120 CONTINUE 01695 * 01696 * Report result. 01697 * 01698 IF( ERRMAX.LT.THRESH )THEN 01699 WRITE( NOUT, FMT = 9999 )SNAME, NC 01700 ELSE 01701 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01702 END IF 01703 GO TO 150 01704 * 01705 130 CONTINUE 01706 WRITE( NOUT, FMT = 9995 )J 01707 * 01708 140 CONTINUE 01709 WRITE( NOUT, FMT = 9996 )SNAME 01710 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA 01711 * 01712 150 CONTINUE 01713 RETURN 01714 * 01715 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01716 $ 'S)' ) 01717 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 01718 $ 'ANGED INCORRECTLY *******' ) 01719 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 01720 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 01721 $ ' - SUSPECT *******' ) 01722 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 01723 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 01724 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, 01725 $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', 01726 $ ' .' ) 01727 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 01728 $ '******' ) 01729 * 01730 * End of CCHK4. 01731 * 01732 END 01733 SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 01734 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 01735 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 01736 $ Z ) 01737 * 01738 * Tests CHER and CHPR. 01739 * 01740 * Auxiliary routine for test program for Level 2 Blas. 01741 * 01742 * -- Written on 10-August-1987. 01743 * Richard Hanson, Sandia National Labs. 01744 * Jeremy Du Croz, NAG Central Office. 01745 * 01746 * .. Parameters .. 01747 COMPLEX ZERO, HALF, ONE 01748 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 01749 $ ONE = ( 1.0, 0.0 ) ) 01750 REAL RZERO 01751 PARAMETER ( RZERO = 0.0 ) 01752 * .. Scalar Arguments .. 01753 REAL EPS, THRESH 01754 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 01755 LOGICAL FATAL, REWI, TRACE 01756 CHARACTER*6 SNAME 01757 * .. Array Arguments .. 01758 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 01759 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 01760 $ XX( NMAX*INCMAX ), Y( NMAX ), 01761 $ YS( NMAX*INCMAX ), YT( NMAX ), 01762 $ YY( NMAX*INCMAX ), Z( NMAX ) 01763 REAL G( NMAX ) 01764 INTEGER IDIM( NIDIM ), INC( NINC ) 01765 * .. Local Scalars .. 01766 COMPLEX ALPHA, TRANSL 01767 REAL ERR, ERRMAX, RALPHA, RALS 01768 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, 01769 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS 01770 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 01771 CHARACTER*1 UPLO, UPLOS 01772 CHARACTER*2 ICH 01773 * .. Local Arrays .. 01774 COMPLEX W( 1 ) 01775 LOGICAL ISAME( 13 ) 01776 * .. External Functions .. 01777 LOGICAL LCE, LCERES 01778 EXTERNAL LCE, LCERES 01779 * .. External Subroutines .. 01780 EXTERNAL CHER, CHPR, CMAKE, CMVCH 01781 * .. Intrinsic Functions .. 01782 INTRINSIC ABS, CMPLX, CONJG, MAX, REAL 01783 * .. Scalars in Common .. 01784 INTEGER INFOT, NOUTC 01785 LOGICAL LERR, OK 01786 * .. Common blocks .. 01787 COMMON /INFOC/INFOT, NOUTC, OK, LERR 01788 * .. Data statements .. 01789 DATA ICH/'UL'/ 01790 * .. Executable Statements .. 01791 FULL = SNAME( 3: 3 ).EQ.'E' 01792 PACKED = SNAME( 3: 3 ).EQ.'P' 01793 * Define the number of arguments. 01794 IF( FULL )THEN 01795 NARGS = 7 01796 ELSE IF( PACKED )THEN 01797 NARGS = 6 01798 END IF 01799 * 01800 NC = 0 01801 RESET = .TRUE. 01802 ERRMAX = RZERO 01803 * 01804 DO 100 IN = 1, NIDIM 01805 N = IDIM( IN ) 01806 * Set LDA to 1 more than minimum value if room. 01807 LDA = N 01808 IF( LDA.LT.NMAX ) 01809 $ LDA = LDA + 1 01810 * Skip tests if not enough room. 01811 IF( LDA.GT.NMAX ) 01812 $ GO TO 100 01813 IF( PACKED )THEN 01814 LAA = ( N*( N + 1 ) )/2 01815 ELSE 01816 LAA = LDA*N 01817 END IF 01818 * 01819 DO 90 IC = 1, 2 01820 UPLO = ICH( IC: IC ) 01821 UPPER = UPLO.EQ.'U' 01822 * 01823 DO 80 IX = 1, NINC 01824 INCX = INC( IX ) 01825 LX = ABS( INCX )*N 01826 * 01827 * Generate the vector X. 01828 * 01829 TRANSL = HALF 01830 CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 01831 $ 0, N - 1, RESET, TRANSL ) 01832 IF( N.GT.1 )THEN 01833 X( N/2 ) = ZERO 01834 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 01835 END IF 01836 * 01837 DO 70 IA = 1, NALF 01838 RALPHA = REAL( ALF( IA ) ) 01839 ALPHA = CMPLX( RALPHA, RZERO ) 01840 NULL = N.LE.0.OR.RALPHA.EQ.RZERO 01841 * 01842 * Generate the matrix A. 01843 * 01844 TRANSL = ZERO 01845 CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, 01846 $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) 01847 * 01848 NC = NC + 1 01849 * 01850 * Save every datum before calling the subroutine. 01851 * 01852 UPLOS = UPLO 01853 NS = N 01854 RALS = RALPHA 01855 DO 10 I = 1, LAA 01856 AS( I ) = AA( I ) 01857 10 CONTINUE 01858 LDAS = LDA 01859 DO 20 I = 1, LX 01860 XS( I ) = XX( I ) 01861 20 CONTINUE 01862 INCXS = INCX 01863 * 01864 * Call the subroutine. 01865 * 01866 IF( FULL )THEN 01867 IF( TRACE ) 01868 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 01869 $ RALPHA, INCX, LDA 01870 IF( REWI ) 01871 $ REWIND NTRA 01872 CALL CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) 01873 ELSE IF( PACKED )THEN 01874 IF( TRACE ) 01875 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 01876 $ RALPHA, INCX 01877 IF( REWI ) 01878 $ REWIND NTRA 01879 CALL CHPR( UPLO, N, RALPHA, XX, INCX, AA ) 01880 END IF 01881 * 01882 * Check if error-exit was taken incorrectly. 01883 * 01884 IF( .NOT.OK )THEN 01885 WRITE( NOUT, FMT = 9992 ) 01886 FATAL = .TRUE. 01887 GO TO 120 01888 END IF 01889 * 01890 * See what data changed inside subroutines. 01891 * 01892 ISAME( 1 ) = UPLO.EQ.UPLOS 01893 ISAME( 2 ) = NS.EQ.N 01894 ISAME( 3 ) = RALS.EQ.RALPHA 01895 ISAME( 4 ) = LCE( XS, XX, LX ) 01896 ISAME( 5 ) = INCXS.EQ.INCX 01897 IF( NULL )THEN 01898 ISAME( 6 ) = LCE( AS, AA, LAA ) 01899 ELSE 01900 ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS, 01901 $ AA, LDA ) 01902 END IF 01903 IF( .NOT.PACKED )THEN 01904 ISAME( 7 ) = LDAS.EQ.LDA 01905 END IF 01906 * 01907 * If data was incorrectly changed, report and return. 01908 * 01909 SAME = .TRUE. 01910 DO 30 I = 1, NARGS 01911 SAME = SAME.AND.ISAME( I ) 01912 IF( .NOT.ISAME( I ) ) 01913 $ WRITE( NOUT, FMT = 9998 )I 01914 30 CONTINUE 01915 IF( .NOT.SAME )THEN 01916 FATAL = .TRUE. 01917 GO TO 120 01918 END IF 01919 * 01920 IF( .NOT.NULL )THEN 01921 * 01922 * Check the result column by column. 01923 * 01924 IF( INCX.GT.0 )THEN 01925 DO 40 I = 1, N 01926 Z( I ) = X( I ) 01927 40 CONTINUE 01928 ELSE 01929 DO 50 I = 1, N 01930 Z( I ) = X( N - I + 1 ) 01931 50 CONTINUE 01932 END IF 01933 JA = 1 01934 DO 60 J = 1, N 01935 W( 1 ) = CONJG( Z( J ) ) 01936 IF( UPPER )THEN 01937 JJ = 1 01938 LJ = J 01939 ELSE 01940 JJ = J 01941 LJ = N - J + 1 01942 END IF 01943 CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, 01944 $ 1, ONE, A( JJ, J ), 1, YT, G, 01945 $ AA( JA ), EPS, ERR, FATAL, NOUT, 01946 $ .TRUE. ) 01947 IF( FULL )THEN 01948 IF( UPPER )THEN 01949 JA = JA + LDA 01950 ELSE 01951 JA = JA + LDA + 1 01952 END IF 01953 ELSE 01954 JA = JA + LJ 01955 END IF 01956 ERRMAX = MAX( ERRMAX, ERR ) 01957 * If got really bad answer, report and return. 01958 IF( FATAL ) 01959 $ GO TO 110 01960 60 CONTINUE 01961 ELSE 01962 * Avoid repeating tests if N.le.0. 01963 IF( N.LE.0 ) 01964 $ GO TO 100 01965 END IF 01966 * 01967 70 CONTINUE 01968 * 01969 80 CONTINUE 01970 * 01971 90 CONTINUE 01972 * 01973 100 CONTINUE 01974 * 01975 * Report result. 01976 * 01977 IF( ERRMAX.LT.THRESH )THEN 01978 WRITE( NOUT, FMT = 9999 )SNAME, NC 01979 ELSE 01980 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 01981 END IF 01982 GO TO 130 01983 * 01984 110 CONTINUE 01985 WRITE( NOUT, FMT = 9995 )J 01986 * 01987 120 CONTINUE 01988 WRITE( NOUT, FMT = 9996 )SNAME 01989 IF( FULL )THEN 01990 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA 01991 ELSE IF( PACKED )THEN 01992 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX 01993 END IF 01994 * 01995 130 CONTINUE 01996 RETURN 01997 * 01998 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 01999 $ 'S)' ) 02000 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 02001 $ 'ANGED INCORRECTLY *******' ) 02002 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 02003 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 02004 $ ' - SUSPECT *******' ) 02005 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 02006 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 02007 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02008 $ I2, ', AP) .' ) 02009 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 02010 $ I2, ', A,', I3, ') .' ) 02011 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 02012 $ '******' ) 02013 * 02014 * End of CCHK5. 02015 * 02016 END 02017 SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 02018 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 02019 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 02020 $ Z ) 02021 * 02022 * Tests CHER2 and CHPR2. 02023 * 02024 * Auxiliary routine for test program for Level 2 Blas. 02025 * 02026 * -- Written on 10-August-1987. 02027 * Richard Hanson, Sandia National Labs. 02028 * Jeremy Du Croz, NAG Central Office. 02029 * 02030 * .. Parameters .. 02031 COMPLEX ZERO, HALF, ONE 02032 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 02033 $ ONE = ( 1.0, 0.0 ) ) 02034 REAL RZERO 02035 PARAMETER ( RZERO = 0.0 ) 02036 * .. Scalar Arguments .. 02037 REAL EPS, THRESH 02038 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 02039 LOGICAL FATAL, REWI, TRACE 02040 CHARACTER*6 SNAME 02041 * .. Array Arguments .. 02042 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 02043 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 02044 $ XX( NMAX*INCMAX ), Y( NMAX ), 02045 $ YS( NMAX*INCMAX ), YT( NMAX ), 02046 $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) 02047 REAL G( NMAX ) 02048 INTEGER IDIM( NIDIM ), INC( NINC ) 02049 * .. Local Scalars .. 02050 COMPLEX ALPHA, ALS, TRANSL 02051 REAL ERR, ERRMAX 02052 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, 02053 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, 02054 $ NARGS, NC, NS 02055 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 02056 CHARACTER*1 UPLO, UPLOS 02057 CHARACTER*2 ICH 02058 * .. Local Arrays .. 02059 COMPLEX W( 2 ) 02060 LOGICAL ISAME( 13 ) 02061 * .. External Functions .. 02062 LOGICAL LCE, LCERES 02063 EXTERNAL LCE, LCERES 02064 * .. External Subroutines .. 02065 EXTERNAL CHER2, CHPR2, CMAKE, CMVCH 02066 * .. Intrinsic Functions .. 02067 INTRINSIC ABS, CONJG, MAX 02068 * .. Scalars in Common .. 02069 INTEGER INFOT, NOUTC 02070 LOGICAL LERR, OK 02071 * .. Common blocks .. 02072 COMMON /INFOC/INFOT, NOUTC, OK, LERR 02073 * .. Data statements .. 02074 DATA ICH/'UL'/ 02075 * .. Executable Statements .. 02076 FULL = SNAME( 3: 3 ).EQ.'E' 02077 PACKED = SNAME( 3: 3 ).EQ.'P' 02078 * Define the number of arguments. 02079 IF( FULL )THEN 02080 NARGS = 9 02081 ELSE IF( PACKED )THEN 02082 NARGS = 8 02083 END IF 02084 * 02085 NC = 0 02086 RESET = .TRUE. 02087 ERRMAX = RZERO 02088 * 02089 DO 140 IN = 1, NIDIM 02090 N = IDIM( IN ) 02091 * Set LDA to 1 more than minimum value if room. 02092 LDA = N 02093 IF( LDA.LT.NMAX ) 02094 $ LDA = LDA + 1 02095 * Skip tests if not enough room. 02096 IF( LDA.GT.NMAX ) 02097 $ GO TO 140 02098 IF( PACKED )THEN 02099 LAA = ( N*( N + 1 ) )/2 02100 ELSE 02101 LAA = LDA*N 02102 END IF 02103 * 02104 DO 130 IC = 1, 2 02105 UPLO = ICH( IC: IC ) 02106 UPPER = UPLO.EQ.'U' 02107 * 02108 DO 120 IX = 1, NINC 02109 INCX = INC( IX ) 02110 LX = ABS( INCX )*N 02111 * 02112 * Generate the vector X. 02113 * 02114 TRANSL = HALF 02115 CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 02116 $ 0, N - 1, RESET, TRANSL ) 02117 IF( N.GT.1 )THEN 02118 X( N/2 ) = ZERO 02119 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 02120 END IF 02121 * 02122 DO 110 IY = 1, NINC 02123 INCY = INC( IY ) 02124 LY = ABS( INCY )*N 02125 * 02126 * Generate the vector Y. 02127 * 02128 TRANSL = ZERO 02129 CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 02130 $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 02131 IF( N.GT.1 )THEN 02132 Y( N/2 ) = ZERO 02133 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 02134 END IF 02135 * 02136 DO 100 IA = 1, NALF 02137 ALPHA = ALF( IA ) 02138 NULL = N.LE.0.OR.ALPHA.EQ.ZERO 02139 * 02140 * Generate the matrix A. 02141 * 02142 TRANSL = ZERO 02143 CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, 02144 $ NMAX, AA, LDA, N - 1, N - 1, RESET, 02145 $ TRANSL ) 02146 * 02147 NC = NC + 1 02148 * 02149 * Save every datum before calling the subroutine. 02150 * 02151 UPLOS = UPLO 02152 NS = N 02153 ALS = ALPHA 02154 DO 10 I = 1, LAA 02155 AS( I ) = AA( I ) 02156 10 CONTINUE 02157 LDAS = LDA 02158 DO 20 I = 1, LX 02159 XS( I ) = XX( I ) 02160 20 CONTINUE 02161 INCXS = INCX 02162 DO 30 I = 1, LY 02163 YS( I ) = YY( I ) 02164 30 CONTINUE 02165 INCYS = INCY 02166 * 02167 * Call the subroutine. 02168 * 02169 IF( FULL )THEN 02170 IF( TRACE ) 02171 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 02172 $ ALPHA, INCX, INCY, LDA 02173 IF( REWI ) 02174 $ REWIND NTRA 02175 CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 02176 $ AA, LDA ) 02177 ELSE IF( PACKED )THEN 02178 IF( TRACE ) 02179 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 02180 $ ALPHA, INCX, INCY 02181 IF( REWI ) 02182 $ REWIND NTRA 02183 CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 02184 $ AA ) 02185 END IF 02186 * 02187 * Check if error-exit was taken incorrectly. 02188 * 02189 IF( .NOT.OK )THEN 02190 WRITE( NOUT, FMT = 9992 ) 02191 FATAL = .TRUE. 02192 GO TO 160 02193 END IF 02194 * 02195 * See what data changed inside subroutines. 02196 * 02197 ISAME( 1 ) = UPLO.EQ.UPLOS 02198 ISAME( 2 ) = NS.EQ.N 02199 ISAME( 3 ) = ALS.EQ.ALPHA 02200 ISAME( 4 ) = LCE( XS, XX, LX ) 02201 ISAME( 5 ) = INCXS.EQ.INCX 02202 ISAME( 6 ) = LCE( YS, YY, LY ) 02203 ISAME( 7 ) = INCYS.EQ.INCY 02204 IF( NULL )THEN 02205 ISAME( 8 ) = LCE( AS, AA, LAA ) 02206 ELSE 02207 ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, 02208 $ AS, AA, LDA ) 02209 END IF 02210 IF( .NOT.PACKED )THEN 02211 ISAME( 9 ) = LDAS.EQ.LDA 02212 END IF 02213 * 02214 * If data was incorrectly changed, report and return. 02215 * 02216 SAME = .TRUE. 02217 DO 40 I = 1, NARGS 02218 SAME = SAME.AND.ISAME( I ) 02219 IF( .NOT.ISAME( I ) ) 02220 $ WRITE( NOUT, FMT = 9998 )I 02221 40 CONTINUE 02222 IF( .NOT.SAME )THEN 02223 FATAL = .TRUE. 02224 GO TO 160 02225 END IF 02226 * 02227 IF( .NOT.NULL )THEN 02228 * 02229 * Check the result column by column. 02230 * 02231 IF( INCX.GT.0 )THEN 02232 DO 50 I = 1, N 02233 Z( I, 1 ) = X( I ) 02234 50 CONTINUE 02235 ELSE 02236 DO 60 I = 1, N 02237 Z( I, 1 ) = X( N - I + 1 ) 02238 60 CONTINUE 02239 END IF 02240 IF( INCY.GT.0 )THEN 02241 DO 70 I = 1, N 02242 Z( I, 2 ) = Y( I ) 02243 70 CONTINUE 02244 ELSE 02245 DO 80 I = 1, N 02246 Z( I, 2 ) = Y( N - I + 1 ) 02247 80 CONTINUE 02248 END IF 02249 JA = 1 02250 DO 90 J = 1, N 02251 W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) 02252 W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) 02253 IF( UPPER )THEN 02254 JJ = 1 02255 LJ = J 02256 ELSE 02257 JJ = J 02258 LJ = N - J + 1 02259 END IF 02260 CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), 02261 $ NMAX, W, 1, ONE, A( JJ, J ), 1, 02262 $ YT, G, AA( JA ), EPS, ERR, FATAL, 02263 $ NOUT, .TRUE. ) 02264 IF( FULL )THEN 02265 IF( UPPER )THEN 02266 JA = JA + LDA 02267 ELSE 02268 JA = JA + LDA + 1 02269 END IF 02270 ELSE 02271 JA = JA + LJ 02272 END IF 02273 ERRMAX = MAX( ERRMAX, ERR ) 02274 * If got really bad answer, report and return. 02275 IF( FATAL ) 02276 $ GO TO 150 02277 90 CONTINUE 02278 ELSE 02279 * Avoid repeating tests with N.le.0. 02280 IF( N.LE.0 ) 02281 $ GO TO 140 02282 END IF 02283 * 02284 100 CONTINUE 02285 * 02286 110 CONTINUE 02287 * 02288 120 CONTINUE 02289 * 02290 130 CONTINUE 02291 * 02292 140 CONTINUE 02293 * 02294 * Report result. 02295 * 02296 IF( ERRMAX.LT.THRESH )THEN 02297 WRITE( NOUT, FMT = 9999 )SNAME, NC 02298 ELSE 02299 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 02300 END IF 02301 GO TO 170 02302 * 02303 150 CONTINUE 02304 WRITE( NOUT, FMT = 9995 )J 02305 * 02306 160 CONTINUE 02307 WRITE( NOUT, FMT = 9996 )SNAME 02308 IF( FULL )THEN 02309 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, 02310 $ INCY, LDA 02311 ELSE IF( PACKED )THEN 02312 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY 02313 END IF 02314 * 02315 170 CONTINUE 02316 RETURN 02317 * 02318 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 02319 $ 'S)' ) 02320 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 02321 $ 'ANGED INCORRECTLY *******' ) 02322 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 02323 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 02324 $ ' - SUSPECT *******' ) 02325 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 02326 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 02327 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 02328 $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', 02329 $ ' .' ) 02330 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 02331 $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', 02332 $ ' .' ) 02333 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 02334 $ '******' ) 02335 * 02336 * End of CCHK6. 02337 * 02338 END 02339 SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) 02340 * 02341 * Tests the error exits from the Level 2 Blas. 02342 * Requires a special version of the error-handling routine XERBLA. 02343 * ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. 02344 * 02345 * Auxiliary routine for test program for Level 2 Blas. 02346 * 02347 * -- Written on 10-August-1987. 02348 * Richard Hanson, Sandia National Labs. 02349 * Jeremy Du Croz, NAG Central Office. 02350 * 02351 * .. Scalar Arguments .. 02352 INTEGER ISNUM, NOUT 02353 CHARACTER*6 SRNAMT 02354 * .. Scalars in Common .. 02355 INTEGER INFOT, NOUTC 02356 LOGICAL LERR, OK 02357 * .. Local Scalars .. 02358 COMPLEX ALPHA, BETA 02359 REAL RALPHA 02360 * .. Local Arrays .. 02361 COMPLEX A( 1, 1 ), X( 1 ), Y( 1 ) 02362 * .. External Subroutines .. 02363 EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, 02364 $ CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, 02365 $ CTBSV, CTPMV, CTPSV, CTRMV, CTRSV 02366 * .. Common blocks .. 02367 COMMON /INFOC/INFOT, NOUTC, OK, LERR 02368 * .. Executable Statements .. 02369 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER 02370 * if anything is wrong. 02371 OK = .TRUE. 02372 * LERR is set to .TRUE. by the special version of XERBLA each time 02373 * it is called, and is then tested and re-set by CHKXER. 02374 LERR = .FALSE. 02375 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 02376 $ 90, 100, 110, 120, 130, 140, 150, 160, 02377 $ 170 )ISNUM 02378 10 INFOT = 1 02379 CALL CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02380 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02381 INFOT = 2 02382 CALL CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02383 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02384 INFOT = 3 02385 CALL CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02386 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02387 INFOT = 6 02388 CALL CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02389 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02390 INFOT = 8 02391 CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02392 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02393 INFOT = 11 02394 CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02395 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02396 GO TO 180 02397 20 INFOT = 1 02398 CALL CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02399 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02400 INFOT = 2 02401 CALL CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02402 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02403 INFOT = 3 02404 CALL CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02405 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02406 INFOT = 4 02407 CALL CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02408 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02409 INFOT = 5 02410 CALL CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02411 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02412 INFOT = 8 02413 CALL CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02414 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02415 INFOT = 10 02416 CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02417 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02418 INFOT = 13 02419 CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02420 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02421 GO TO 180 02422 30 INFOT = 1 02423 CALL CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02424 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02425 INFOT = 2 02426 CALL CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02427 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02428 INFOT = 5 02429 CALL CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02430 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02431 INFOT = 7 02432 CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02433 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02434 INFOT = 10 02435 CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02436 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02437 GO TO 180 02438 40 INFOT = 1 02439 CALL CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02440 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02441 INFOT = 2 02442 CALL CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02443 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02444 INFOT = 3 02445 CALL CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02446 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02447 INFOT = 6 02448 CALL CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 02449 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02450 INFOT = 8 02451 CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 02452 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02453 INFOT = 11 02454 CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 02455 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02456 GO TO 180 02457 50 INFOT = 1 02458 CALL CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) 02459 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02460 INFOT = 2 02461 CALL CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) 02462 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02463 INFOT = 6 02464 CALL CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) 02465 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02466 INFOT = 9 02467 CALL CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) 02468 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02469 GO TO 180 02470 60 INFOT = 1 02471 CALL CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) 02472 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02473 INFOT = 2 02474 CALL CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) 02475 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02476 INFOT = 3 02477 CALL CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) 02478 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02479 INFOT = 4 02480 CALL CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 02481 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02482 INFOT = 6 02483 CALL CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 02484 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02485 INFOT = 8 02486 CALL CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 02487 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02488 GO TO 180 02489 70 INFOT = 1 02490 CALL CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 02491 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02492 INFOT = 2 02493 CALL CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 02494 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02495 INFOT = 3 02496 CALL CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 02497 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02498 INFOT = 4 02499 CALL CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 02500 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02501 INFOT = 5 02502 CALL CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 02503 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02504 INFOT = 7 02505 CALL CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 02506 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02507 INFOT = 9 02508 CALL CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 02509 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02510 GO TO 180 02511 80 INFOT = 1 02512 CALL CTPMV( '/', 'N', 'N', 0, A, X, 1 ) 02513 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02514 INFOT = 2 02515 CALL CTPMV( 'U', '/', 'N', 0, A, X, 1 ) 02516 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02517 INFOT = 3 02518 CALL CTPMV( 'U', 'N', '/', 0, A, X, 1 ) 02519 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02520 INFOT = 4 02521 CALL CTPMV( 'U', 'N', 'N', -1, A, X, 1 ) 02522 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02523 INFOT = 7 02524 CALL CTPMV( 'U', 'N', 'N', 0, A, X, 0 ) 02525 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02526 GO TO 180 02527 90 INFOT = 1 02528 CALL CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) 02529 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02530 INFOT = 2 02531 CALL CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) 02532 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02533 INFOT = 3 02534 CALL CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) 02535 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02536 INFOT = 4 02537 CALL CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 02538 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02539 INFOT = 6 02540 CALL CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 02541 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02542 INFOT = 8 02543 CALL CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 02544 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02545 GO TO 180 02546 100 INFOT = 1 02547 CALL CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 02548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02549 INFOT = 2 02550 CALL CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 02551 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02552 INFOT = 3 02553 CALL CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 02554 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02555 INFOT = 4 02556 CALL CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 02557 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02558 INFOT = 5 02559 CALL CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 02560 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02561 INFOT = 7 02562 CALL CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 02563 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02564 INFOT = 9 02565 CALL CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 02566 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02567 GO TO 180 02568 110 INFOT = 1 02569 CALL CTPSV( '/', 'N', 'N', 0, A, X, 1 ) 02570 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02571 INFOT = 2 02572 CALL CTPSV( 'U', '/', 'N', 0, A, X, 1 ) 02573 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02574 INFOT = 3 02575 CALL CTPSV( 'U', 'N', '/', 0, A, X, 1 ) 02576 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02577 INFOT = 4 02578 CALL CTPSV( 'U', 'N', 'N', -1, A, X, 1 ) 02579 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02580 INFOT = 7 02581 CALL CTPSV( 'U', 'N', 'N', 0, A, X, 0 ) 02582 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02583 GO TO 180 02584 120 INFOT = 1 02585 CALL CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02586 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02587 INFOT = 2 02588 CALL CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) 02589 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02590 INFOT = 5 02591 CALL CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) 02592 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02593 INFOT = 7 02594 CALL CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) 02595 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02596 INFOT = 9 02597 CALL CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02598 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02599 GO TO 180 02600 130 INFOT = 1 02601 CALL CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02602 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02603 INFOT = 2 02604 CALL CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) 02605 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02606 INFOT = 5 02607 CALL CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) 02608 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02609 INFOT = 7 02610 CALL CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) 02611 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02612 INFOT = 9 02613 CALL CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) 02614 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02615 GO TO 180 02616 140 INFOT = 1 02617 CALL CHER( '/', 0, RALPHA, X, 1, A, 1 ) 02618 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02619 INFOT = 2 02620 CALL CHER( 'U', -1, RALPHA, X, 1, A, 1 ) 02621 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02622 INFOT = 5 02623 CALL CHER( 'U', 0, RALPHA, X, 0, A, 1 ) 02624 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02625 INFOT = 7 02626 CALL CHER( 'U', 2, RALPHA, X, 1, A, 1 ) 02627 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02628 GO TO 180 02629 150 INFOT = 1 02630 CALL CHPR( '/', 0, RALPHA, X, 1, A ) 02631 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02632 INFOT = 2 02633 CALL CHPR( 'U', -1, RALPHA, X, 1, A ) 02634 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02635 INFOT = 5 02636 CALL CHPR( 'U', 0, RALPHA, X, 0, A ) 02637 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02638 GO TO 180 02639 160 INFOT = 1 02640 CALL CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) 02641 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02642 INFOT = 2 02643 CALL CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) 02644 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02645 INFOT = 5 02646 CALL CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) 02647 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02648 INFOT = 7 02649 CALL CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) 02650 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02651 INFOT = 9 02652 CALL CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) 02653 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02654 GO TO 180 02655 170 INFOT = 1 02656 CALL CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) 02657 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02658 INFOT = 2 02659 CALL CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) 02660 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02661 INFOT = 5 02662 CALL CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) 02663 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02664 INFOT = 7 02665 CALL CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) 02666 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 02667 * 02668 180 IF( OK )THEN 02669 WRITE( NOUT, FMT = 9999 )SRNAMT 02670 ELSE 02671 WRITE( NOUT, FMT = 9998 )SRNAMT 02672 END IF 02673 RETURN 02674 * 02675 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 02676 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', 02677 $ '**' ) 02678 * 02679 * End of CCHKE. 02680 * 02681 END 02682 SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, 02683 $ KU, RESET, TRANSL ) 02684 * 02685 * Generates values for an M by N matrix A within the bandwidth 02686 * defined by KL and KU. 02687 * Stores the values in the array AA in the data structure required 02688 * by the routine, with unwanted elements set to rogue value. 02689 * 02690 * TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. 02691 * 02692 * Auxiliary routine for test program for Level 2 Blas. 02693 * 02694 * -- Written on 10-August-1987. 02695 * Richard Hanson, Sandia National Labs. 02696 * Jeremy Du Croz, NAG Central Office. 02697 * 02698 * .. Parameters .. 02699 COMPLEX ZERO, ONE 02700 PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 02701 COMPLEX ROGUE 02702 PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) 02703 REAL RZERO 02704 PARAMETER ( RZERO = 0.0 ) 02705 REAL RROGUE 02706 PARAMETER ( RROGUE = -1.0E10 ) 02707 * .. Scalar Arguments .. 02708 COMPLEX TRANSL 02709 INTEGER KL, KU, LDA, M, N, NMAX 02710 LOGICAL RESET 02711 CHARACTER*1 DIAG, UPLO 02712 CHARACTER*2 TYPE 02713 * .. Array Arguments .. 02714 COMPLEX A( NMAX, * ), AA( * ) 02715 * .. Local Scalars .. 02716 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK 02717 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER 02718 * .. External Functions .. 02719 COMPLEX CBEG 02720 EXTERNAL CBEG 02721 * .. Intrinsic Functions .. 02722 INTRINSIC CMPLX, CONJG, MAX, MIN, REAL 02723 * .. Executable Statements .. 02724 GEN = TYPE( 1: 1 ).EQ.'G' 02725 SYM = TYPE( 1: 1 ).EQ.'H' 02726 TRI = TYPE( 1: 1 ).EQ.'T' 02727 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' 02728 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' 02729 UNIT = TRI.AND.DIAG.EQ.'U' 02730 * 02731 * Generate data in array A. 02732 * 02733 DO 20 J = 1, N 02734 DO 10 I = 1, M 02735 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) 02736 $ THEN 02737 IF( ( I.LE.J.AND.J - I.LE.KU ).OR. 02738 $ ( I.GE.J.AND.I - J.LE.KL ) )THEN 02739 A( I, J ) = CBEG( RESET ) + TRANSL 02740 ELSE 02741 A( I, J ) = ZERO 02742 END IF 02743 IF( I.NE.J )THEN 02744 IF( SYM )THEN 02745 A( J, I ) = CONJG( A( I, J ) ) 02746 ELSE IF( TRI )THEN 02747 A( J, I ) = ZERO 02748 END IF 02749 END IF 02750 END IF 02751 10 CONTINUE 02752 IF( SYM ) 02753 $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) 02754 IF( TRI ) 02755 $ A( J, J ) = A( J, J ) + ONE 02756 IF( UNIT ) 02757 $ A( J, J ) = ONE 02758 20 CONTINUE 02759 * 02760 * Store elements in array AS in data structure required by routine. 02761 * 02762 IF( TYPE.EQ.'GE' )THEN 02763 DO 50 J = 1, N 02764 DO 30 I = 1, M 02765 AA( I + ( J - 1 )*LDA ) = A( I, J ) 02766 30 CONTINUE 02767 DO 40 I = M + 1, LDA 02768 AA( I + ( J - 1 )*LDA ) = ROGUE 02769 40 CONTINUE 02770 50 CONTINUE 02771 ELSE IF( TYPE.EQ.'GB' )THEN 02772 DO 90 J = 1, N 02773 DO 60 I1 = 1, KU + 1 - J 02774 AA( I1 + ( J - 1 )*LDA ) = ROGUE 02775 60 CONTINUE 02776 DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) 02777 AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) 02778 70 CONTINUE 02779 DO 80 I3 = I2, LDA 02780 AA( I3 + ( J - 1 )*LDA ) = ROGUE 02781 80 CONTINUE 02782 90 CONTINUE 02783 ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN 02784 DO 130 J = 1, N 02785 IF( UPPER )THEN 02786 IBEG = 1 02787 IF( UNIT )THEN 02788 IEND = J - 1 02789 ELSE 02790 IEND = J 02791 END IF 02792 ELSE 02793 IF( UNIT )THEN 02794 IBEG = J + 1 02795 ELSE 02796 IBEG = J 02797 END IF 02798 IEND = N 02799 END IF 02800 DO 100 I = 1, IBEG - 1 02801 AA( I + ( J - 1 )*LDA ) = ROGUE 02802 100 CONTINUE 02803 DO 110 I = IBEG, IEND 02804 AA( I + ( J - 1 )*LDA ) = A( I, J ) 02805 110 CONTINUE 02806 DO 120 I = IEND + 1, LDA 02807 AA( I + ( J - 1 )*LDA ) = ROGUE 02808 120 CONTINUE 02809 IF( SYM )THEN 02810 JJ = J + ( J - 1 )*LDA 02811 AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) 02812 END IF 02813 130 CONTINUE 02814 ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN 02815 DO 170 J = 1, N 02816 IF( UPPER )THEN 02817 KK = KL + 1 02818 IBEG = MAX( 1, KL + 2 - J ) 02819 IF( UNIT )THEN 02820 IEND = KL 02821 ELSE 02822 IEND = KL + 1 02823 END IF 02824 ELSE 02825 KK = 1 02826 IF( UNIT )THEN 02827 IBEG = 2 02828 ELSE 02829 IBEG = 1 02830 END IF 02831 IEND = MIN( KL + 1, 1 + M - J ) 02832 END IF 02833 DO 140 I = 1, IBEG - 1 02834 AA( I + ( J - 1 )*LDA ) = ROGUE 02835 140 CONTINUE 02836 DO 150 I = IBEG, IEND 02837 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) 02838 150 CONTINUE 02839 DO 160 I = IEND + 1, LDA 02840 AA( I + ( J - 1 )*LDA ) = ROGUE 02841 160 CONTINUE 02842 IF( SYM )THEN 02843 JJ = KK + ( J - 1 )*LDA 02844 AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) 02845 END IF 02846 170 CONTINUE 02847 ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN 02848 IOFF = 0 02849 DO 190 J = 1, N 02850 IF( UPPER )THEN 02851 IBEG = 1 02852 IEND = J 02853 ELSE 02854 IBEG = J 02855 IEND = N 02856 END IF 02857 DO 180 I = IBEG, IEND 02858 IOFF = IOFF + 1 02859 AA( IOFF ) = A( I, J ) 02860 IF( I.EQ.J )THEN 02861 IF( UNIT ) 02862 $ AA( IOFF ) = ROGUE 02863 IF( SYM ) 02864 $ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) 02865 END IF 02866 180 CONTINUE 02867 190 CONTINUE 02868 END IF 02869 RETURN 02870 * 02871 * End of CMAKE. 02872 * 02873 END 02874 SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, 02875 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) 02876 * 02877 * Checks the results of the computational tests. 02878 * 02879 * Auxiliary routine for test program for Level 2 Blas. 02880 * 02881 * -- Written on 10-August-1987. 02882 * Richard Hanson, Sandia National Labs. 02883 * Jeremy Du Croz, NAG Central Office. 02884 * 02885 * .. Parameters .. 02886 COMPLEX ZERO 02887 PARAMETER ( ZERO = ( 0.0, 0.0 ) ) 02888 REAL RZERO, RONE 02889 PARAMETER ( RZERO = 0.0, RONE = 1.0 ) 02890 * .. Scalar Arguments .. 02891 COMPLEX ALPHA, BETA 02892 REAL EPS, ERR 02893 INTEGER INCX, INCY, M, N, NMAX, NOUT 02894 LOGICAL FATAL, MV 02895 CHARACTER*1 TRANS 02896 * .. Array Arguments .. 02897 COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) 02898 REAL G( * ) 02899 * .. Local Scalars .. 02900 COMPLEX C 02901 REAL ERRI 02902 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL 02903 LOGICAL CTRAN, TRAN 02904 * .. Intrinsic Functions .. 02905 INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT 02906 * .. Statement Functions .. 02907 REAL ABS1 02908 * .. Statement Function definitions .. 02909 ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) 02910 * .. Executable Statements .. 02911 TRAN = TRANS.EQ.'T' 02912 CTRAN = TRANS.EQ.'C' 02913 IF( TRAN.OR.CTRAN )THEN 02914 ML = N 02915 NL = M 02916 ELSE 02917 ML = M 02918 NL = N 02919 END IF 02920 IF( INCX.LT.0 )THEN 02921 KX = NL 02922 INCXL = -1 02923 ELSE 02924 KX = 1 02925 INCXL = 1 02926 END IF 02927 IF( INCY.LT.0 )THEN 02928 KY = ML 02929 INCYL = -1 02930 ELSE 02931 KY = 1 02932 INCYL = 1 02933 END IF 02934 * 02935 * Compute expected result in YT using data in A, X and Y. 02936 * Compute gauges in G. 02937 * 02938 IY = KY 02939 DO 40 I = 1, ML 02940 YT( IY ) = ZERO 02941 G( IY ) = RZERO 02942 JX = KX 02943 IF( TRAN )THEN 02944 DO 10 J = 1, NL 02945 YT( IY ) = YT( IY ) + A( J, I )*X( JX ) 02946 G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) 02947 JX = JX + INCXL 02948 10 CONTINUE 02949 ELSE IF( CTRAN )THEN 02950 DO 20 J = 1, NL 02951 YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) 02952 G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) 02953 JX = JX + INCXL 02954 20 CONTINUE 02955 ELSE 02956 DO 30 J = 1, NL 02957 YT( IY ) = YT( IY ) + A( I, J )*X( JX ) 02958 G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) 02959 JX = JX + INCXL 02960 30 CONTINUE 02961 END IF 02962 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) 02963 G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) 02964 IY = IY + INCYL 02965 40 CONTINUE 02966 * 02967 * Compute the error ratio for this result. 02968 * 02969 ERR = ZERO 02970 DO 50 I = 1, ML 02971 ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS 02972 IF( G( I ).NE.RZERO ) 02973 $ ERRI = ERRI/G( I ) 02974 ERR = MAX( ERR, ERRI ) 02975 IF( ERR*SQRT( EPS ).GE.RONE ) 02976 $ GO TO 60 02977 50 CONTINUE 02978 * If the loop completes, all results are at least half accurate. 02979 GO TO 80 02980 * 02981 * Report fatal error. 02982 * 02983 60 FATAL = .TRUE. 02984 WRITE( NOUT, FMT = 9999 ) 02985 DO 70 I = 1, ML 02986 IF( MV )THEN 02987 WRITE( NOUT, FMT = 9998 )I, YT( I ), 02988 $ YY( 1 + ( I - 1 )*ABS( INCY ) ) 02989 ELSE 02990 WRITE( NOUT, FMT = 9998 )I, 02991 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) 02992 END IF 02993 70 CONTINUE 02994 * 02995 80 CONTINUE 02996 RETURN 02997 * 02998 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', 02999 $ 'F ACCURATE *******', /' EXPECTED RE', 03000 $ 'SULT COMPUTED RESULT' ) 03001 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 03002 * 03003 * End of CMVCH. 03004 * 03005 END 03006 LOGICAL FUNCTION LCE( RI, RJ, LR ) 03007 * 03008 * Tests if two arrays are identical. 03009 * 03010 * Auxiliary routine for test program for Level 2 Blas. 03011 * 03012 * -- Written on 10-August-1987. 03013 * Richard Hanson, Sandia National Labs. 03014 * Jeremy Du Croz, NAG Central Office. 03015 * 03016 * .. Scalar Arguments .. 03017 INTEGER LR 03018 * .. Array Arguments .. 03019 COMPLEX RI( * ), RJ( * ) 03020 * .. Local Scalars .. 03021 INTEGER I 03022 * .. Executable Statements .. 03023 DO 10 I = 1, LR 03024 IF( RI( I ).NE.RJ( I ) ) 03025 $ GO TO 20 03026 10 CONTINUE 03027 LCE = .TRUE. 03028 GO TO 30 03029 20 CONTINUE 03030 LCE = .FALSE. 03031 30 RETURN 03032 * 03033 * End of LCE. 03034 * 03035 END 03036 LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) 03037 * 03038 * Tests if selected elements in two arrays are equal. 03039 * 03040 * TYPE is 'GE', 'HE' or 'HP'. 03041 * 03042 * Auxiliary routine for test program for Level 2 Blas. 03043 * 03044 * -- Written on 10-August-1987. 03045 * Richard Hanson, Sandia National Labs. 03046 * Jeremy Du Croz, NAG Central Office. 03047 * 03048 * .. Scalar Arguments .. 03049 INTEGER LDA, M, N 03050 CHARACTER*1 UPLO 03051 CHARACTER*2 TYPE 03052 * .. Array Arguments .. 03053 COMPLEX AA( LDA, * ), AS( LDA, * ) 03054 * .. Local Scalars .. 03055 INTEGER I, IBEG, IEND, J 03056 LOGICAL UPPER 03057 * .. Executable Statements .. 03058 UPPER = UPLO.EQ.'U' 03059 IF( TYPE.EQ.'GE' )THEN 03060 DO 20 J = 1, N 03061 DO 10 I = M + 1, LDA 03062 IF( AA( I, J ).NE.AS( I, J ) ) 03063 $ GO TO 70 03064 10 CONTINUE 03065 20 CONTINUE 03066 ELSE IF( TYPE.EQ.'HE' )THEN 03067 DO 50 J = 1, N 03068 IF( UPPER )THEN 03069 IBEG = 1 03070 IEND = J 03071 ELSE 03072 IBEG = J 03073 IEND = N 03074 END IF 03075 DO 30 I = 1, IBEG - 1 03076 IF( AA( I, J ).NE.AS( I, J ) ) 03077 $ GO TO 70 03078 30 CONTINUE 03079 DO 40 I = IEND + 1, LDA 03080 IF( AA( I, J ).NE.AS( I, J ) ) 03081 $ GO TO 70 03082 40 CONTINUE 03083 50 CONTINUE 03084 END IF 03085 * 03086 60 CONTINUE 03087 LCERES = .TRUE. 03088 GO TO 80 03089 70 CONTINUE 03090 LCERES = .FALSE. 03091 80 RETURN 03092 * 03093 * End of LCERES. 03094 * 03095 END 03096 COMPLEX FUNCTION CBEG( RESET ) 03097 * 03098 * Generates complex numbers as pairs of random numbers uniformly 03099 * distributed between -0.5 and 0.5. 03100 * 03101 * Auxiliary routine for test program for Level 2 Blas. 03102 * 03103 * -- Written on 10-August-1987. 03104 * Richard Hanson, Sandia National Labs. 03105 * Jeremy Du Croz, NAG Central Office. 03106 * 03107 * .. Scalar Arguments .. 03108 LOGICAL RESET 03109 * .. Local Scalars .. 03110 INTEGER I, IC, J, MI, MJ 03111 * .. Save statement .. 03112 SAVE I, IC, J, MI, MJ 03113 * .. Intrinsic Functions .. 03114 INTRINSIC CMPLX 03115 * .. Executable Statements .. 03116 IF( RESET )THEN 03117 * Initialize local variables. 03118 MI = 891 03119 MJ = 457 03120 I = 7 03121 J = 7 03122 IC = 0 03123 RESET = .FALSE. 03124 END IF 03125 * 03126 * The sequence of values of I or J is bounded between 1 and 999. 03127 * If initial I or J = 1,2,3,6,7 or 9, the period will be 50. 03128 * If initial I or J = 4 or 8, the period will be 25. 03129 * If initial I or J = 5, the period will be 10. 03130 * IC is used to break up the period by skipping 1 value of I or J 03131 * in 6. 03132 * 03133 IC = IC + 1 03134 10 I = I*MI 03135 J = J*MJ 03136 I = I - 1000*( I/1000 ) 03137 J = J - 1000*( J/1000 ) 03138 IF( IC.GE.5 )THEN 03139 IC = 0 03140 GO TO 10 03141 END IF 03142 CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) 03143 RETURN 03144 * 03145 * End of CBEG. 03146 * 03147 END 03148 REAL FUNCTION SDIFF( X, Y ) 03149 * 03150 * Auxiliary routine for test program for Level 2 Blas. 03151 * 03152 * -- Written on 10-August-1987. 03153 * Richard Hanson, Sandia National Labs. 03154 * 03155 * .. Scalar Arguments .. 03156 REAL X, Y 03157 * .. Executable Statements .. 03158 SDIFF = X - Y 03159 RETURN 03160 * 03161 * End of SDIFF. 03162 * 03163 END 03164 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 03165 * 03166 * Tests whether XERBLA has detected an error when it should. 03167 * 03168 * Auxiliary routine for test program for Level 2 Blas. 03169 * 03170 * -- Written on 10-August-1987. 03171 * Richard Hanson, Sandia National Labs. 03172 * Jeremy Du Croz, NAG Central Office. 03173 * 03174 * .. Scalar Arguments .. 03175 INTEGER INFOT, NOUT 03176 LOGICAL LERR, OK 03177 CHARACTER*6 SRNAMT 03178 * .. Executable Statements .. 03179 IF( .NOT.LERR )THEN 03180 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT 03181 OK = .FALSE. 03182 END IF 03183 LERR = .FALSE. 03184 RETURN 03185 * 03186 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', 03187 $ 'ETECTED BY ', A6, ' *****' ) 03188 * 03189 * End of CHKXER. 03190 * 03191 END 03192 SUBROUTINE XERBLA( SRNAME, INFO ) 03193 * 03194 * This is a special version of XERBLA to be used only as part of 03195 * the test program for testing error exits from the Level 2 BLAS 03196 * routines. 03197 * 03198 * XERBLA is an error handler for the Level 2 BLAS routines. 03199 * 03200 * It is called by the Level 2 BLAS routines if an input parameter is 03201 * invalid. 03202 * 03203 * Auxiliary routine for test program for Level 2 Blas. 03204 * 03205 * -- Written on 10-August-1987. 03206 * Richard Hanson, Sandia National Labs. 03207 * Jeremy Du Croz, NAG Central Office. 03208 * 03209 * .. Scalar Arguments .. 03210 INTEGER INFO 03211 CHARACTER*6 SRNAME 03212 * .. Scalars in Common .. 03213 INTEGER INFOT, NOUT 03214 LOGICAL LERR, OK 03215 CHARACTER*6 SRNAMT 03216 * .. Common blocks .. 03217 COMMON /INFOC/INFOT, NOUT, OK, LERR 03218 COMMON /SRNAMC/SRNAMT 03219 * .. Executable Statements .. 03220 LERR = .TRUE. 03221 IF( INFO.NE.INFOT )THEN 03222 IF( INFOT.NE.0 )THEN 03223 WRITE( NOUT, FMT = 9999 )INFO, INFOT 03224 ELSE 03225 WRITE( NOUT, FMT = 9997 )INFO 03226 END IF 03227 OK = .FALSE. 03228 END IF 03229 IF( SRNAME.NE.SRNAMT )THEN 03230 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT 03231 OK = .FALSE. 03232 END IF 03233 RETURN 03234 * 03235 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', 03236 $ ' OF ', I2, ' *******' ) 03237 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', 03238 $ 'AD OF ', A6, ' *******' ) 03239 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, 03240 $ ' *******' ) 03241 * 03242 * End of XERBLA 03243 * 03244 END 03245
1.7.3 
