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

◆ dchk6()

subroutine dchk6 ( 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,
double precision, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
double precision, dimension( nmax, nmax )  a,
double precision, dimension( nmax*nmax )  aa,
double precision, dimension( nmax*nmax )  as,
double precision, dimension( nmax )  x,
double precision, dimension( nmax*incmax )  xx,
double precision, dimension( nmax*incmax )  xs,
double precision, dimension( nmax )  y,
double precision, dimension( nmax*incmax )  yy,
double precision, dimension( nmax*incmax )  ys,
double precision, dimension( nmax )  yt,
double precision, dimension( nmax )  g,
double precision, dimension( nmax, 2 )  z 
)

Definition at line 2035 of file dblat2.f.

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