2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049 DOUBLE PRECISION ZERO, HALF, ONE
2050 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
2051
2052 DOUBLE PRECISION EPS, THRESH
2053 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2054 LOGICAL FATAL, REWI, TRACE
2055 CHARACTER*6 SNAME
2056
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
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
2072 DOUBLE PRECISION W( 2 )
2073 LOGICAL ISAME( 13 )
2074
2075 LOGICAL LDE, LDERES
2077
2079
2080 INTRINSIC abs, max
2081
2082 INTEGER INFOT, NOUTC
2083 LOGICAL LERR, OK
2084
2085 COMMON /infoc/infot, noutc, ok, lerr
2086
2087 DATA ich/'UL'/
2088
2089 full = sname( 3: 3 ).EQ.'Y'
2090 packed = sname( 3: 3 ).EQ.'P'
2091
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
2105 lda = n
2106 IF( lda.LT.nmax )
2107 $ lda = lda + 1
2108
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
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
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
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
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
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
2201
2202 IF( .NOT.ok )THEN
2203 WRITE( nout, fmt = 9992 )
2204 fatal = .true.
2205 GO TO 160
2206 END IF
2207
2208
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
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
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
2288 IF( fatal )
2289 $ GO TO 150
2290 90 CONTINUE
2291 ELSE
2292
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
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
2348
subroutine dmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
logical function lde(ri, rj, lr)
logical function lderes(type, uplo, m, n, aa, as, lda)
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
DSYR2
subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
DSPR2