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