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