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