LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ schk6()

subroutine schk6 ( character*12  sname,
real  eps,
real  thresh,
integer  nout,
integer  ntra,
logical  trace,
logical  rewi,
logical  fatal,
integer  nidim,
integer, dimension( nidim )  idim,
integer  nalf,
real, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
real, dimension( nmax, nmax )  a,
real, dimension( nmax*nmax )  aa,
real, dimension( nmax*nmax )  as,
real, dimension( nmax )  x,
real, dimension( nmax*incmax )  xx,
real, dimension( nmax*incmax )  xs,
real, dimension( nmax )  y,
real, dimension( nmax*incmax )  yy,
real, dimension( nmax*incmax )  ys,
real, dimension( nmax )  yt,
real, dimension( nmax )  g,
real, dimension( nmax, 2 )  z,
integer  iorder 
)

Definition at line 2131 of file c_sblat2.f.

2135*
2136* Tests SSYR2 and SSPR2.
2137*
2138* Auxiliary routine for test program for Level 2 Blas.
2139*
2140* -- Written on 10-August-1987.
2141* Richard Hanson, Sandia National Labs.
2142* Jeremy Du Croz, NAG Central Office.
2143*
2144* .. Parameters ..
2145 REAL ZERO, HALF, ONE
2146 parameter( zero = 0.0, half = 0.5, one = 1.0 )
2147* .. Scalar Arguments ..
2148 REAL EPS, THRESH
2149 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
2150 $ IORDER
2151 LOGICAL FATAL, REWI, TRACE
2152 CHARACTER*12 SNAME
2153* .. Array Arguments ..
2154 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2155 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
2156 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
2157 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
2158 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2159 INTEGER IDIM( NIDIM ), INC( NINC )
2160* .. Local Scalars ..
2161 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
2162 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2163 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2164 $ NARGS, NC, NS
2165 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2166 CHARACTER*1 UPLO, UPLOS
2167 CHARACTER*14 CUPLO
2168 CHARACTER*2 ICH
2169* .. Local Arrays ..
2170 REAL W( 2 )
2171 LOGICAL ISAME( 13 )
2172* .. External Functions ..
2173 LOGICAL LSE, LSERES
2174 EXTERNAL lse, lseres
2175* .. External Subroutines ..
2176 EXTERNAL smake, smvch, csspr2, cssyr2
2177* .. Intrinsic Functions ..
2178 INTRINSIC abs, max
2179* .. Scalars in Common ..
2180 INTEGER INFOT, NOUTC
2181 LOGICAL OK
2182* .. Common blocks ..
2183 COMMON /infoc/infot, noutc, ok
2184* .. Data statements ..
2185 DATA ich/'UL'/
2186* .. Executable Statements ..
2187 full = sname( 9: 9 ).EQ.'y'
2188 packed = sname( 9: 9 ).EQ.'p'
2189* Define the number of arguments.
2190 IF( full )THEN
2191 nargs = 9
2192 ELSE IF( packed )THEN
2193 nargs = 8
2194 END IF
2195*
2196 nc = 0
2197 reset = .true.
2198 errmax = zero
2199*
2200 DO 140 in = 1, nidim
2201 n = idim( in )
2202* Set LDA to 1 more than minimum value if room.
2203 lda = n
2204 IF( lda.LT.nmax )
2205 $ lda = lda + 1
2206* Skip tests if not enough room.
2207 IF( lda.GT.nmax )
2208 $ GO TO 140
2209 IF( packed )THEN
2210 laa = ( n*( n + 1 ) )/2
2211 ELSE
2212 laa = lda*n
2213 END IF
2214*
2215 DO 130 ic = 1, 2
2216 uplo = ich( ic: ic )
2217 IF (uplo.EQ.'U')THEN
2218 cuplo = ' CblasUpper'
2219 ELSE
2220 cuplo = ' CblasLower'
2221 END IF
2222 upper = uplo.EQ.'U'
2223*
2224 DO 120 ix = 1, ninc
2225 incx = inc( ix )
2226 lx = abs( incx )*n
2227*
2228* Generate the vector X.
2229*
2230 transl = half
2231 CALL smake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2232 $ 0, n - 1, reset, transl )
2233 IF( n.GT.1 )THEN
2234 x( n/2 ) = zero
2235 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2236 END IF
2237*
2238 DO 110 iy = 1, ninc
2239 incy = inc( iy )
2240 ly = abs( incy )*n
2241*
2242* Generate the vector Y.
2243*
2244 transl = zero
2245 CALL smake( 'ge', ' ', ' ', 1, n, y, 1, yy,
2246 $ abs( incy ), 0, n - 1, reset, transl )
2247 IF( n.GT.1 )THEN
2248 y( n/2 ) = zero
2249 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2250 END IF
2251*
2252 DO 100 ia = 1, nalf
2253 alpha = alf( ia )
2254 null = n.LE.0.OR.alpha.EQ.zero
2255*
2256* Generate the matrix A.
2257*
2258 transl = zero
2259 CALL smake( sname( 8: 9 ), uplo, ' ', n, n, a,
2260 $ nmax, aa, lda, n - 1, n - 1, reset,
2261 $ transl )
2262*
2263 nc = nc + 1
2264*
2265* Save every datum before calling the subroutine.
2266*
2267 uplos = uplo
2268 ns = n
2269 als = alpha
2270 DO 10 i = 1, laa
2271 as( i ) = aa( i )
2272 10 CONTINUE
2273 ldas = lda
2274 DO 20 i = 1, lx
2275 xs( i ) = xx( i )
2276 20 CONTINUE
2277 incxs = incx
2278 DO 30 i = 1, ly
2279 ys( i ) = yy( i )
2280 30 CONTINUE
2281 incys = incy
2282*
2283* Call the subroutine.
2284*
2285 IF( full )THEN
2286 IF( trace )
2287 $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
2288 $ alpha, incx, incy, lda
2289 IF( rewi )
2290 $ rewind ntra
2291 CALL cssyr2( iorder, uplo, n, alpha, xx, incx,
2292 $ yy, incy, aa, lda )
2293 ELSE IF( packed )THEN
2294 IF( trace )
2295 $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
2296 $ alpha, incx, incy
2297 IF( rewi )
2298 $ rewind ntra
2299 CALL csspr2( iorder, uplo, n, alpha, xx, incx,
2300 $ yy, incy, aa )
2301 END IF
2302*
2303* Check if error-exit was taken incorrectly.
2304*
2305 IF( .NOT.ok )THEN
2306 WRITE( nout, fmt = 9992 )
2307 fatal = .true.
2308 GO TO 160
2309 END IF
2310*
2311* See what data changed inside subroutines.
2312*
2313 isame( 1 ) = uplo.EQ.uplos
2314 isame( 2 ) = ns.EQ.n
2315 isame( 3 ) = als.EQ.alpha
2316 isame( 4 ) = lse( xs, xx, lx )
2317 isame( 5 ) = incxs.EQ.incx
2318 isame( 6 ) = lse( ys, yy, ly )
2319 isame( 7 ) = incys.EQ.incy
2320 IF( null )THEN
2321 isame( 8 ) = lse( as, aa, laa )
2322 ELSE
2323 isame( 8 ) = lseres( sname( 8: 9 ), uplo, n, n,
2324 $ as, aa, lda )
2325 END IF
2326 IF( .NOT.packed )THEN
2327 isame( 9 ) = ldas.EQ.lda
2328 END IF
2329*
2330* If data was incorrectly changed, report and return.
2331*
2332 same = .true.
2333 DO 40 i = 1, nargs
2334 same = same.AND.isame( i )
2335 IF( .NOT.isame( i ) )
2336 $ WRITE( nout, fmt = 9998 )i
2337 40 CONTINUE
2338 IF( .NOT.same )THEN
2339 fatal = .true.
2340 GO TO 160
2341 END IF
2342*
2343 IF( .NOT.null )THEN
2344*
2345* Check the result column by column.
2346*
2347 IF( incx.GT.0 )THEN
2348 DO 50 i = 1, n
2349 z( i, 1 ) = x( i )
2350 50 CONTINUE
2351 ELSE
2352 DO 60 i = 1, n
2353 z( i, 1 ) = x( n - i + 1 )
2354 60 CONTINUE
2355 END IF
2356 IF( incy.GT.0 )THEN
2357 DO 70 i = 1, n
2358 z( i, 2 ) = y( i )
2359 70 CONTINUE
2360 ELSE
2361 DO 80 i = 1, n
2362 z( i, 2 ) = y( n - i + 1 )
2363 80 CONTINUE
2364 END IF
2365 ja = 1
2366 DO 90 j = 1, n
2367 w( 1 ) = z( j, 2 )
2368 w( 2 ) = z( j, 1 )
2369 IF( upper )THEN
2370 jj = 1
2371 lj = j
2372 ELSE
2373 jj = j
2374 lj = n - j + 1
2375 END IF
2376 CALL smvch( 'N', lj, 2, alpha, z( jj, 1 ),
2377 $ nmax, w, 1, one, a( jj, j ), 1,
2378 $ yt, g, aa( ja ), eps, err, fatal,
2379 $ nout, .true. )
2380 IF( full )THEN
2381 IF( upper )THEN
2382 ja = ja + lda
2383 ELSE
2384 ja = ja + lda + 1
2385 END IF
2386 ELSE
2387 ja = ja + lj
2388 END IF
2389 errmax = max( errmax, err )
2390* If got really bad answer, report and return.
2391 IF( fatal )
2392 $ GO TO 150
2393 90 CONTINUE
2394 ELSE
2395* Avoid repeating tests with N.le.0.
2396 IF( n.LE.0 )
2397 $ GO TO 140
2398 END IF
2399*
2400 100 CONTINUE
2401*
2402 110 CONTINUE
2403*
2404 120 CONTINUE
2405*
2406 130 CONTINUE
2407*
2408 140 CONTINUE
2409*
2410* Report result.
2411*
2412 IF( errmax.LT.thresh )THEN
2413 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2414 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2415 ELSE
2416 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2417 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2418 END IF
2419 GO TO 170
2420*
2421 150 CONTINUE
2422 WRITE( nout, fmt = 9995 )j
2423*
2424 160 CONTINUE
2425 WRITE( nout, fmt = 9996 )sname
2426 IF( full )THEN
2427 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, incx,
2428 $ incy, lda
2429 ELSE IF( packed )THEN
2430 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, alpha, incx, incy
2431 END IF
2432*
2433 170 CONTINUE
2434 RETURN
2435*
243610003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2437 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2438 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
243910002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2440 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2441 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
244210001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2443 $ ' (', i6, ' CALL', 'S)' )
244410000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2445 $ ' (', i6, ' CALL', 'S)' )
2446 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2447 $ 'ANGED INCORRECTLY *******' )
2448 9997 FORMAT( ' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2449 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2450 $ ' - SUSPECT *******' )
2451 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2452 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2453 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2454 $ i2, ', Y,', i2, ', AP) .' )
2455 9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2456 $ i2, ', Y,', i2, ', A,', i3, ') .' )
2457 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2458 $ '******' )
2459*
2460* End of SCHK6.
2461*
smvch
subroutine smvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition sblat2.f:2854
lseres
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition sblat2.f:3000
smake
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition sblat2.f:2678
lse
logical function lse(ri, rj, lr)
Definition sblat2.f:2970
Here is the call graph for this function: