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