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