LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

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

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