LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ 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 2055 of file zblat2.f.

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