LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk6 ( 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,
complex, dimension( nalf )  ALF,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  Y,
complex, dimension( nmax*incmax )  YY,
complex, dimension( nmax*incmax )  YS,
complex, dimension( nmax )  YT,
real, dimension( nmax )  G,
complex, dimension( nmax, 2 )  Z,
integer  IORDER 
)

Definition at line 2128 of file c_cblat2.f.

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

Here is the call graph for this function: