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