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