c_cblat3.f

PROGRAM CBLAT3
*
* Test program for the COMPLEX Level 3 Blas.
*
* The program must be driven by a short data file. The first 13 records
* of the file are read using list-directed input, the last 9 records
* are read using the format ( A12, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 22 lines:
* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 3 NUMBER OF VALUES OF ALPHA
* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
* cblas_cgemm T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_chemm T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_csymm T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_ctrmm T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_ctrsm T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_cherk T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_csyrk T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
* A Set of Level 3 Basic Linear Algebra Subprograms.
*
* Technical Memorandum No.88 (Revision 1), Mathematics and
* Computer Science Division, Argonne National Laboratory, 9700
* South Cass Avenue, Argonne, Illinois 60439, US.
*
* -- Written on 8-February-1989.
* Jack Dongarra, Argonne National Laboratory.
* Iain Duff, AERE Harwell.
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
* .. Parameters ..
INTEGER NIN, NOUT
PARAMETER ( NIN =5, NOUT =6 )
INTEGER NSUBS
PARAMETER ( NSUBS =9 )
COMPLEX ZERO, ONE
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
REAL RZERO, RHALF, RONE
PARAMETER ( RZERO =0.0, RHALF =0.5, RONE =1.0 )
INTEGER NMAX
PARAMETER ( NMAX =65 )
INTEGER NIDMAX, NALMAX, NBEMAX
PARAMETER ( NIDMAX =9, NALMAX =7, NBEMAX =7 )
* .. Local Scalars ..
REAL EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA,
 $ LAYOUT
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
 $ TSTERR, CORDER, RORDER
CHARACTER*1 TRANSA, TRANSB
CHARACTER*12 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
 $ ALF( NALMAX ), AS( NMAX*NMAX ),
 $ BB( NMAX*NMAX ), BET( NBEMAX ),
 $ BS( NMAX*NMAX ), C( NMAX, NMAX ),
 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
 $ W( 2*NMAX )
REAL G( NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*12 SNAMES( NSUBS )
* .. External Functions ..
REAL SDIFF
LOGICAL LCE
EXTERNAL SDIFF, LCE
* .. External Subroutines ..
EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
CHARACTER*12 SRNAMT
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK, LERR
COMMON/SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'cblas_cgemm ', 'cblas_chemm ',
 $ 'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ',
 $ 'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k',
 $ 'cblas_csyr2k'/
* .. Executable Statements ..
*
 NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT =* )SNAPS
READ( NIN, FMT =* )NTRA
 TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT =* )REWI
 REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT =* )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT =* )TSTERR
* Read the flag that indicates whether row-major data layout to be tested.
READ( NIN, FMT =* )LAYOUT
* Read the threshold value of the test ratio
READ( NIN, FMT =* )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT =* )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT =9997 )'N', NIDMAX
GO TO220
END IF
READ( NIN, FMT =* )( IDIM( I ), I =1, NIDIM )
DO10 I =1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT =9996 )NMAX
GO TO220
END IF
10CONTINUE
* Values of ALPHA
READ( NIN, FMT =* )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT =9997 )'ALPHA', NALMAX
GO TO220
END IF
READ( NIN, FMT =* )( ALF( I ), I =1, NALF )
* Values of BETA
READ( NIN, FMT =* )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT =9997 )'BETA', NBEMAX
GO TO220
END IF
READ( NIN, FMT =* )( BET( I ), I =1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT =9995 )
WRITE( NOUT, FMT =9994 )( IDIM( I ), I =1, NIDIM )
WRITE( NOUT, FMT =9993 )( ALF( I ), I =1, NALF )
WRITE( NOUT, FMT =9992 )( BET( I ), I =1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT =* )
WRITE( NOUT, FMT =9984 )
END IF
WRITE( NOUT, FMT =* )
WRITE( NOUT, FMT =9999 )THRESH
WRITE( NOUT, FMT =* )

 RORDER =.FALSE.
 CORDER =.FALSE.
IF (LAYOUT.EQ.2) THEN
 RORDER =.TRUE.
 CORDER =.TRUE.
WRITE( *, FMT =10002 )
ELSEIF (LAYOUT.EQ.1) THEN
 RORDER =.TRUE.
WRITE( *, FMT =10001 )
ELSEIF (LAYOUT.EQ.0) THEN
 CORDER =.TRUE.
WRITE( *, FMT =10000 )
END IF
WRITE( *, FMT =* )

*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO20 I =1, NSUBS
 LTEST( I ) =.FALSE.
20CONTINUE
30READ( NIN, FMT =9988, END =60 )SNAMET, LTESTT
DO40 I =1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
 $ GO TO50
40CONTINUE
WRITE( NOUT, FMT =9990 )SNAMET
STOP
50 LTEST( I ) = LTESTT
GO TO30
*
60CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
 EPS = RONE
70CONTINUE
IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
 $ GO TO80
 EPS = RHALF*EPS
GO TO70
80CONTINUE
 EPS = EPS + EPS
WRITE( NOUT, FMT =9998 )EPS
*
* Check the reliability of CMMCH using exact data.
*
 N =MIN( 32, NMAX )
DO100 J =1, N
DO90 I =1, N
 AB( I, J ) =MAX( I - J +1, 0 )
90CONTINUE
 AB( J, NMAX +1 ) = J
 AB( 1, NMAX + J ) = J
 C( J, 1 ) = ZERO
100CONTINUE
DO110 J =1, N
 CC( J ) = J*( ( J +1 )*J )/2- ( ( J +1 )*J*( J -1 ) )/3
110CONTINUE
* CC holds the exact result. On exit from CMMCH CT holds
* the result computed by CMMCH.
 TRANSA ='N'
 TRANSB ='N'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
 $ AB( 1, NMAX +1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT =9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
 TRANSB ='C'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
 $ AB( 1, NMAX +1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT =9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
DO120 J =1, N
 AB( J, NMAX +1 ) = N - J +1
 AB( 1, NMAX + J ) = N - J +1
120CONTINUE
DO130 J =1, N
 CC( N - J +1 ) = J*( ( J +1 )*J )/2-
 $ ( ( J +1 )*J*( J -1 ) )/3
130CONTINUE
 TRANSA ='C'
 TRANSB ='N'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
 $ AB( 1, NMAX +1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT =9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
 TRANSB ='C'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
 $ AB( 1, NMAX +1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT =9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO200 ISNUM =1, NSUBS
WRITE( NOUT, FMT =* )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT =9987 )SNAMES( ISNUM )
ELSE
 SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL CC3CHKE( SNAMES( ISNUM ) )
WRITE( NOUT, FMT =* )
END IF
* Test computations.
 INFOT =0
 OK =.TRUE.
 FATAL =.FALSE.
GO TO ( 140, 150, 150, 160, 160, 170, 170,
 $ 180, 180 )ISNUM
* Test CGEMM, 01.
140IF (CORDER) THEN
CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 0 )
END IF
IF (RORDER) THEN
CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 1 )
END IF
GO TO190
* Test CHEMM, 02, CSYMM, 03.
150IF (CORDER) THEN
CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 0 )
END IF
IF (RORDER) THEN
CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 1 )
END IF
GO TO190
* Test CTRMM, 04, CTRSM, 05.
160IF (CORDER) THEN
CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
 $ AA, AS, AB( 1, NMAX +1 ), BB, BS, CT, G, C,
 $ 0 )
END IF
IF (RORDER) THEN
CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
 $ AA, AS, AB( 1, NMAX +1 ), BB, BS, CT, G, C,
 $ 1 )
END IF
GO TO190
* Test CHERK, 06, CSYRK, 07.
170IF (CORDER) THEN
CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 0 )
END IF
IF (RORDER) THEN
CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, AB( 1, NMAX +1 ), BB, BS, C,
 $ CC, CS, CT, G, 1 )
END IF
GO TO190
* Test CHER2K, 08, CSYR2K, 09.
180IF (CORDER) THEN
CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
 $ 0 )
END IF
IF (RORDER) THEN
CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
 $ 1 )
END IF
GO TO190
*
190IF( FATAL.AND.SFATAL )
 $ GO TO210
END IF
200CONTINUE
WRITE( NOUT, FMT =9986 )
GO TO230
*
210CONTINUE
WRITE( NOUT, FMT =9985 )
GO TO230
*
220CONTINUE
WRITE( NOUT, FMT =9991 )
*
230CONTINUE
IF( TRACE )
 $ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
10002FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )
10000FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
9999FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
 $ 'S THAN', F8.2 )
9998FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
9997FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
 $ 'THAN ', I2 )
9996FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995FORMAT(' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F',
 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9994FORMAT( ' FOR N ', 9I6 )
9993FORMAT( ' FOR ALPHA ',
 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9992FORMAT( ' FOR BETA ',
 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9991FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
 $ /' ******* TESTS ABANDONED *******' )
9990FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',
 $ 'ESTS ABANDONED *******' )
9989FORMAT(' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
 $ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1,
 $ 'AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
 $ ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
 $ '*******' )
9988FORMAT( A12,L2 )
9987FORMAT( 1X, A12,' WAS NOT TESTED' )
9986FORMAT( /' END OF TESTS' )
9985FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of CBLAT3.
*
 END
SUBROUTINECCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
$IORDER )
*
* Tests CGEMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- Written on 8-February-1989.
* Jack Dongarra, Argonne National Laboratory.
* Iain Duff, AERE Harwell.
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = ( 0.0, 0.0 ) )
REAL RZERO
PARAMETER ( RZERO =0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
CHARACTER*12 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
 $ CS( NMAX*NMAX ), CT( NMAX )
REAL G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
COMPLEX ALPHA, ALS, BETA, BLS
REAL ERR, ERRMAX
INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
LOGICAL NULL, RESET, SAME, TRANA, TRANB
CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LCE, LCERES
EXTERNAL LCE, LCERES
* .. External Subroutines ..
EXTERNAL CCGEMM, CMAKE, CMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
*
 NARGS =13
 NC =0
 RESET =.TRUE.
 ERRMAX = RZERO
*
DO110 IM =1, NIDIM
 M = IDIM( IM )
*
DO100IN=1, NIDIM
 N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
 LDC = M
IF( LDC.LT.NMAX )
 $ LDC = LDC +1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
 $ GO TO100
 LCC = LDC*N
 NULL = N.LE.0.OR.M.LE.0
*
DO90 IK =1, NIDIM
 K = IDIM( IK )
*
DO80 ICA =1, 3
 TRANSA = ICH( ICA: ICA )
 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
*
IF( TRANA )THEN
 MA = K
 NA = M
ELSE
 MA = M
 NA = K
END IF
* Set LDA to 1 more than minimum value if room.
 LDA = MA
IF( LDA.LT.NMAX )
 $ LDA = LDA +1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
 $ GO TO80
 LAA = LDA*NA
*
* Generate the matrix A.
*
CALL CMAKE( 'ge', '', '', MA, NA, A, NMAX, AA, LDA,
 $ RESET, ZERO )
*
DO70 ICB =1, 3
 TRANSB = ICH( ICB: ICB )
 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
IF( TRANB )THEN
 MB = N
 NB = K
ELSE
 MB = K
 NB = N
END IF
* Set LDB to 1 more than minimum value if room.
 LDB = MB
IF( LDB.LT.NMAX )
 $ LDB = LDB +1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
 $ GO TO70
 LBB = LDB*NB
*
* Generate the matrix B.
*
CALL CMAKE( 'ge', '', '', MB, NB, B, NMAX, BB,
 $ LDB, RESET, ZERO )
*
DO60 IA =1, NALF
 ALPHA = ALF( IA )
*
DO50 IB =1, NBET
 BETA = BET( IB )
*
* Generate the matrix C.
*
CALL CMAKE( 'ge', '', '', M, N, C, NMAX,
 $ CC, LDC, RESET, ZERO )
*
 NC = NC +1
*
* Save every datum before calling the
* subroutine.
*
 TRANAS = TRANSA
 TRANBS = TRANSB
 MS = M
 NS = N
 KS = K
 ALS = ALPHA
DO10 I =1, LAA
 AS( I ) = AA( I )
10CONTINUE
 LDAS = LDA
DO20 I =1, LBB
 BS( I ) = BB( I )
20CONTINUE
 LDBS = LDB
 BLS = BETA
DO30 I =1, LCC
 CS( I ) = CC( I )
30CONTINUE
 LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
 $ CALL CPRCN1(NTRA, NC, SNAME, IORDER,
 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA,
 $ LDB, BETA, LDC)
IF( REWI )
 $ REWIND NTRA
CALL CCGEMM( IORDER, TRANSA, TRANSB, M, N,
 $ K, ALPHA, AA, LDA, BB, LDB,
 $ BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT =9994 )
 FATAL =.TRUE.
GO TO120
END IF
*
* See what data changed inside subroutines.
*
 ISAME( 1 ) = TRANSA.EQ.TRANAS
 ISAME( 2 ) = TRANSB.EQ.TRANBS
 ISAME( 3 ) = MS.EQ.M
 ISAME( 4 ) = NS.EQ.N
 ISAME( 5 ) = KS.EQ.K
 ISAME( 6 ) = ALS.EQ.ALPHA
 ISAME( 7 ) = LCE( AS, AA, LAA )
 ISAME( 8 ) = LDAS.EQ.LDA
 ISAME( 9 ) = LCE( BS, BB, LBB )
 ISAME( 10 ) = LDBS.EQ.LDB
 ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
 ISAME( 12 ) = LCE( CS, CC, LCC )
ELSE
 ISAME( 12 ) = LCERES( 'ge', '', M, N, CS,
 $ CC, LDC )
END IF
 ISAME( 13 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report
* and return.
*
 SAME =.TRUE.
DO40 I =1, NARGS
 SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
 $ WRITE( NOUT, FMT =9998 )I
40CONTINUE
IF( .NOT.SAME )THEN
 FATAL =.TRUE.
GO TO120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL CMMCH( TRANSA, TRANSB, M, N, K,
 $ ALPHA, A, NMAX, B, NMAX, BETA,
 $ C, NMAX, CT, G, CC, LDC, EPS,
 $ ERR, FATAL, NOUT, .TRUE. )
 ERRMAX =MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
 $ GO TO120
END IF
*
50CONTINUE
*
60CONTINUE
*
70CONTINUE
*
80CONTINUE
*
90CONTINUE
*
100CONTINUE
*
110CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
IF ( IORDER.EQ.0) WRITE( NOUT, FMT =10000 )SNAME, NC
IF ( IORDER.EQ.1) WRITE( NOUT, FMT =10001 )SNAME, NC
ELSE
IF ( IORDER.EQ.0) WRITE( NOUT, FMT =10002 )SNAME, NC, ERRMAX
IF ( IORDER.EQ.1) WRITE( NOUT, FMT =10003 )SNAME, NC, ERRMAX
END IF
GO TO130
*
120CONTINUE
WRITE( NOUT, FMT =9996 )SNAME
CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB,
 $ M, N, K, ALPHA, LDA, LDB, BETA, LDC)
*
130CONTINUE
RETURN
*
10003FORMAT( '', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
10002FORMAT( '', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
10001FORMAT( '', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
 $ ' (', I6, ' CALL', 'S)' )
10000FORMAT( '', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
 $ ' (', I6, ' CALL', 'S)' )
9998FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
 $ 'ANGED INCORRECTLY *******' )
9996FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
9995FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
 $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
 $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
9994FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
 $ '******' )
*
* End of CCHK1.
*
END
*
SUBROUTINECPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
$K, ALPHA, LDA, LDB, BETA, LDC)
INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
COMPLEX ALPHA, BETA
CHARACTER*1 TRANSA, TRANSB
CHARACTER*12 SNAME
CHARACTER*14 CRC, CTA,CTB

IF (TRANSA.EQ.'N')THEN
 CTA =' CblasNoTrans'
ELSEIF (TRANSA.EQ.'T')THEN
 CTA =' CblasTrans'
ELSE
 CTA ='CblasConjTrans'
END IF
IF (TRANSB.EQ.'N')THEN
 CTB =' CblasNoTrans'
ELSEIF (TRANSB.EQ.'T')THEN
 CTB =' CblasTrans'
ELSE
 CTB ='CblasConjTrans'
END IF
IF (IORDER.EQ.1)THEN
 CRC =' CblasRowMajor'
ELSE
 CRC =' CblasColMajor'
END IF
WRITE(NOUT, FMT =9995)NC,SNAME,CRC, CTA,CTB
WRITE(NOUT, FMT =9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC

9995FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
9994FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
 $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
END
*
SUBROUTINECCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
$IORDER )
*
* Tests CHEMM and CSYMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- Written on 8-February-1989.
* Jack Dongarra, Argonne National Laboratory.
* Iain Duff, AERE Harwell.
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = ( 0.0, 0.0 ) )
REAL RZERO
PARAMETER ( RZERO =0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
CHARACTER*12 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
 $ CS( NMAX*NMAX ), CT( NMAX )
REAL G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
COMPLEX ALPHA, ALS, BETA, BLS
REAL ERR, ERRMAX
INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
 $ NARGS, NC, NS
LOGICAL CONJ, LEFT, NULL, RESET, SAME
CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
CHARACTER*2 ICHS, ICHU
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LCE, LCERES
EXTERNAL LCE, LCERES
* .. External Subroutines ..
EXTERNAL CCHEMM, CMAKE, CMMCH, CCSYMM
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHS/'LR'/, ICHU/'UL'/
* .. Executable Statements ..
 CONJ = SNAME( 8: 9 ).EQ.'he'
*
 NARGS =12
 NC =0
 RESET =.TRUE.
 ERRMAX = RZERO
*
DO100 IM =1, NIDIM
 M = IDIM( IM )
*
DO90IN=1, NIDIM
 N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
 LDC = M
IF( LDC.LT.NMAX )
 $ LDC = LDC +1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
 $ GO TO90
 LCC = LDC*N
 NULL = N.LE.0.OR.M.LE.0
* Set LDB to 1 more than minimum value if room.
 LDB = M
IF( LDB.LT.NMAX )
 $ LDB = LDB +1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
 $ GO TO90
 LBB = LDB*N
*
* Generate the matrix B.
*
CALL CMAKE( 'ge', '', '', M, N, B, NMAX, BB, LDB, RESET,
 $ ZERO )
*
DO80 ICS =1, 2
 SIDE = ICHS( ICS: ICS )
 LEFT = SIDE.EQ.'L'
*
IF( LEFT )THEN
 NA = M
ELSE
 NA = N
END IF
* Set LDA to 1 more than minimum value if room.
 LDA = NA
IF( LDA.LT.NMAX )
 $ LDA = LDA +1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
 $ GO TO80
 LAA = LDA*NA
*
DO70 ICU =1, 2
 UPLO = ICHU( ICU: ICU )
*
* Generate the hermitian or symmetric matrix A.
*
CALL CMAKE(SNAME( 8: 9 ), UPLO, '', NA, NA, A, NMAX,
 $ AA, LDA, RESET, ZERO )
*
DO60 IA =1, NALF
 ALPHA = ALF( IA )
*
DO50 IB =1, NBET
 BETA = BET( IB )
*
* Generate the matrix C.
*
CALL CMAKE( 'ge', '', '', M, N, C, NMAX, CC,
 $ LDC, RESET, ZERO )
*
 NC = NC +1
*
* Save every datum before calling the
* subroutine.
*
 SIDES = SIDE
 UPLOS = UPLO
 MS = M
 NS = N
 ALS = ALPHA
DO10 I =1, LAA
 AS( I ) = AA( I )
10CONTINUE
 LDAS = LDA
DO20 I =1, LBB
 BS( I ) = BB( I )
20CONTINUE
 LDBS = LDB
 BLS = BETA
DO30 I =1, LCC
 CS( I ) = CC( I )
30CONTINUE
 LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
 $ CALL CPRCN2(NTRA, NC, SNAME, IORDER,
 $ SIDE, UPLO, M, N, ALPHA, LDA, LDB,
 $ BETA, LDC)
IF( REWI )
 $ REWIND NTRA
IF( CONJ )THEN
CALL CCHEMM( IORDER, SIDE, UPLO, M, N,
 $ ALPHA, AA, LDA, BB, LDB, BETA,
 $ CC, LDC )
ELSE
CALL CCSYMM( IORDER, SIDE, UPLO, M, N,
 $ ALPHA, AA, LDA, BB, LDB, BETA,
 $ CC, LDC )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT =9994 )
 FATAL =.TRUE.
GO TO110
END IF
*
* See what data changed inside subroutines.
*
 ISAME( 1 ) = SIDES.EQ.SIDE
 ISAME( 2 ) = UPLOS.EQ.UPLO
 ISAME( 3 ) = MS.EQ.M
 ISAME( 4 ) = NS.EQ.N
 ISAME( 5 ) = ALS.EQ.ALPHA
 ISAME( 6 ) = LCE( AS, AA, LAA )
 ISAME( 7 ) = LDAS.EQ.LDA
 ISAME( 8 ) = LCE( BS, BB, LBB )
 ISAME( 9 ) = LDBS.EQ.LDB
 ISAME( 10 ) = BLS.EQ.BETA
IF( NULL )THEN
 ISAME( 11 ) = LCE( CS, CC, LCC )
ELSE
 ISAME( 11 ) = LCERES( 'ge', '', M, N, CS,
 $ CC, LDC )
END IF
 ISAME( 12 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
 SAME =.TRUE.
DO40 I =1, NARGS
 SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
 $ WRITE( NOUT, FMT =9998 )I
40CONTINUE
IF( .NOT.SAME )THEN
 FATAL =.TRUE.
GO TO110
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
IF( LEFT )THEN
CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A,
 $ NMAX, B, NMAX, BETA, C, NMAX,
 $ CT, G, CC, LDC, EPS, ERR,
 $ FATAL, NOUT, .TRUE. )
ELSE
CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B,
 $ NMAX, A, NMAX, BETA, C, NMAX,
 $ CT, G, CC, LDC, EPS, ERR,
 $ FATAL, NOUT, .TRUE. )
END IF
 ERRMAX =MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
 $ GO TO110
END IF
*
50CONTINUE
*
60CONTINUE
*
70CONTINUE
*
80CONTINUE
*
90CONTINUE