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