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

◆ zchk6()

subroutine zchk6 ( character*6  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 
)

Definition at line 2083 of file zblat2.f.

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