LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 2135 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 *
2436 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2437  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2438  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2439 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2440  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2441  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2442 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2443  $ ' (', i6, ' CALL', 'S)' )
2444 10000 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 *
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
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:2829
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975

Here is the call graph for this function: