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