LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk6 ( 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,
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 
)

Definition at line 2056 of file cblat2.f.

2056 *
2057 * Tests CHER2 and CHPR2.
2058 *
2059 * Auxiliary routine for test program for Level 2 Blas.
2060 *
2061 * -- Written on 10-August-1987.
2062 * Richard Hanson, Sandia National Labs.
2063 * Jeremy Du Croz, NAG Central Office.
2064 *
2065 * .. Parameters ..
2066  COMPLEX zero, half, one
2067  parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
2068  $ one = ( 1.0, 0.0 ) )
2069  REAL rzero
2070  parameter ( rzero = 0.0 )
2071 * .. Scalar Arguments ..
2072  REAL eps, thresh
2073  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
2074  LOGICAL fatal, rewi, trace
2075  CHARACTER*6 sname
2076 * .. Array Arguments ..
2077  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
2078  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
2079  $ xx( nmax*incmax ), y( nmax ),
2080  $ ys( nmax*incmax ), yt( nmax ),
2081  $ yy( nmax*incmax ), z( nmax, 2 )
2082  REAL g( nmax )
2083  INTEGER idim( nidim ), inc( ninc )
2084 * .. Local Scalars ..
2085  COMPLEX alpha, als, transl
2086  REAL err, errmax
2087  INTEGER i, ia, ic, in, incx, incxs, incy, incys, ix,
2088  $ iy, j, ja, jj, laa, lda, ldas, lj, lx, ly, n,
2089  $ nargs, nc, ns
2090  LOGICAL full, null, packed, reset, same, upper
2091  CHARACTER*1 uplo, uplos
2092  CHARACTER*2 ich
2093 * .. Local Arrays ..
2094  COMPLEX w( 2 )
2095  LOGICAL isame( 13 )
2096 * .. External Functions ..
2097  LOGICAL lce, lceres
2098  EXTERNAL lce, lceres
2099 * .. External Subroutines ..
2100  EXTERNAL cher2, chpr2, cmake, cmvch
2101 * .. Intrinsic Functions ..
2102  INTRINSIC abs, conjg, max
2103 * .. Scalars in Common ..
2104  INTEGER infot, noutc
2105  LOGICAL lerr, ok
2106 * .. Common blocks ..
2107  COMMON /infoc/infot, noutc, ok, lerr
2108 * .. Data statements ..
2109  DATA ich/'UL'/
2110 * .. Executable Statements ..
2111  full = sname( 3: 3 ).EQ.'E'
2112  packed = sname( 3: 3 ).EQ.'P'
2113 * Define the number of arguments.
2114  IF( full )THEN
2115  nargs = 9
2116  ELSE IF( packed )THEN
2117  nargs = 8
2118  END IF
2119 *
2120  nc = 0
2121  reset = .true.
2122  errmax = rzero
2123 *
2124  DO 140 in = 1, nidim
2125  n = idim( in )
2126 * Set LDA to 1 more than minimum value if room.
2127  lda = n
2128  IF( lda.LT.nmax )
2129  $ lda = lda + 1
2130 * Skip tests if not enough room.
2131  IF( lda.GT.nmax )
2132  $ GO TO 140
2133  IF( packed )THEN
2134  laa = ( n*( n + 1 ) )/2
2135  ELSE
2136  laa = lda*n
2137  END IF
2138 *
2139  DO 130 ic = 1, 2
2140  uplo = ich( ic: ic )
2141  upper = uplo.EQ.'U'
2142 *
2143  DO 120 ix = 1, ninc
2144  incx = inc( ix )
2145  lx = abs( incx )*n
2146 *
2147 * Generate the vector X.
2148 *
2149  transl = half
2150  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2151  $ 0, n - 1, reset, transl )
2152  IF( n.GT.1 )THEN
2153  x( n/2 ) = zero
2154  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2155  END IF
2156 *
2157  DO 110 iy = 1, ninc
2158  incy = inc( iy )
2159  ly = abs( incy )*n
2160 *
2161 * Generate the vector Y.
2162 *
2163  transl = zero
2164  CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
2165  $ abs( incy ), 0, n - 1, reset, transl )
2166  IF( n.GT.1 )THEN
2167  y( n/2 ) = zero
2168  yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2169  END IF
2170 *
2171  DO 100 ia = 1, nalf
2172  alpha = alf( ia )
2173  null = n.LE.0.OR.alpha.EQ.zero
2174 *
2175 * Generate the matrix A.
2176 *
2177  transl = zero
2178  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a,
2179  $ nmax, aa, lda, n - 1, n - 1, reset,
2180  $ transl )
2181 *
2182  nc = nc + 1
2183 *
2184 * Save every datum before calling the subroutine.
2185 *
2186  uplos = uplo
2187  ns = n
2188  als = alpha
2189  DO 10 i = 1, laa
2190  as( i ) = aa( i )
2191  10 CONTINUE
2192  ldas = lda
2193  DO 20 i = 1, lx
2194  xs( i ) = xx( i )
2195  20 CONTINUE
2196  incxs = incx
2197  DO 30 i = 1, ly
2198  ys( i ) = yy( i )
2199  30 CONTINUE
2200  incys = incy
2201 *
2202 * Call the subroutine.
2203 *
2204  IF( full )THEN
2205  IF( trace )
2206  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2207  $ alpha, incx, incy, lda
2208  IF( rewi )
2209  $ rewind ntra
2210  CALL cher2( uplo, n, alpha, xx, incx, yy, incy,
2211  $ aa, lda )
2212  ELSE IF( packed )THEN
2213  IF( trace )
2214  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2215  $ alpha, incx, incy
2216  IF( rewi )
2217  $ rewind ntra
2218  CALL chpr2( uplo, n, alpha, xx, incx, yy, incy,
2219  $ aa )
2220  END IF
2221 *
2222 * Check if error-exit was taken incorrectly.
2223 *
2224  IF( .NOT.ok )THEN
2225  WRITE( nout, fmt = 9992 )
2226  fatal = .true.
2227  GO TO 160
2228  END IF
2229 *
2230 * See what data changed inside subroutines.
2231 *
2232  isame( 1 ) = uplo.EQ.uplos
2233  isame( 2 ) = ns.EQ.n
2234  isame( 3 ) = als.EQ.alpha
2235  isame( 4 ) = lce( xs, xx, lx )
2236  isame( 5 ) = incxs.EQ.incx
2237  isame( 6 ) = lce( ys, yy, ly )
2238  isame( 7 ) = incys.EQ.incy
2239  IF( null )THEN
2240  isame( 8 ) = lce( as, aa, laa )
2241  ELSE
2242  isame( 8 ) = lceres( sname( 2: 3 ), uplo, n, n,
2243  $ as, aa, lda )
2244  END IF
2245  IF( .NOT.packed )THEN
2246  isame( 9 ) = ldas.EQ.lda
2247  END IF
2248 *
2249 * If data was incorrectly changed, report and return.
2250 *
2251  same = .true.
2252  DO 40 i = 1, nargs
2253  same = same.AND.isame( i )
2254  IF( .NOT.isame( i ) )
2255  $ WRITE( nout, fmt = 9998 )i
2256  40 CONTINUE
2257  IF( .NOT.same )THEN
2258  fatal = .true.
2259  GO TO 160
2260  END IF
2261 *
2262  IF( .NOT.null )THEN
2263 *
2264 * Check the result column by column.
2265 *
2266  IF( incx.GT.0 )THEN
2267  DO 50 i = 1, n
2268  z( i, 1 ) = x( i )
2269  50 CONTINUE
2270  ELSE
2271  DO 60 i = 1, n
2272  z( i, 1 ) = x( n - i + 1 )
2273  60 CONTINUE
2274  END IF
2275  IF( incy.GT.0 )THEN
2276  DO 70 i = 1, n
2277  z( i, 2 ) = y( i )
2278  70 CONTINUE
2279  ELSE
2280  DO 80 i = 1, n
2281  z( i, 2 ) = y( n - i + 1 )
2282  80 CONTINUE
2283  END IF
2284  ja = 1
2285  DO 90 j = 1, n
2286  w( 1 ) = alpha*conjg( z( j, 2 ) )
2287  w( 2 ) = conjg( alpha )*conjg( z( j, 1 ) )
2288  IF( upper )THEN
2289  jj = 1
2290  lj = j
2291  ELSE
2292  jj = j
2293  lj = n - j + 1
2294  END IF
2295  CALL cmvch( 'N', lj, 2, one, z( jj, 1 ),
2296  $ nmax, w, 1, one, a( jj, j ), 1,
2297  $ yt, g, aa( ja ), eps, err, fatal,
2298  $ nout, .true. )
2299  IF( full )THEN
2300  IF( upper )THEN
2301  ja = ja + lda
2302  ELSE
2303  ja = ja + lda + 1
2304  END IF
2305  ELSE
2306  ja = ja + lj
2307  END IF
2308  errmax = max( errmax, err )
2309 * If got really bad answer, report and return.
2310  IF( fatal )
2311  $ GO TO 150
2312  90 CONTINUE
2313  ELSE
2314 * Avoid repeating tests with N.le.0.
2315  IF( n.LE.0 )
2316  $ GO TO 140
2317  END IF
2318 *
2319  100 CONTINUE
2320 *
2321  110 CONTINUE
2322 *
2323  120 CONTINUE
2324 *
2325  130 CONTINUE
2326 *
2327  140 CONTINUE
2328 *
2329 * Report result.
2330 *
2331  IF( errmax.LT.thresh )THEN
2332  WRITE( nout, fmt = 9999 )sname, nc
2333  ELSE
2334  WRITE( nout, fmt = 9997 )sname, nc, errmax
2335  END IF
2336  GO TO 170
2337 *
2338  150 CONTINUE
2339  WRITE( nout, fmt = 9995 )j
2340 *
2341  160 CONTINUE
2342  WRITE( nout, fmt = 9996 )sname
2343  IF( full )THEN
2344  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2345  $ incy, lda
2346  ELSE IF( packed )THEN
2347  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2348  END IF
2349 *
2350  170 CONTINUE
2351  RETURN
2352 *
2353  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2354  $ 'S)' )
2355  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2356  $ 'ANGED INCORRECTLY *******' )
2357  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2358  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2359  $ ' - SUSPECT *******' )
2360  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2361  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2362  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
2363  $ f4.1, '), X,', i2, ', Y,', i2, ', AP) ',
2364  $ ' .' )
2365  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
2366  $ f4.1, '), X,', i2, ', Y,', i2, ', A,', i3, ') ',
2367  $ ' .' )
2368  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2369  $ '******' )
2370 *
2371 * End of CCHK6.
2372 *
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
chpr2
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
CHPR2
Definition: chpr2.f:147
cmake
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: cblat2.f:2719
cher2
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CHER2
Definition: cher2.f:152
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3072

Here is the call graph for this function:

Here is the caller graph for this function: