LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dchk5 ( 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,
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 )  Z,
integer  IORDER 
)

Definition at line 1839 of file c_dblat2.f.

1839 *
1840 * Tests DSYR and DSPR.
1841 *
1842 * Auxiliary routine for test program for Level 2 Blas.
1843 *
1844 * -- Written on 10-August-1987.
1845 * Richard Hanson, Sandia National Labs.
1846 * Jeremy Du Croz, NAG Central Office.
1847 *
1848 * .. Parameters ..
1849  DOUBLE PRECISION zero, half, one
1850  parameter ( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
1851 * .. Scalar Arguments ..
1852  DOUBLE PRECISION eps, thresh
1853  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra,
1854  $ iorder
1855  LOGICAL fatal, rewi, trace
1856  CHARACTER*12 sname
1857 * .. Array Arguments ..
1858  DOUBLE PRECISION a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1859  $ as( nmax*nmax ), g( nmax ), x( nmax ),
1860  $ xs( nmax*incmax ), xx( nmax*incmax ),
1861  $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
1862  $ yy( nmax*incmax ), z( nmax )
1863  INTEGER idim( nidim ), inc( ninc )
1864 * .. Local Scalars ..
1865  DOUBLE PRECISION alpha, als, err, errmax, transl
1866  INTEGER i, ia, ic, in, incx, incxs, ix, j, ja, jj, laa,
1867  $ lda, ldas, lj, lx, n, nargs, nc, ns
1868  LOGICAL full, null, packed, reset, same, upper
1869  CHARACTER*1 uplo, uplos
1870  CHARACTER*14 cuplo
1871  CHARACTER*2 ich
1872 * .. Local Arrays ..
1873  DOUBLE PRECISION w( 1 )
1874  LOGICAL isame( 13 )
1875 * .. External Functions ..
1876  LOGICAL lde, lderes
1877  EXTERNAL lde, lderes
1878 * .. External Subroutines ..
1879  EXTERNAL dmake, dmvch, cdspr, cdsyr
1880 * .. Intrinsic Functions ..
1881  INTRINSIC abs, max
1882 * .. Scalars in Common ..
1883  INTEGER infot, noutc
1884  LOGICAL ok
1885 * .. Common blocks ..
1886  COMMON /infoc/infot, noutc, ok
1887 * .. Data statements ..
1888  DATA ich/'UL'/
1889 * .. Executable Statements ..
1890  full = sname( 9: 9 ).EQ.'y'
1891  packed = sname( 9: 9 ).EQ.'p'
1892 * Define the number of arguments.
1893  IF( full )THEN
1894  nargs = 7
1895  ELSE IF( packed )THEN
1896  nargs = 6
1897  END IF
1898 *
1899  nc = 0
1900  reset = .true.
1901  errmax = zero
1902 *
1903  DO 100 in = 1, nidim
1904  n = idim( in )
1905 * Set LDA to 1 more than minimum value if room.
1906  lda = n
1907  IF( lda.LT.nmax )
1908  $ lda = lda + 1
1909 * Skip tests if not enough room.
1910  IF( lda.GT.nmax )
1911  $ GO TO 100
1912  IF( packed )THEN
1913  laa = ( n*( n + 1 ) )/2
1914  ELSE
1915  laa = lda*n
1916  END IF
1917 *
1918  DO 90 ic = 1, 2
1919  uplo = ich( ic: ic )
1920  IF (uplo.EQ.'U')THEN
1921  cuplo = ' CblasUpper'
1922  ELSE
1923  cuplo = ' CblasLower'
1924  END IF
1925  upper = uplo.EQ.'U'
1926 *
1927  DO 80 ix = 1, ninc
1928  incx = inc( ix )
1929  lx = abs( incx )*n
1930 *
1931 * Generate the vector X.
1932 *
1933  transl = half
1934  CALL dmake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1935  $ 0, n - 1, reset, transl )
1936  IF( n.GT.1 )THEN
1937  x( n/2 ) = zero
1938  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1939  END IF
1940 *
1941  DO 70 ia = 1, nalf
1942  alpha = alf( ia )
1943  null = n.LE.0.OR.alpha.EQ.zero
1944 *
1945 * Generate the matrix A.
1946 *
1947  transl = zero
1948  CALL dmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax,
1949  $ aa, lda, n - 1, n - 1, reset, transl )
1950 *
1951  nc = nc + 1
1952 *
1953 * Save every datum before calling the subroutine.
1954 *
1955  uplos = uplo
1956  ns = n
1957  als = alpha
1958  DO 10 i = 1, laa
1959  as( i ) = aa( i )
1960  10 CONTINUE
1961  ldas = lda
1962  DO 20 i = 1, lx
1963  xs( i ) = xx( i )
1964  20 CONTINUE
1965  incxs = incx
1966 *
1967 * Call the subroutine.
1968 *
1969  IF( full )THEN
1970  IF( trace )
1971  $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
1972  $ alpha, incx, lda
1973  IF( rewi )
1974  $ rewind ntra
1975  CALL cdsyr( iorder, uplo, n, alpha, xx, incx,
1976  $ aa, lda )
1977  ELSE IF( packed )THEN
1978  IF( trace )
1979  $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
1980  $ alpha, incx
1981  IF( rewi )
1982  $ rewind ntra
1983  CALL cdspr( iorder, uplo, n, alpha, xx, incx, aa )
1984  END IF
1985 *
1986 * Check if error-exit was taken incorrectly.
1987 *
1988  IF( .NOT.ok )THEN
1989  WRITE( nout, fmt = 9992 )
1990  fatal = .true.
1991  GO TO 120
1992  END IF
1993 *
1994 * See what data changed inside subroutines.
1995 *
1996  isame( 1 ) = uplo.EQ.uplos
1997  isame( 2 ) = ns.EQ.n
1998  isame( 3 ) = als.EQ.alpha
1999  isame( 4 ) = lde( xs, xx, lx )
2000  isame( 5 ) = incxs.EQ.incx
2001  IF( null )THEN
2002  isame( 6 ) = lde( as, aa, laa )
2003  ELSE
2004  isame( 6 ) = lderes( sname( 8: 9 ), uplo, n, n, as,
2005  $ aa, lda )
2006  END IF
2007  IF( .NOT.packed )THEN
2008  isame( 7 ) = ldas.EQ.lda
2009  END IF
2010 *
2011 * If data was incorrectly changed, report and return.
2012 *
2013  same = .true.
2014  DO 30 i = 1, nargs
2015  same = same.AND.isame( i )
2016  IF( .NOT.isame( i ) )
2017  $ WRITE( nout, fmt = 9998 )i
2018  30 CONTINUE
2019  IF( .NOT.same )THEN
2020  fatal = .true.
2021  GO TO 120
2022  END IF
2023 *
2024  IF( .NOT.null )THEN
2025 *
2026 * Check the result column by column.
2027 *
2028  IF( incx.GT.0 )THEN
2029  DO 40 i = 1, n
2030  z( i ) = x( i )
2031  40 CONTINUE
2032  ELSE
2033  DO 50 i = 1, n
2034  z( i ) = x( n - i + 1 )
2035  50 CONTINUE
2036  END IF
2037  ja = 1
2038  DO 60 j = 1, n
2039  w( 1 ) = z( j )
2040  IF( upper )THEN
2041  jj = 1
2042  lj = j
2043  ELSE
2044  jj = j
2045  lj = n - j + 1
2046  END IF
2047  CALL dmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
2048  $ 1, one, a( jj, j ), 1, yt, g,
2049  $ aa( ja ), eps, err, fatal, nout,
2050  $ .true. )
2051  IF( full )THEN
2052  IF( upper )THEN
2053  ja = ja + lda
2054  ELSE
2055  ja = ja + lda + 1
2056  END IF
2057  ELSE
2058  ja = ja + lj
2059  END IF
2060  errmax = max( errmax, err )
2061 * If got really bad answer, report and return.
2062  IF( fatal )
2063  $ GO TO 110
2064  60 CONTINUE
2065  ELSE
2066 * Avoid repeating tests if N.le.0.
2067  IF( n.LE.0 )
2068  $ GO TO 100
2069  END IF
2070 *
2071  70 CONTINUE
2072 *
2073  80 CONTINUE
2074 *
2075  90 CONTINUE
2076 *
2077  100 CONTINUE
2078 *
2079 * Report result.
2080 *
2081  IF( errmax.LT.thresh )THEN
2082  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2083  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2084  ELSE
2085  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2086  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2087  END IF
2088  GO TO 130
2089 *
2090  110 CONTINUE
2091  WRITE( nout, fmt = 9995 )j
2092 *
2093  120 CONTINUE
2094  WRITE( nout, fmt = 9996 )sname
2095  IF( full )THEN
2096  WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, incx, lda
2097  ELSE IF( packed )THEN
2098  WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, alpha, incx
2099  END IF
2100 *
2101  130 CONTINUE
2102  RETURN
2103 *
2104 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2105  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2106  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2107 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2108  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2109  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2110 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2111  $ ' (', i6, ' CALL', 'S)' )
2112 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2113  $ ' (', i6, ' CALL', 'S)' )
2114  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2115  $ 'ANGED INCORRECTLY *******' )
2116  9997 FORMAT( ' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2117  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2118  $ ' - SUSPECT *******' )
2119  9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2120  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2121  9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2122  $ i2, ', AP) .' )
2123  9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2124  $ i2, ', A,', i3, ') .' )
2125  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2126  $ '******' )
2127 *
2128 * End of DCHK5.
2129 *
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
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:2829
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975

Here is the call graph for this function: