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