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