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