LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ schk6()

subroutine schk6 ( character*6  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 
)

Definition at line 2007 of file sblat2.f.

2011 *
2012 * Tests SSYR2 and SSPR2.
2013 *
2014 * Auxiliary routine for test program for Level 2 Blas.
2015 *
2016 * -- Written on 10-August-1987.
2017 * Richard Hanson, Sandia National Labs.
2018 * Jeremy Du Croz, NAG Central Office.
2019 *
2020 * .. Parameters ..
2021  REAL ZERO, HALF, ONE
2022  parameter( zero = 0.0, half = 0.5, one = 1.0 )
2023 * .. Scalar Arguments ..
2024  REAL EPS, THRESH
2025  INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2026  LOGICAL FATAL, REWI, TRACE
2027  CHARACTER*6 SNAME
2028 * .. Array Arguments ..
2029  REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2030  $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
2031  $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
2032  $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
2033  $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2034  INTEGER IDIM( NIDIM ), INC( NINC )
2035 * .. Local Scalars ..
2036  REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
2037  INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2038  $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2039  $ NARGS, NC, NS
2040  LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2041  CHARACTER*1 UPLO, UPLOS
2042  CHARACTER*2 ICH
2043 * .. Local Arrays ..
2044  REAL W( 2 )
2045  LOGICAL ISAME( 13 )
2046 * .. External Functions ..
2047  LOGICAL LSE, LSERES
2048  EXTERNAL lse, lseres
2049 * .. External Subroutines ..
2050  EXTERNAL smake, smvch, sspr2, ssyr2
2051 * .. Intrinsic Functions ..
2052  INTRINSIC abs, max
2053 * .. Scalars in Common ..
2054  INTEGER INFOT, NOUTC
2055  LOGICAL LERR, OK
2056 * .. Common blocks ..
2057  COMMON /infoc/infot, noutc, ok, lerr
2058 * .. Data statements ..
2059  DATA ich/'UL'/
2060 * .. Executable Statements ..
2061  full = sname( 3: 3 ).EQ.'Y'
2062  packed = sname( 3: 3 ).EQ.'P'
2063 * Define the number of arguments.
2064  IF( full )THEN
2065  nargs = 9
2066  ELSE IF( packed )THEN
2067  nargs = 8
2068  END IF
2069 *
2070  nc = 0
2071  reset = .true.
2072  errmax = zero
2073 *
2074  DO 140 in = 1, nidim
2075  n = idim( in )
2076 * Set LDA to 1 more than minimum value if room.
2077  lda = n
2078  IF( lda.LT.nmax )
2079  $ lda = lda + 1
2080 * Skip tests if not enough room.
2081  IF( lda.GT.nmax )
2082  $ GO TO 140
2083  IF( packed )THEN
2084  laa = ( n*( n + 1 ) )/2
2085  ELSE
2086  laa = lda*n
2087  END IF
2088 *
2089  DO 130 ic = 1, 2
2090  uplo = ich( ic: ic )
2091  upper = uplo.EQ.'U'
2092 *
2093  DO 120 ix = 1, ninc
2094  incx = inc( ix )
2095  lx = abs( incx )*n
2096 *
2097 * Generate the vector X.
2098 *
2099  transl = half
2100  CALL smake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2101  $ 0, n - 1, reset, transl )
2102  IF( n.GT.1 )THEN
2103  x( n/2 ) = zero
2104  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2105  END IF
2106 *
2107  DO 110 iy = 1, ninc
2108  incy = inc( iy )
2109  ly = abs( incy )*n
2110 *
2111 * Generate the vector Y.
2112 *
2113  transl = zero
2114  CALL smake( 'GE', ' ', ' ', 1, n, y, 1, yy,
2115  $ abs( incy ), 0, n - 1, reset, transl )
2116  IF( n.GT.1 )THEN
2117  y( n/2 ) = zero
2118  yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2119  END IF
2120 *
2121  DO 100 ia = 1, nalf
2122  alpha = alf( ia )
2123  null = n.LE.0.OR.alpha.EQ.zero
2124 *
2125 * Generate the matrix A.
2126 *
2127  transl = zero
2128  CALL smake( sname( 2: 3 ), uplo, ' ', n, n, a,
2129  $ nmax, aa, lda, n - 1, n - 1, reset,
2130  $ transl )
2131 *
2132  nc = nc + 1
2133 *
2134 * Save every datum before calling the subroutine.
2135 *
2136  uplos = uplo
2137  ns = n
2138  als = alpha
2139  DO 10 i = 1, laa
2140  as( i ) = aa( i )
2141  10 CONTINUE
2142  ldas = lda
2143  DO 20 i = 1, lx
2144  xs( i ) = xx( i )
2145  20 CONTINUE
2146  incxs = incx
2147  DO 30 i = 1, ly
2148  ys( i ) = yy( i )
2149  30 CONTINUE
2150  incys = incy
2151 *
2152 * Call the subroutine.
2153 *
2154  IF( full )THEN
2155  IF( trace )
2156  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2157  $ alpha, incx, incy, lda
2158  IF( rewi )
2159  $ rewind ntra
2160  CALL ssyr2( uplo, n, alpha, xx, incx, yy, incy,
2161  $ aa, lda )
2162  ELSE IF( packed )THEN
2163  IF( trace )
2164  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2165  $ alpha, incx, incy
2166  IF( rewi )
2167  $ rewind ntra
2168  CALL sspr2( uplo, n, alpha, xx, incx, yy, incy,
2169  $ aa )
2170  END IF
2171 *
2172 * Check if error-exit was taken incorrectly.
2173 *
2174  IF( .NOT.ok )THEN
2175  WRITE( nout, fmt = 9992 )
2176  fatal = .true.
2177  GO TO 160
2178  END IF
2179 *
2180 * See what data changed inside subroutines.
2181 *
2182  isame( 1 ) = uplo.EQ.uplos
2183  isame( 2 ) = ns.EQ.n
2184  isame( 3 ) = als.EQ.alpha
2185  isame( 4 ) = lse( xs, xx, lx )
2186  isame( 5 ) = incxs.EQ.incx
2187  isame( 6 ) = lse( ys, yy, ly )
2188  isame( 7 ) = incys.EQ.incy
2189  IF( null )THEN
2190  isame( 8 ) = lse( as, aa, laa )
2191  ELSE
2192  isame( 8 ) = lseres( sname( 2: 3 ), uplo, n, n,
2193  $ as, aa, lda )
2194  END IF
2195  IF( .NOT.packed )THEN
2196  isame( 9 ) = ldas.EQ.lda
2197  END IF
2198 *
2199 * If data was incorrectly changed, report and return.
2200 *
2201  same = .true.
2202  DO 40 i = 1, nargs
2203  same = same.AND.isame( i )
2204  IF( .NOT.isame( i ) )
2205  $ WRITE( nout, fmt = 9998 )i
2206  40 CONTINUE
2207  IF( .NOT.same )THEN
2208  fatal = .true.
2209  GO TO 160
2210  END IF
2211 *
2212  IF( .NOT.null )THEN
2213 *
2214 * Check the result column by column.
2215 *
2216  IF( incx.GT.0 )THEN
2217  DO 50 i = 1, n
2218  z( i, 1 ) = x( i )
2219  50 CONTINUE
2220  ELSE
2221  DO 60 i = 1, n
2222  z( i, 1 ) = x( n - i + 1 )
2223  60 CONTINUE
2224  END IF
2225  IF( incy.GT.0 )THEN
2226  DO 70 i = 1, n
2227  z( i, 2 ) = y( i )
2228  70 CONTINUE
2229  ELSE
2230  DO 80 i = 1, n
2231  z( i, 2 ) = y( n - i + 1 )
2232  80 CONTINUE
2233  END IF
2234  ja = 1
2235  DO 90 j = 1, n
2236  w( 1 ) = z( j, 2 )
2237  w( 2 ) = z( j, 1 )
2238  IF( upper )THEN
2239  jj = 1
2240  lj = j
2241  ELSE
2242  jj = j
2243  lj = n - j + 1
2244  END IF
2245  CALL smvch( 'N', lj, 2, alpha, z( jj, 1 ),
2246  $ nmax, w, 1, one, a( jj, j ), 1,
2247  $ yt, g, aa( ja ), eps, err, fatal,
2248  $ nout, .true. )
2249  IF( full )THEN
2250  IF( upper )THEN
2251  ja = ja + lda
2252  ELSE
2253  ja = ja + lda + 1
2254  END IF
2255  ELSE
2256  ja = ja + lj
2257  END IF
2258  errmax = max( errmax, err )
2259 * If got really bad answer, report and return.
2260  IF( fatal )
2261  $ GO TO 150
2262  90 CONTINUE
2263  ELSE
2264 * Avoid repeating tests with N.le.0.
2265  IF( n.LE.0 )
2266  $ GO TO 140
2267  END IF
2268 *
2269  100 CONTINUE
2270 *
2271  110 CONTINUE
2272 *
2273  120 CONTINUE
2274 *
2275  130 CONTINUE
2276 *
2277  140 CONTINUE
2278 *
2279 * Report result.
2280 *
2281  IF( errmax.LT.thresh )THEN
2282  WRITE( nout, fmt = 9999 )sname, nc
2283  ELSE
2284  WRITE( nout, fmt = 9997 )sname, nc, errmax
2285  END IF
2286  GO TO 170
2287 *
2288  150 CONTINUE
2289  WRITE( nout, fmt = 9995 )j
2290 *
2291  160 CONTINUE
2292  WRITE( nout, fmt = 9996 )sname
2293  IF( full )THEN
2294  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2295  $ incy, lda
2296  ELSE IF( packed )THEN
2297  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2298  END IF
2299 *
2300  170 CONTINUE
2301  RETURN
2302 *
2303  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2304  $ 'S)' )
2305  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2306  $ 'ANGED INCORRECTLY *******' )
2307  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2308  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2309  $ ' - SUSPECT *******' )
2310  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2311  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2312  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2313  $ i2, ', Y,', i2, ', AP) .' )
2314  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2315  $ i2, ', Y,', i2, ', A,', i3, ') .' )
2316  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2317  $ '******' )
2318 *
2319 * End of SCHK6
2320 *
sspr2
subroutine sspr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
SSPR2
Definition: sspr2.f:142
ssyr2
subroutine ssyr2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SSYR2
Definition: ssyr2.f:147
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2942
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:2826
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2972
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2650
Here is the caller graph for this function: