*DECK CBLAT3 SUBROUTINE CBLAT3 (NOUT, KPRINT, IPASS) C***BEGIN PROLOGUE CBLAT3 C***PURPOSE Driver for testing Level 3 BLAS complex subroutines. C***LIBRARY SLATEC (BLAS) C***CATEGORY A4 C***TYPE COMPLEX (SBLAT3-S, DBLAT3-D, CBLAT3-C) C***KEYWORDS BLAS, QUICK CHECK DRIVER C***AUTHOR Dongarra, J. J., (ANL) C Duff, I., (AERE) C Du Croz, J., (NAG) C Hammarling, S., (NAG) C***DESCRIPTION C C Test program for the COMPLEX Level 3 Blas. C C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. C A set of level 3 basic linear algebra subprograms. C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. C***ROUTINES CALLED CCHK13, CCHK23, CCHK33, CCHK43, CCHK53, CCHKE3, C CMMCH, LCE, R1MACH, XERCLR C***REVISION HISTORY (YYMMDD) C 890208 DATE WRITTEN C 910619 Modified to meet SLATEC code and prologue standards. (BKS) C 930315 Removed unused variables. (WRB) C 930618 Code modified to improve PASS/FAIL reporting. (BKS, WRB) C***END PROLOGUE CBLAT3 C .. Parameters .. INTEGER NSUBS PARAMETER ( NSUBS = 9) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) INTEGER NMAX PARAMETER ( NMAX = 65) C .. Scalar Arguments .. INTEGER IPASS, KPRINT C .. Local Scalars .. REAL EPS, ERR, THRESH INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT PARAMETER (NIDIM=6, NALF=3, NBET=3) LOGICAL SAME, TSTERR, FTL, FTL1, FTL2 CHARACTER*1 TRANSA, TRANSB C .. Local Arrays .. COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), $ BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ W( 2*NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) LOGICAL LTEST( NSUBS ) CHARACTER*6 SNAMES( NSUBS ) C .. External Functions .. REAL R1MACH LOGICAL LCE EXTERNAL LCE, R1MACH C .. External Subroutines .. EXTERNAL CCHK13, CCHK23, CCHK33, CCHK43, CCHK53, $ CCHKE3, CMMCH C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Data statements .. DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', $ 'CSYR2K'/ DATA IDIM/0,1,2,3,5,9/ DATA ALF/(0.0,0.0),(1.0,0.0),(0.7,-0.9)/ DATA BET/(0.0,0.0),(1.0,0.0),(1.3,-1.1)/ C***FIRST EXECUTABLE STATEMENT CBLAT3 C C Set the flag that indicates whether error exits are to be tested. TSTERR = .TRUE. C Set the threshold value of the test ratio THRESH = 16.0 C C Set IPASS = 1 assuming all tests will pass. C IPASS = 1 C C Report values of parameters. C IF (KPRINT .GE. 3) THEN 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 = 9984 ) END IF WRITE( NOUT, FMT = 9999 )THRESH ENDIF C C Set names of subroutines and flags which indicate C whether they are to be tested. C DO 40 I = 1, NSUBS LTEST( I ) = .TRUE. 40 CONTINUE C C Set EPS (the machine precision). C EPS = R1MACH (4) C C Check the reliability of CMMCH using exact data. C N = MIN( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = MAX( I - J + 1, 0 ) 90 CONTINUE AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 CONTINUE DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 110 CONTINUE C CC holds the exact result. On exit from CMMCH CT holds C the result computed by CMMCH. TRANSA = 'N' TRANSB = 'N' FTL = .FALSE. CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN IPASS = 0 IF (KPRINT .GE. 2) THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR ENDIF END IF TRANSB = 'C' FTL = .FALSE. CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN IPASS = 0 IF (KPRINT .GE. 2) THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR ENDIF END IF DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 CONTINUE DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - $ ( ( J + 1 )*J*( J - 1 ) )/3 130 CONTINUE TRANSA = 'C' TRANSB = 'N' FTL = .FALSE. CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN IPASS = 0 IF (KPRINT .GE. 2 ) THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR ENDIF END IF TRANSB = 'C' FTL = .FALSE. CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN IPASS = 0 IF (KPRINT .GE. 2 ) THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR ENDIF END IF C C Test each subroutine in turn. C DO 200 ISNUM = 1, NSUBS IF( .NOT.LTEST( ISNUM ) )THEN C Subprogram is not to be tested. WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) ELSE C Test error exits. FTL1 = .FALSE. IF( TSTERR )THEN CALL CCHKE3(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) END IF C Test computations. FTL2 = .FALSE. CALL XERCLR GO TO ( 140, 150, 150, 160, 160, 170, 170, $ 180, 180 )ISNUM C Test CGEMM, 01. 140 CALL CCHK13( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 C Test CHEMM, 02, CSYMM, 03. 150 CALL CCHK23( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 C Test CTRMM, 04, CTRSM, 05. 160 CALL CCHK33( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, $ FTL2, NIDIM, IDIM, NALF, ALF, NMAX, AB, $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) GO TO 190 C Test CHERK, 06, CSYRK, 07. 170 CALL CCHK43( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 C Test CHER2K, 08, CSYR2K, 09. 180 CALL CCHK53( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 C 190 IF( FTL1 .OR. FTL2 ) THEN IPASS = 0 ENDIF END IF 200 CONTINUE RETURN C 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', $ 'S THAN', F8.2 ) 9995 FORMAT( ' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9992 FORMAT( ' FOR BETA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9989 FORMAT( ' 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.') 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) C C End of CBLAT3. C END