LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 2062 of file zblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: