LAPACK  3.9.0
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 2014 of file sblat2.f.

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