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