1*DECK SBLAT3 2 SUBROUTINE SBLAT3 (NOUT, KPRINT, IPASS) 3C***BEGIN PROLOGUE SBLAT3 4C***PURPOSE Driver for testing Level 3 BLAS single precision 5C subroutines. 6C***LIBRARY SLATEC (BLAS) 7C***CATEGORY A3A 8C***TYPE SINGLE PRECISION (SBLAT3-S, DBLAT3-D, CBLAT3-C) 9C***KEYWORDS BLAS, QUICK CHECK DRIVER 10C***AUTHOR Dongarra, J. J., (ANL) 11C Duff, I., (AERE) 12C Du Croz, J., (NAG) 13C Hammarling, S., (NAG) 14C***DESCRIPTION 15C 16C Test program for the REAL Level 3 Blas. 17C 18C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. 19C A set of level 3 basic linear algebra subprograms. 20C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. 21C***ROUTINES CALLED LSE, R1MACH, SCHK13, SCHK23, SCHK33, SCHK43, 22C SCHK53, SCHKE3, SMMCH, XERCLR 23C***REVISION HISTORY (YYMMDD) 24C 890208 DATE WRITTEN 25C 910619 Modified to meet SLATEC code and prologue standards. (BKS) 26C 930315 Removed unused variables. (WRB) 27C 930618 Code modified to improve PASS/FAIL reporting. (BKS, WRB) 28C 930701 Call to SCHKE5 changed to call to SCHKE3. (BKS) 29C***END PROLOGUE SBLAT3 30C .. Parameters .. 31 INTEGER NSUBS 32 PARAMETER ( NSUBS = 6) 33 REAL ZERO, ONE 34 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 35 INTEGER NMAX, INCMAX 36 PARAMETER ( NMAX = 65, INCMAX = 2 ) 37C .. Scalar Arguments .. 38 INTEGER IPASS, KPRINT 39C .. Local Scalars .. 40 REAL EPS, ERR, THRESH 41 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT 42 PARAMETER (NIDIM=6, NALF=3, NBET=3) 43 LOGICAL SAME, TSTERR, FTL, FTL1, FTL2 44 CHARACTER*1 TRANSA, TRANSB 45C .. Local Arrays .. 46 REAL AB( NMAX, 2*NMAX ), AA( NMAX*NMAX ), 47 $ ALF( NALF ), AS( NMAX*NMAX ), BET( NBET ), 48 $ G( NMAX ), BB( NMAX*NMAX ), 49 $ BS( NMAX*NMAX ), C( NMAX,NMAX), 50 $ CC( NMAX*NMAX ), CS( NMAX*NMAX), 51 $ CT( NMAX), W( 2*NMAX ) 52 INTEGER IDIM( NIDIM ) 53 LOGICAL LTEST( NSUBS ) 54 CHARACTER*6 SNAMES( NSUBS ) 55C .. External Functions .. 56 REAL R1MACH 57 LOGICAL LSE 58 EXTERNAL LSE, R1MACH 59C .. External Subroutines .. 60 EXTERNAL SCHK13, SCHK23, SCHK33, SCHK43, SCHK53, 61 $ SCHKE3, SMMCH 62C .. Intrinsic Functions .. 63 INTRINSIC MAX, MIN 64C .. Data statements .. 65 DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', 66 $ 'SSYRK ', 'SSYR2K'/ 67 DATA IDIM/0,1,2,3,5,9/ 68 DATA ALF/0.0,1.0,0.7/ 69 DATA BET/0.0,1.0,1.3/ 70C***FIRST EXECUTABLE STATEMENT SBLAT3 71C 72C Set the flag that indicates whether error exits are to be tested. 73C 74 TSTERR=.TRUE. 75C 76C Set the threshold value of the test ratio 77C 78 THRESH=16.0 79C 80C Initialize IPASS to 1 assuming everything will pass. 81C 82 IPASS = 1 83C 84C Report values of parameters. 85C 86 IF (KPRINT .GE. 3) THEN 87 WRITE( NOUT, FMT = 9995 ) 88 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) 89 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) 90 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) 91 IF( .NOT.TSTERR )THEN 92 WRITE( NOUT, FMT = 9984 ) 93 END IF 94 WRITE( NOUT, FMT = 9999 )THRESH 95 ENDIF 96C 97C Set names of subroutines and flags which indicate 98C whether they are to be tested. 99C 100 DO 40 I = 1, NSUBS 101 LTEST( I ) = .TRUE. 102 40 CONTINUE 103C 104C Set EPS (the machine precision). 105C 106 EPS = R1MACH (4) 107C 108C Check the reliability of SMMCH using exact data. 109C 110 N = MIN( 32, NMAX ) 111 DO 120 J = 1, N 112 DO 110 I = 1, N 113 AB( I, J ) = MAX( I - J + 1, 0 ) 114 110 CONTINUE 115 AB( J, NMAX + 1 ) = J 116 AB( 1, NMAX + J ) = J 117 C( J, 1 ) = ZERO 118 120 CONTINUE 119 DO 130 J = 1, N 120 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 121 130 CONTINUE 122C CC holds the exact result. On exit from SMMCH CT holds 123C the result computed by SMMCH. 124 TRANSA = 'N' 125 TRANSB = 'N' 126 FTL = .FALSE. 127 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 128 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 129 $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) 130 SAME = LSE( CC, CT, N ) 131 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 132 IPASS = 0 133 IF (KPRINT .GE. 2) THEN 134 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 135 END IF 136 ENDIF 137 TRANSB = 'T' 138 FTL = .FALSE. 139 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 140 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 141 $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) 142 SAME = LSE( CC, CT, N ) 143 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 144 IPASS = 0 145 IF ( KPRINT .GE. 2) THEN 146 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 147 END IF 148 ENDIF 149 DO 125 J = 1, N 150 AB( J, NMAX + 1 ) = N - J + 1 151 AB( 1, NMAX + J ) = N - J + 1 152 125 CONTINUE 153 DO 135 J = 1, N 154 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - 155 $ ( ( J + 1 )*J*( J - 1 ) )/3 156 135 CONTINUE 157 TRANSA = 'T' 158 TRANSB = 'N' 159 FTL = .FALSE. 160 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 161 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 162 $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) 163 SAME = LSE( CC, CT, N ) 164 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 165 IPASS = 0 166 IF ( KPRINT .GE. 2) THEN 167 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 168 END IF 169 END IF 170 TRANSB = 'T' 171 FTL = .FALSE. 172 CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, 173 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, 174 $ NMAX, EPS, ERR, FTL, NOUT, .TRUE., KPRINT ) 175 SAME = LSE( CC, CT, N ) 176 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN 177 IPASS = 0 178 IF ( KPRINT .GE. 2) THEN 179 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR 180 END IF 181 END IF 182C 183C Test each subroutine in turn. 184C 185 DO 210 ISNUM = 1, NSUBS 186 IF( .NOT.LTEST( ISNUM ) )THEN 187C Subprogram is not to be tested. 188 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) 189 ELSE 190C Test error exits. 191 FTL1 = .FALSE. 192 IF( TSTERR )THEN 193 CALL SCHKE3(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) 194 END IF 195C Test computations. 196 FTL2 = .FALSE. 197 CALL XERCLR 198 GO TO ( 140, 150, 160, 160, 170, 180) ISNUM 199C Test SGEMM, 01. 200 140 CALL SCHK13( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, 201 $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, 202 $ NMAX, AB, AA, AS, AB(1, NMAX + 1), 203 $ BB, BS, C, CC, CS, CT, G ) 204 GO TO 200 205C Test SSYMM, 02. 206 150 CALL SCHK23( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, 207 $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, 208 $ NMAX, AB, AA, AS, AB(1, NMAX + 1), 209 $ BB, BS, C, CC, CS, CT, G ) 210 GO TO 200 211C Test STRMM, 03, STRSM, 04. 212 160 CALL SCHK33( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, 213 $ FTL2, NIDIM, IDIM, NALF, ALF, NMAX, AB, 214 $ AA, AS ,AB(1, NMAX + 1), BB, BS, CT, G, C) 215 GO TO 200 216C Test SSYRK, 05. 217 170 CALL SCHK43( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, 218 $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, 219 $ NMAX, AB, AA, AS, AB(1, NMAX + 1), BB, BS, C, 220 $ CC, CS, CT, G ) 221 GO TO 200 222C Test SSYR2K, 06. 223 180 CALL SCHK53( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, 224 $ FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, 225 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W) 226 GO TO 200 227 200 IF (FTL1 .OR. FTL2) THEN 228 IPASS = 0 229 ENDIF 230 END IF 231 210 CONTINUE 232 RETURN 233C 234 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', 235 $ 'S THAN', F8.2 ) 236 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', 237 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 238 9994 FORMAT( ' FOR N ', 9I6 ) 239 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) 240 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 241 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', 242 $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, 243 $ ' AND TRANSB = ', A1, 244 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / 245 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE', 246 $ ' COMPILER.') 247 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 248 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 249C 250C End of SBLAT3. 251C 252 END 253