1*DECK SCHK22 2 SUBROUTINE SCHK22 (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 SCHK22 6C***SUBSIDIARY 7C***PURPOSE Quick check for SSYMV, SSBMV and SSPMV. 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 SSYMV, SSBMV and SSPMV. 15C 16C Auxiliary routine for test program for Level 2 Blas. 17C***REFERENCES (NONE) 18C***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE2, SMVCH, SSBMV, SSPMV, 19C SSYMV 20C***REVISION HISTORY (YYMMDD) 21C 870810 DATE WRITTEN 22C 910619 Modified to meet SLATEC code and prologue standards. (BKS) 23C***END PROLOGUE SCHK22 24C .. Parameters .. 25 REAL ZERO, HALF 26 PARAMETER ( ZERO = 0.0, HALF = 0.5 ) 27C .. Scalar Arguments .. 28 LOGICAL FATAL 29 REAL EPS, THRESH 30 INTEGER INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, 31 $ NMAX, NOUT 32 CHARACTER*6 SNAME 33C .. Array Arguments .. 34 REAL 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 REAL 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 LSE, LSERES 54 EXTERNAL LSE, LSERES, NUMXER 55C .. External Subroutines .. 56 EXTERNAL SMAKE2, SMVCH, SSBMV, SSPMV, SSYMV 57C .. Intrinsic Functions .. 58 INTRINSIC ABS, MAX 59C .. Data statements .. 60 DATA ICH/'UL'/ 61C***FIRST EXECUTABLE STATEMENT SCHK22 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 SMAKE2( 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 SMAKE2( '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 SMAKE2( '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 SSYMV( UPLO, N, ALPHA, AA, LDA, XX, 177 $ INCX, BETA, YY, INCY ) 178 ELSE IF( BANDED )THEN 179 CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA, 180 $ XX, INCX, BETA, YY, INCY ) 181 ELSE IF( PACKED )THEN 182 CALL SSPMV( 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 ) = LSE( AS, AA, LAA ) 202 ISAME( 5 ) = LDAS.EQ.LDA 203 ISAME( 6 ) = LSE( XS, XX, LX ) 204 ISAME( 7 ) = INCXS.EQ.INCX 205 ISAME( 8 ) = BLS.EQ.BETA 206 IF( NULL )THEN 207 ISAME( 9 ) = LSE( YS, YY, LY ) 208 ELSE 209 ISAME( 9 ) = LSERES( '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 ) = LSE( AS, AA, LAA ) 217 ISAME( 6 ) = LDAS.EQ.LDA 218 ISAME( 7 ) = LSE( XS, XX, LX ) 219 ISAME( 8 ) = INCXS.EQ.INCX 220 ISAME( 9 ) = BLS.EQ.BETA 221 IF( NULL )THEN 222 ISAME( 10 ) = LSE( YS, YY, LY ) 223 ELSE 224 ISAME( 10 ) = LSERES( '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 ) = LSE( AS, AA, LAA ) 231 ISAME( 5 ) = LSE( XS, XX, LX ) 232 ISAME( 6 ) = INCXS.EQ.INCX 233 ISAME( 7 ) = BLS.EQ.BETA 234 IF( NULL )THEN 235 ISAME( 8 ) = LSE( YS, YY, LY ) 236 ELSE 237 ISAME( 8 ) = LSERES( '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 SMVCH( '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, SNAME, 272 $ UPLO, N, ALPHA, LDA, 273 $ INCX, BETA, INCY 274 ELSE IF( BANDED )THEN 275 WRITE( NOUT, FMT = 9994 )NC, SNAME, 276 $ UPLO, N, K, ALPHA, 277 $ LDA, INCX, BETA, INCY 278 ELSE IF( PACKED )THEN 279 WRITE( NOUT, FMT = 9995 )NC, SNAME, 280 $ UPLO, N, ALPHA, INCX, 281 $ BETA, INCY 282 END IF 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 SCHK22. 332C 333 END 334