1*DECK DCHK13 2 SUBROUTINE DCHK13 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, 3 $ IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, 4 $ CS, CT, G) 5C***BEGIN PROLOGUE DCHK13 6C***SUBSIDIARY 7C***PURPOSE Test DGEMM. 8C***LIBRARY SLATEC (BLAS) 9C***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE 10C***AUTHOR Dongarra, J. J., (ANL) 11C Duff, I., (AERE) 12C Du Croz, J., (NAG) 13C Hammarling, S., (NAG) 14C***DESCRIPTION 15C 16C Quick check for DGEMM. 17C 18C Auxiliary routine for test program for Level 3 Blas. 19C***REFERENCES (NONE) 20C***ROUTINES CALLED DGEMM, DMAKE3, DMMCH, LDE, LDERES, NUMXER 21C***REVISION HISTORY (YYMMDD) 22C 890208 DATE WRITTEN 23C 910619 Modified to meet SLATEC code and prologue standards. (BKS) 24C***END PROLOGUE DCHK13 25C .. Parameters .. 26 DOUBLE PRECISION ZERO 27 PARAMETER ( ZERO = 0.0D0) 28C .. Scalar Arguments .. 29 LOGICAL FATAL 30 DOUBLE PRECISION EPS, THRESH 31 INTEGER KPRINT, NALF, NBET, NIDIM, NMAX, NOUT 32 CHARACTER*6 SNAME 33C .. Array Arguments .. 34 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 35 $ AS( NMAX*NMAX ), G( NMAX ), 36 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), 37 $ C( NMAX, NMAX ), CC( NMAX*NMAX ), 38 $ CS( NMAX*NMAX ), CT( NMAX ), B( NMAX, NMAX) 39 INTEGER IDIM( NIDIM ) 40C .. Local Scalars .. 41 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX 42 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, 43 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, 44 $ MA, MB, MS, N, NA, NARGS, NB, NC, NERR, NS 45 LOGICAL FTL, NULL, RESET, TRANA, TRANB 46 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB 47 CHARACTER*3 ICH 48C .. Local Arrays .. 49 LOGICAL ISAME( 13 ) 50C .. External Functions .. 51 INTEGER NUMXER 52 LOGICAL LDE, LDERES 53 EXTERNAL LDE, LDERES, NUMXER 54C .. External Subroutines .. 55 EXTERNAL DGEMM, DMAKE3, DMMCH 56C .. Intrinsic Functions .. 57 INTRINSIC ABS, MAX, MIN 58C .. Data statements .. 59 DATA ICH/'NTC'/ 60C***FIRST EXECUTABLE STATEMENT DCHK13 61 NARGS = 13 62 NC = 0 63 RESET = .TRUE. 64 ERRMAX = ZERO 65C 66 DO 110 IM = 1, NIDIM 67 M = IDIM( IM ) 68C 69 DO 100 IN = 1, NIDIM 70 N = IDIM( IN ) 71C Set LDC to 1 more than minimum value if room. 72 LDC = M 73 IF( LDC.LT.NMAX ) 74 $ LDC = LDC + 1 75C Skip tests if not enough room. 76 IF( LDC.GT.NMAX ) 77 $ GO TO 100 78 LCC = LDC*N 79 NULL = N.LE.0.OR.M.LE.0 80C 81 DO 90 IK = 1, NIDIM 82 K = IDIM( IK ) 83C 84 DO 80 ICA = 1, 3 85 TRANSA = ICH( ICA: ICA ) 86 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' 87C 88 IF( TRANA )THEN 89 MA = K 90 NA = M 91 ELSE 92 MA = M 93 NA = K 94 END IF 95C Set LDA to 1 more than minimum value if room. 96 LDA = MA 97 IF( LDA.LT.NMAX ) 98 $ LDA = LDA + 1 99C Skip tests if not enough room. 100 IF( LDA.GT.NMAX ) 101 $ GO TO 80 102 LAA = LDA*NA 103C 104C Generate the matrix A. 105C 106 CALL DMAKE3( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, 107 $ RESET, ZERO ) 108C 109 DO 70 ICB = 1, 3 110 TRANSB = ICH( ICB: ICB ) 111 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' 112C 113 IF( TRANB )THEN 114 MB = N 115 NB = K 116 ELSE 117 MB = K 118 NB = N 119 END IF 120C Set LDB to 1 more than minimum value if room. 121 LDB = MB 122 IF( LDB.LT.NMAX ) 123 $ LDB = LDB + 1 124C Skip tests if not enough room. 125 IF( LDB.GT.NMAX ) 126 $ GO TO 70 127 LBB = LDB*NB 128C 129C Generate the matrix B. 130C 131 CALL DMAKE3( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, 132 $ LDB, RESET, ZERO ) 133C 134 DO 60 IA = 1, NALF 135 ALPHA = ALF( IA ) 136C 137 DO 50 IB = 1, NBET 138 BETA = BET( IB ) 139C 140C Generate the matrix C. 141C 142 CALL DMAKE3( 'GE', ' ', ' ', M, N, C, NMAX, 143 $ CC, LDC, RESET, ZERO ) 144C 145 NC = NC + 1 146C 147C Save every datum before calling the 148C subroutine. 149C 150 TRANAS = TRANSA 151 TRANBS = TRANSB 152 MS = M 153 NS = N 154 KS = K 155 ALS = ALPHA 156 DO 10 I = 1, LAA 157 AS( I ) = AA( I ) 158 10 CONTINUE 159 LDAS = LDA 160 DO 20 I = 1, LBB 161 BS( I ) = BB( I ) 162 20 CONTINUE 163 LDBS = LDB 164 BLS = BETA 165 DO 30 I = 1, LCC 166 CS( I ) = CC( I ) 167 30 CONTINUE 168 LDCS = LDC 169C 170C Call the subroutine. 171C 172 CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA, 173 $ AA, LDA, BB, LDB, BETA, CC, LDC ) 174C 175C Check if error-exit was taken incorrectly. 176C 177 IF( NUMXER(NERR) .NE. 0 )THEN 178 IF (KPRINT .GE. 2) THEN 179 WRITE( NOUT, FMT = 9994 ) 180 END IF 181 FATAL = .TRUE. 182 END IF 183C 184C See what data changed inside subroutines. 185C 186 ISAME( 1 ) = TRANSA.EQ.TRANAS 187 ISAME( 2 ) = TRANSB.EQ.TRANBS 188 ISAME( 3 ) = MS.EQ.M 189 ISAME( 4 ) = NS.EQ.N 190 ISAME( 5 ) = KS.EQ.K 191 ISAME( 6 ) = ALS.EQ.ALPHA 192 ISAME( 7 ) = LDE( AS, AA, LAA ) 193 ISAME( 8 ) = LDAS.EQ.LDA 194 ISAME( 9 ) = LDE( BS, BB, LBB ) 195 ISAME( 10 ) = LDBS.EQ.LDB 196 ISAME( 11 ) = BLS.EQ.BETA 197 IF( NULL )THEN 198 ISAME( 12 ) = LDE( CS, CC, LCC ) 199 ELSE 200 ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, 201 $ CC, LDC ) 202 END IF 203 ISAME( 13 ) = LDCS.EQ.LDC 204C 205C If data was incorrectly changed, report 206C and return. 207C 208 DO 40 I = 1, NARGS 209 IF (.NOT. ISAME( I )) THEN 210 FATAL = .TRUE. 211 IF (KPRINT .GE. 2) THEN 212 WRITE( NOUT, FMT = 9998 )I 213 ENDIF 214 ENDIF 215 40 CONTINUE 216C 217 FTL = .FALSE. 218 IF( .NOT.NULL )THEN 219C 220C Check the result. 221C 222 CALL DMMCH( TRANSA, TRANSB, M, N, K, 223 $ ALPHA, A, NMAX, B, NMAX, BETA, 224 $ C, NMAX, CT, G, CC, LDC, EPS, 225 $ ERR, FTL, NOUT, .TRUE., 226 $ KPRINT) 227 ERRMAX = MAX( ERRMAX, ERR ) 228 END IF 229 IF (FTL) THEN 230 FATAL = .TRUE. 231 IF (KPRINT .GE. 3) THEN 232 WRITE( NOUT, FMT = 9996 )SNAME 233 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, 234 $ TRANSB, M, N, K, ALPHA, LDA, LDB, BETA, 235 $ LDC 236 ENDIF 237 ENDIF 238C 239 50 CONTINUE 240C 241 60 CONTINUE 242C 243 70 CONTINUE 244C 245 80 CONTINUE 246C 247 90 CONTINUE 248C 249 100 CONTINUE 250C 251 110 CONTINUE 252C 253C Report result. 254C 255 IF (.NOT. FATAL) THEN 256 IF (KPRINT .GE. 3) THEN 257 IF( ERRMAX.LT.THRESH )THEN 258 WRITE( NOUT, FMT = 9999 )SNAME, NC 259 ELSE 260 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 261 END IF 262 ENDIF 263 ENDIF 264 RETURN 265C 266 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 267 $ 'S)' ) 268 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 269 $ 'ANGED INCORRECTLY *******' ) 270 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 271 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 272 $ ' - SUSPECT *******' ) 273 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 274 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', 275 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', 276 $ 'C,', I3, ').' ) 277 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 278 $ '******' ) 279C 280C End of DCHK13. 281C 282 END 283