1*DECK DCHK53 2 SUBROUTINE DCHK53 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, 3 $ IDIM, NALF, ALF, NBET, BET, NMAX, AB, AA, AS, BB, BS, C, CC, 4 $ CS, CT, G, W) 5C***BEGIN PROLOGUE DCHK53 6C***SUBSIDIARY 7C***PURPOSE Test DSYR2K. 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 DSYR2K. 17C 18C Auxiliary routine for test program for Level 3 Blas. 19C***REFERENCES (NONE) 20C***ROUTINES CALLED DMAKE3, DMMCH, DSYR2K, 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 DCHK53 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 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), 35 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), 36 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), 37 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), 38 $ G( NMAX ), W( 2*NMAX ) 39 INTEGER IDIM( NIDIM ) 40C .. Local Scalars .. 41 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX 42 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, 43 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, 44 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NERR, NS 45 LOGICAL FTL, NULL, RESET, TRAN, UPPER 46 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS 47 CHARACTER*2 ICHU 48 CHARACTER*3 ICHT 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 DSYR2K, DMAKE3, DMMCH 57C .. Intrinsic Functions .. 58 INTRINSIC ABS, MAX, MIN 59C .. Data statements .. 60 DATA ICHU/'UL'/, ICHT/'NTC'/ 61C***FIRST EXECUTABLE STATEMENT DCHK53 62 NARGS = 12 63 NC = 0 64 RESET = .TRUE. 65 ERRMAX = ZERO 66C 67 DO 130 IN = 1, NIDIM 68 N = IDIM( IN ) 69C Set LDC to 1 more than minimum value if room. 70 LDC = N 71 IF( LDC.LT.NMAX ) 72 $ LDC = LDC + 1 73C Skip tests if not enough room. 74 IF( LDC.GT.NMAX ) 75 $ GO TO 130 76 LCC = LDC*N 77 NULL = N.LE.0 78C 79 DO 120 IK = 1, NIDIM 80 K = IDIM( IK ) 81C 82 DO 110 ICT = 1, 3 83 TRANS = ICHT( ICT: ICT ) 84 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 85 IF( TRAN )THEN 86 MA = K 87 NA = N 88 ELSE 89 MA = N 90 NA = K 91 END IF 92C Set LDA to 1 more than minimum value if room. 93 LDA = MA 94 IF( LDA.LT.NMAX ) 95 $ LDA = LDA + 1 96C Skip tests if not enough room. 97 IF( LDA.GT.NMAX ) 98 $ GO TO 110 99 LAA = LDA*NA 100C 101C Generate the matrix A. 102C 103 IF( TRAN )THEN 104 CALL DMAKE3( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, 105 $ LDA, RESET, ZERO ) 106 ELSE 107 CALL DMAKE3('GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, 108 $ RESET, ZERO ) 109 END IF 110C 111C Generate the matrix B. 112C 113 LDB = LDA 114 LBB = LAA 115 IF( TRAN )THEN 116 CALL DMAKE3( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), 117 $ 2*NMAX, BB, LDB, RESET, ZERO ) 118 ELSE 119 CALL DMAKE3( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), 120 $ NMAX, BB, LDB, RESET, ZERO ) 121 END IF 122C 123 DO 100 ICU = 1, 2 124 UPLO = ICHU( ICU: ICU ) 125 UPPER = UPLO.EQ.'U' 126C 127 DO 90 IA = 1, NALF 128 ALPHA = ALF( IA ) 129C 130 DO 80 IB = 1, NBET 131 BETA = BET( IB ) 132C 133C Generate the matrix C. 134C 135 CALL DMAKE3( 'SY', UPLO, ' ', N, N, C, NMAX, CC, 136 $ LDC, RESET, ZERO ) 137C 138 NC = NC + 1 139C 140C Save every datum before calling the subroutine. 141C 142 UPLOS = UPLO 143 TRANSS = TRANS 144 NS = N 145 KS = K 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 BETS = 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 CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, 164 $ BB, LDB, BETA, CC, LDC ) 165C 166C Check if error-exit was taken incorrectly. 167C 168 IF( NUMXER(NERR) .NE. 0 )THEN 169 IF (KPRINT .GE. 2) THEN 170 WRITE( NOUT, FMT = 9993 ) 171 END IF 172 FATAL = .TRUE. 173 END IF 174C 175C See what data changed inside subroutines. 176C 177 ISAME( 1 ) = UPLOS.EQ.UPLO 178 ISAME( 2 ) = TRANSS.EQ.TRANS 179 ISAME( 3 ) = NS.EQ.N 180 ISAME( 4 ) = KS.EQ.K 181 ISAME( 5 ) = ALS.EQ.ALPHA 182 ISAME( 6 ) = LDE( AS, AA, LAA ) 183 ISAME( 7 ) = LDAS.EQ.LDA 184 ISAME( 8 ) = LDE( BS, BB, LBB ) 185 ISAME( 9 ) = LDBS.EQ.LDB 186 ISAME( 10 ) = BETS.EQ.BETA 187 IF( NULL )THEN 188 ISAME( 11 ) = LDE( CS, CC, LCC ) 189 ELSE 190 ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, 191 $ CC, LDC ) 192 END IF 193 ISAME( 12 ) = LDCS.EQ.LDC 194C 195C If data was incorrectly changed, report and 196C return. 197C 198 DO 40 I = 1, NARGS 199 IF (.NOT. ISAME( I )) THEN 200 FATAL = .TRUE. 201 IF (KPRINT .GE. 2) THEN 202 WRITE( NOUT, FMT = 9998 )I 203 ENDIF 204 ENDIF 205 40 CONTINUE 206C 207 FTL = .FALSE. 208 IF( .NOT.NULL )THEN 209C 210C Check the result column by column. 211C 212 JJAB = 1 213 JC = 1 214 DO 70 J = 1, N 215 IF( UPPER )THEN 216 JJ = 1 217 LJ = J 218 ELSE 219 JJ = J 220 LJ = N - J + 1 221 END IF 222 IF( TRAN )THEN 223 DO 50 I = 1, K 224 W( I ) = AB( ( J - 1 )*2*NMAX + K + 225 $ I ) 226 W( K + I ) = AB( ( J - 1 )*2*NMAX + 227 $ I ) 228 50 CONTINUE 229 CALL DMMCH( 'T', 'N', LJ, 1, 2*K, 230 $ ALPHA, AB( JJAB ), 2*NMAX, 231 $ W, 2*NMAX, BETA, 232 $ C( JJ, J ), NMAX, CT, G, 233 $ CC( JC ), LDC, EPS, ERR, 234 $ FTL, NOUT, .TRUE., 235 $ KPRINT ) 236 ELSE 237 DO 60 I = 1, K 238 W( I ) = AB( ( K + I - 1 )*NMAX + 239 $ J ) 240 W( K + I ) = AB( ( I - 1 )*NMAX + 241 $ J ) 242 60 CONTINUE 243 CALL DMMCH( 'N', 'N', LJ, 1, 2*K, 244 $ ALPHA, AB( JJ ), NMAX, W, 245 $ 2*NMAX, BETA, C( JJ, J ), 246 $ NMAX, CT, G, CC( JC ), LDC, 247 $ EPS, ERR, FTL, NOUT, 248 $ .TRUE., KPRINT ) 249 END IF 250 IF( UPPER )THEN 251 JC = JC + LDC 252 ELSE 253 JC = JC + LDC + 1 254 IF( TRAN ) 255 $ JJAB = JJAB + 2*NMAX 256 END IF 257 ERRMAX = MAX( ERRMAX, ERR ) 258 70 CONTINUE 259 END IF 260 IF (FTL) THEN 261 FATAL = .TRUE. 262 IF (KPRINT .GE. 3) THEN 263 WRITE( NOUT, FMT = 9996 )SNAME 264 WRITE( NOUT, FMT = 9994 )NC, 265 $ SNAME, UPLO, TRANS, 266 $ N, K, ALPHA, LDA, LDB, 267 $ BETA, LDC 268 ENDIF 269 ENDIF 270C 271 80 CONTINUE 272C 273 90 CONTINUE 274C 275 100 CONTINUE 276C 277 110 CONTINUE 278C 279 120 CONTINUE 280C 281 130 CONTINUE 282C 283C Report result. 284C 285 IF (.NOT. FATAL) THEN 286 IF (KPRINT .GE. 3) THEN 287 IF( ERRMAX.LT.THRESH )THEN 288 WRITE( NOUT, FMT = 9999 )SNAME, NC 289 ELSE 290 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 291 END IF 292 ENDIF 293 ENDIF 294 RETURN 295C 296 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 297 $ 'S)' ) 298 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 299 $ 'ANGED INCORRECTLY *******' ) 300 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 301 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 302 $ ' - SUSPECT *******' ) 303 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 304 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), 305 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', 306 $ ' .' ) 307 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 308 $ '******' ) 309C 310C End of DCHK53. 311C 312 END 313