LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 2133 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 *
Here is the call graph for this function:
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
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:2919
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050