LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ cchk6()

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 2049 of file cblat2.f.

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