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