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