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