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

◆ cchk6()

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 2124 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*
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
Here is the call graph for this function: