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