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