1*DECK DCHK22 2 SUBROUTINE DCHK22 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, 3 $ IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, 4 $ A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) 5C***BEGIN PROLOGUE DCHK22 6C***SUBSIDIARY 7C***PURPOSE Test DSYMV, DSBMV and DSPMV. 8C***LIBRARY SLATEC (BLAS) 9C***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE 10C***AUTHOR Du Croz, J. (NAG) 11C Hanson, R. J. (SNLA) 12C***DESCRIPTION 13C 14C Quick check for DSYMV, DSBMV and DSPMV. 15C 16C Auxiliary routine for test program for Level 2 Blas. 17C***REFERENCES (NONE) 18C***ROUTINES CALLED DMAKE2, DMVCH, DSBMV, DSPMV, DSYMV, LDE, LDERES, 19C NUMXER 20C***REVISION HISTORY (YYMMDD) 21C 870810 DATE WRITTEN 22C 910619 Modified to meet SLATEC code and prologue standards. (BKS) 23C***END PROLOGUE DCHK22 24C .. Parameters .. 25 DOUBLE PRECISION ZERO, HALF 26 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) 27C .. Scalar Arguments .. 28 LOGICAL FATAL 29 DOUBLE PRECISION EPS, THRESH 30 INTEGER INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, 31 $ NMAX, NOUT 32 CHARACTER*6 SNAME 33C .. Array Arguments .. 34 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 35 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), 36 $ X( NMAX ), XS( NMAX*INCMAX ), 37 $ XX( NMAX*INCMAX ), Y( NMAX ), 38 $ YS( NMAX*INCMAX ), YT( NMAX ), 39 $ YY( NMAX*INCMAX ) 40 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 41C .. Local Scalars .. 42 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL 43 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, 44 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, 45 $ N, NARGS, NC, NK, NS, NERR 46 LOGICAL BANDED, FTL, FULL, NULL, PACKED, RESET 47 CHARACTER*1 UPLO, UPLOS 48 CHARACTER*2 ICH 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 DMAKE2, DMVCH, DSBMV, DSPMV, DSYMV 57C .. Intrinsic Functions .. 58 INTRINSIC ABS, MAX 59C .. Data statements .. 60 DATA ICH/'UL'/ 61C***FIRST EXECUTABLE STATEMENT DCHK22 62 FULL = SNAME( 3: 3 ).EQ.'Y' 63 BANDED = SNAME( 3: 3 ).EQ.'B' 64 PACKED = SNAME( 3: 3 ).EQ.'P' 65C Define the number of arguments. 66 IF( FULL )THEN 67 NARGS = 10 68 ELSE IF( BANDED )THEN 69 NARGS = 11 70 ELSE IF( PACKED )THEN 71 NARGS = 9 72 END IF 73C 74 NC = 0 75 RESET = .TRUE. 76 ERRMAX = ZERO 77C 78 DO 110 IN = 1, NIDIM 79 N = IDIM( IN ) 80C 81 IF( BANDED )THEN 82 NK = NKB 83 ELSE 84 NK = 1 85 END IF 86 DO 100 IK = 1, NK 87 IF( BANDED )THEN 88 K = KB( IK ) 89 ELSE 90 K = N - 1 91 END IF 92C Set LDA to 1 more than minimum value if room. 93 IF( BANDED )THEN 94 LDA = K + 1 95 ELSE 96 LDA = N 97 END IF 98 IF( LDA.LT.NMAX ) 99 $ LDA = LDA + 1 100C Skip tests if not enough room. 101 IF( LDA.GT.NMAX ) 102 $ GO TO 100 103 IF( PACKED )THEN 104 LAA = ( N*( N + 1 ) )/2 105 ELSE 106 LAA = LDA*N 107 END IF 108 NULL = N.LE.0 109C 110 DO 90 IC = 1, 2 111 UPLO = ICH( IC: IC ) 112C 113C Generate the matrix A. 114C 115 TRANSL = ZERO 116 CALL DMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, 117 $ LDA, K, K, RESET, TRANSL ) 118C 119 DO 80 IX = 1, NINC 120 INCX = INC( IX ) 121 LX = ABS( INCX )*N 122C 123C Generate the vector X. 124C 125 TRANSL = HALF 126 CALL DMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, 127 $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) 128 IF( N.GT.1 )THEN 129 X( N/2 ) = ZERO 130 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 131 END IF 132C 133 DO 70 IY = 1, NINC 134 INCY = INC( IY ) 135 LY = ABS( INCY )*N 136C 137 DO 60 IA = 1, NALF 138 ALPHA = ALF( IA ) 139C 140 DO 50 IB = 1, NBET 141 BETA = BET( IB ) 142C 143C Generate the vector Y. 144C 145 TRANSL = ZERO 146 CALL DMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, 147 $ ABS( INCY ), 0, N - 1, RESET, 148 $ TRANSL ) 149C 150 NC = NC + 1 151C 152C Save every datum before calling the 153C subroutine. 154C 155 UPLOS = UPLO 156 NS = N 157 KS = K 158 ALS = ALPHA 159 DO 10 I = 1, LAA 160 AS( I ) = AA( I ) 161 10 CONTINUE 162 LDAS = LDA 163 DO 20 I = 1, LX 164 XS( I ) = XX( I ) 165 20 CONTINUE 166 INCXS = INCX 167 BLS = BETA 168 DO 30 I = 1, LY 169 YS( I ) = YY( I ) 170 30 CONTINUE 171 INCYS = INCY 172C 173C Call the subroutine. 174C 175 IF( FULL )THEN 176 CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX, 177 $ INCX, BETA, YY, INCY ) 178 ELSE IF( BANDED )THEN 179 CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA, 180 $ XX, INCX, BETA, YY, INCY ) 181 ELSE IF( PACKED )THEN 182 CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX, 183 $ BETA, YY, INCY ) 184 END IF 185C 186C Check if error-exit was taken incorrectly. 187C 188 IF( NUMXER(NERR) .NE. 0 )THEN 189 IF (KPRINT .GE. 2) THEN 190 WRITE( NOUT, FMT = 9992 ) 191 ENDIF 192 FATAL = .TRUE. 193 END IF 194C 195C See what data changed inside subroutines. 196C 197 ISAME( 1 ) = UPLO.EQ.UPLOS 198 ISAME( 2 ) = NS.EQ.N 199 IF( FULL )THEN 200 ISAME( 3 ) = ALS.EQ.ALPHA 201 ISAME( 4 ) = LDE( AS, AA, LAA ) 202 ISAME( 5 ) = LDAS.EQ.LDA 203 ISAME( 6 ) = LDE( XS, XX, LX ) 204 ISAME( 7 ) = INCXS.EQ.INCX 205 ISAME( 8 ) = BLS.EQ.BETA 206 IF( NULL )THEN 207 ISAME( 9 ) = LDE( YS, YY, LY ) 208 ELSE 209 ISAME( 9 ) = LDERES( 'GE', ' ', 1, N, 210 $ YS, YY, ABS( INCY ) ) 211 END IF 212 ISAME( 10 ) = INCYS.EQ.INCY 213 ELSE IF( BANDED )THEN 214 ISAME( 3 ) = KS.EQ.K 215 ISAME( 4 ) = ALS.EQ.ALPHA 216 ISAME( 5 ) = LDE( AS, AA, LAA ) 217 ISAME( 6 ) = LDAS.EQ.LDA 218 ISAME( 7 ) = LDE( XS, XX, LX ) 219 ISAME( 8 ) = INCXS.EQ.INCX 220 ISAME( 9 ) = BLS.EQ.BETA 221 IF( NULL )THEN 222 ISAME( 10 ) = LDE( YS, YY, LY ) 223 ELSE 224 ISAME( 10 ) = LDERES( 'GE', ' ', 1, N, 225 $ YS, YY, ABS( INCY ) ) 226 END IF 227 ISAME( 11 ) = INCYS.EQ.INCY 228 ELSE IF( PACKED )THEN 229 ISAME( 3 ) = ALS.EQ.ALPHA 230 ISAME( 4 ) = LDE( AS, AA, LAA ) 231 ISAME( 5 ) = LDE( XS, XX, LX ) 232 ISAME( 6 ) = INCXS.EQ.INCX 233 ISAME( 7 ) = BLS.EQ.BETA 234 IF( NULL )THEN 235 ISAME( 8 ) = LDE( YS, YY, LY ) 236 ELSE 237 ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, 238 $ YS, YY, ABS( INCY ) ) 239 END IF 240 ISAME( 9 ) = INCYS.EQ.INCY 241 END IF 242C 243C If data was incorrectly changed, report and 244C return. 245C 246 DO 40 I = 1, NARGS 247 IF (.NOT. ISAME( I )) THEN 248 FATAL = .TRUE. 249 IF (KPRINT .GE. 2) THEN 250 WRITE( NOUT, FMT = 9998 )I 251 ENDIF 252 ENDIF 253 40 CONTINUE 254C 255 FTL = .FALSE. 256 IF( .NOT.NULL )THEN 257C 258C Check the result. 259C 260 CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X, 261 $ INCX, BETA, Y, INCY, YT, G, 262 $ YY, EPS, ERR, FTL, NOUT, 263 $ .TRUE., KPRINT ) 264 ERRMAX = MAX( ERRMAX, ERR ) 265 END IF 266 IF (FTL) THEN 267 FATAL = .TRUE. 268 IF (KPRINT .GE. 3) THEN 269 WRITE( NOUT, FMT = 9996 )SNAME 270 IF( FULL )THEN 271 WRITE( NOUT, FMT = 9993 )NC, 272 $ SNAME, UPLO, N, ALPHA, 273 $ LDA, INCX, BETA, INCY 274 ELSE IF( BANDED )THEN 275 WRITE( NOUT, FMT = 9994 )NC, 276 $ SNAME, UPLO, N, ALPHA, 277 $ INCX, BETA, INCY 278 ELSE IF( PACKED )THEN 279 WRITE( NOUT, FMT = 9995 )NC, 280 $ SNAME, UPLO, N, ALPHA, INCX, 281 $ BETA, INCY 282 ENDIF 283 ENDIF 284 ENDIF 285C 286 50 CONTINUE 287C 288 60 CONTINUE 289C 290 70 CONTINUE 291C 292 80 CONTINUE 293C 294 90 CONTINUE 295C 296 100 CONTINUE 297C 298 110 CONTINUE 299C 300C Report result. 301C 302 IF (.NOT. FATAL) THEN 303 IF (KPRINT .GE. 3) THEN 304 IF( ERRMAX.LT.THRESH )THEN 305 WRITE( NOUT, FMT = 9999 )SNAME, NC 306 ELSE 307 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 308 END IF 309 ENDIF 310 ENDIF 311 RETURN 312C 313 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 314 $ 'S)' ) 315 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 316 $ 'ANGED INCORRECTLY *******' ) 317 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 318 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 319 $ ' - SUSPECT *******' ) 320 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 321 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', 322 $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 323 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, 324 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, 325 $ ') .' ) 326 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', 327 $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 328 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 329 $ '******' ) 330C 331C End of DCHK22. 332C 333 END 334