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