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

◆ zchk6()

subroutine zchk6 ( character*12  sname,
double precision  eps,
double precision  thresh,
integer  nout,
integer  ntra,
logical  trace,
logical  rewi,
logical  fatal,
integer  nidim,
integer, dimension( nidim )  idim,
integer  nalf,
complex*16, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
complex*16, dimension( nmax, nmax )  a,
complex*16, dimension( nmax*nmax )  aa,
complex*16, dimension( nmax*nmax )  as,
complex*16, dimension( nmax )  x,
complex*16, dimension( nmax*incmax )  xx,
complex*16, dimension( nmax*incmax )  xs,
complex*16, dimension( nmax )  y,
complex*16, dimension( nmax*incmax )  yy,
complex*16, dimension( nmax*incmax )  ys,
complex*16, dimension( nmax )  yt,
double precision, dimension( nmax )  g,
complex*16, dimension( nmax, 2 )  z,
integer  iorder 
)

Definition at line 2129 of file c_zblat2.f.

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