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