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