1*DECK CCHK23
2      SUBROUTINE CCHK23 (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  CCHK23
6C***SUBSIDIARY
7C***PURPOSE  Quick check for CHEMM and CSYMM.
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 CHEMM and CSYMM.
17C
18C  Auxiliary routine for test program for Level 3 Blas.
19C***REFERENCES  (NONE)
20C***ROUTINES CALLED  CHEMM, CMAKE3, CMMCH, CSYMM, LCE, LCERES, NUMXER
21C***REVISION HISTORY  (YYMMDD)
22C   890208  DATE WRITTEN
23C   910619  Modified to meet SLATEC code and prologue standards.  (BKS)
24C***END PROLOGUE  CCHK23
25C     .. Parameters ..
26      COMPLEX            ZERO
27      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
28      REAL               RZERO
29      PARAMETER          ( RZERO = 0.0 )
30C     .. Scalar Arguments ..
31      LOGICAL            FATAL
32      REAL               EPS, THRESH
33      INTEGER            KPRINT, NALF, NBET, NIDIM, NMAX, NOUT
34      CHARACTER*6        SNAME
35C     .. Array Arguments ..
36      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
37     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
38     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
39     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
40     $                   CS( NMAX*NMAX ), CT( NMAX )
41      REAL               G( NMAX )
42      INTEGER            IDIM( NIDIM )
43C     .. Local Scalars ..
44      COMPLEX            ALPHA, ALS, BETA, BLS
45      REAL               ERR, ERRMAX
46      INTEGER            I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
47     $                   LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
48     $                   NARGS, NC, NERR, NS
49      LOGICAL            CONJ, FTL, LEFT, NULL, RESET
50      CHARACTER*1        SIDE, SIDES, UPLO, UPLOS
51      CHARACTER*2        ICHU, ICHS
52C     .. Local Arrays ..
53      LOGICAL            ISAME( 13 )
54C     .. External Functions ..
55      INTEGER            NUMXER
56      LOGICAL            LCE, LCERES
57      EXTERNAL           LCE, LCERES, NUMXER
58C     .. External Subroutines ..
59      EXTERNAL           CHEMM, CSYMM, CMAKE3, CMMCH
60C     .. Intrinsic Functions ..
61      INTRINSIC          ABS, MAX, MIN
62C     .. Data statements ..
63      DATA               ICHS/'LR'/, ICHU/'UL'/
64C***FIRST EXECUTABLE STATEMENT  CCHK23
65      CONJ = SNAME( 2: 3 ).EQ.'HE'
66C
67      NARGS = 12
68      NC = 0
69      RESET = .TRUE.
70      ERRMAX = RZERO
71C
72      DO 100 IM = 1, NIDIM
73         M = IDIM( IM )
74C
75         DO 90 IN = 1, NIDIM
76            N = IDIM( IN )
77C           Set LDC to 1 more than minimum value if room.
78            LDC = M
79            IF( LDC.LT.NMAX )
80     $         LDC = LDC + 1
81C           Skip tests if not enough room.
82            IF( LDC.GT.NMAX )
83     $         GO TO 90
84            LCC = LDC*N
85            NULL = N.LE.0.OR.M.LE.0
86C           Set LDB to 1 more than minimum value if room.
87            LDB = M
88            IF( LDB.LT.NMAX )
89     $         LDB = LDB + 1
90C           Skip tests if not enough room.
91            IF( LDB.GT.NMAX )
92     $         GO TO 90
93            LBB = LDB*N
94C
95C           Generate the matrix B.
96C
97            CALL CMAKE3( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
98     $                  ZERO )
99C
100            DO 80 ICS = 1, 2
101               SIDE = ICHS( ICS: ICS )
102               LEFT = SIDE.EQ.'L'
103C
104               IF( LEFT )THEN
105                  NA = M
106               ELSE
107                  NA = N
108               END IF
109C              Set LDA to 1 more than minimum value if room.
110               LDA = NA
111               IF( LDA.LT.NMAX )
112     $            LDA = LDA + 1
113C              Skip tests if not enough room.
114               IF( LDA.GT.NMAX )
115     $            GO TO 80
116               LAA = LDA*NA
117C
118               DO 70 ICU = 1, 2
119                  UPLO = ICHU( ICU: ICU )
120C
121C                 Generate the hermitian or symmetric matrix A.
122C
123                  CALL CMAKE3(SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX,
124     $                        AA, LDA, RESET, ZERO )
125C
126                  DO 60 IA = 1, NALF
127                     ALPHA = ALF( IA )
128C
129                     DO 50 IB = 1, NBET
130                        BETA = BET( IB )
131C
132C                       Generate the matrix C.
133C
134                        CALL CMAKE3( 'GE', ' ', ' ', M, N, C, NMAX, CC,
135     $                              LDC, RESET, ZERO )
136C
137                        NC = NC + 1
138C
139C                       Save every datum before calling the
140C                       subroutine.
141C
142                        SIDES = SIDE
143                        UPLOS = UPLO
144                        MS = M
145                        NS = N
146                        ALS = ALPHA
147                        DO 10 I = 1, LAA
148                           AS( I ) = AA( I )
149   10                   CONTINUE
150                        LDAS = LDA
151                        DO 20 I = 1, LBB
152                           BS( I ) = BB( I )
153   20                   CONTINUE
154                        LDBS = LDB
155                        BLS = BETA
156                        DO 30 I = 1, LCC
157                           CS( I ) = CC( I )
158   30                   CONTINUE
159                        LDCS = LDC
160C
161C                       Call the subroutine.
162C
163                        IF( CONJ )THEN
164                           CALL CHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
165     $                                 BB, LDB, BETA, CC, LDC )
166                        ELSE
167                           CALL CSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
168     $                                 BB, LDB, BETA, CC, LDC )
169                        END IF
170C
171C                       Check if error-exit was taken incorrectly.
172C
173                        IF( NUMXER(NERR) .NE. 0 )THEN
174                          IF (KPRINT .GE. 2) THEN
175                           WRITE( NOUT, FMT = 9994 )
176                           END IF
177                          FATAL = .TRUE.
178                        END IF
179C
180C                       See what data changed inside subroutines.
181C
182                        ISAME( 1 ) = SIDES.EQ.SIDE
183                        ISAME( 2 ) = UPLOS.EQ.UPLO
184                        ISAME( 3 ) = MS.EQ.M
185                        ISAME( 4 ) = NS.EQ.N
186                        ISAME( 5 ) = ALS.EQ.ALPHA
187                        ISAME( 6 ) = LCE( AS, AA, LAA )
188                        ISAME( 7 ) = LDAS.EQ.LDA
189                        ISAME( 8 ) = LCE( BS, BB, LBB )
190                        ISAME( 9 ) = LDBS.EQ.LDB
191                        ISAME( 10 ) = BLS.EQ.BETA
192                        IF( NULL )THEN
193                           ISAME( 11 ) = LCE( CS, CC, LCC )
194                        ELSE
195                           ISAME( 11 ) = LCERES( 'GE', ' ', M, N, CS,
196     $                                   CC, LDC )
197                        END IF
198                        ISAME( 12 ) = LDCS.EQ.LDC
199C
200C                       If data was incorrectly changed, report and
201C                       return.
202C
203                        DO 40 I = 1, NARGS
204                          IF (.NOT. ISAME( I )) THEN
205                            FATAL = .TRUE.
206                            IF (KPRINT .GE. 2) THEN
207                              WRITE( NOUT, FMT = 9998 )I
208                            ENDIF
209                          ENDIF
210  40                    CONTINUE
211C
212                        FTL = .FALSE.
213                        IF( .NOT.NULL )THEN
214C
215C                          Check the result.
216C
217                           IF( LEFT )THEN
218                              CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A,
219     $                                    NMAX, B, NMAX, BETA, C, NMAX,
220     $                                    CT, G, CC, LDC, EPS, ERR,
221     $                                    FTL, NOUT, .TRUE.,
222     $                                    KPRINT )
223                           ELSE
224                              CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B,
225     $                                    NMAX, A, NMAX, BETA, C, NMAX,
226     $                                    CT, G, CC, LDC, EPS, ERR,
227     $                                    FTL, NOUT, .TRUE., KPRINT )
228                           END IF
229                           ERRMAX = MAX( ERRMAX, ERR )
230                        END IF
231C
232                        IF (FTL) THEN
233                          FATAL = .TRUE.
234                          IF (KPRINT .GE. 3) THEN
235                            WRITE( NOUT, FMT = 9996 )SNAME
236                            WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE,
237     $                         UPLO, M, N, ALPHA, LDA, LDB, BETA,
238     $                         LDC
239                          ENDIF
240                        ENDIF
241   50                CONTINUE
242C
243   60             CONTINUE
244C
245   70          CONTINUE
246C
247   80       CONTINUE
248C
249   90    CONTINUE
250C
251  100 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, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
275     $      '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
276     $      ',', F4.1, '), C,', I3, ')    .' )
277 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
278     $      '******' )
279C
280C     End of CCHK23.
281C
282      END
283