LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zchk5 ( 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,
complex*16, dimension( nalf )  ALF,
integer  NBET,
complex*16, dimension( nbet )  BET,
integer  NMAX,
complex*16, dimension( 2*nmax*nmax )  AB,
complex*16, dimension( nmax*nmax )  AA,
complex*16, dimension( nmax*nmax )  AS,
complex*16, dimension( nmax*nmax )  BB,
complex*16, dimension( nmax*nmax )  BS,
complex*16, dimension( nmax, nmax )  C,
complex*16, dimension( nmax*nmax )  CC,
complex*16, dimension( nmax*nmax )  CS,
complex*16, dimension( nmax )  CT,
double precision, dimension( nmax )  G,
complex*16, dimension( 2*nmax )  W,
integer  IORDER 
)

Definition at line 1856 of file c_zblat3.f.

1856 *
1857 * Tests ZHER2K and ZSYR2K.
1858 *
1859 * Auxiliary routine for test program for Level 3 Blas.
1860 *
1861 * -- Written on 8-February-1989.
1862 * Jack Dongarra, Argonne National Laboratory.
1863 * Iain Duff, AERE Harwell.
1864 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1865 * Sven Hammarling, Numerical Algorithms Group Ltd.
1866 *
1867 * .. Parameters ..
1868  COMPLEX*16 zero, one
1869  parameter ( zero = ( 0.0d0, 0.0d0 ), one = ( 1.0d0, 0.0d0 ) )
1870  DOUBLE PRECISION rone, rzero
1871  parameter ( rone = 1.0d0, rzero = 0.0d0 )
1872 * .. Scalar Arguments ..
1873  DOUBLE PRECISION eps, thresh
1874  INTEGER nalf, nbet, nidim, nmax, nout, ntra, iorder
1875  LOGICAL fatal, rewi, trace
1876  CHARACTER*12 sname
1877 * .. Array Arguments ..
1878  COMPLEX*16 aa( nmax*nmax ), ab( 2*nmax*nmax ),
1879  $ alf( nalf ), as( nmax*nmax ), bb( nmax*nmax ),
1880  $ bet( nbet ), bs( nmax*nmax ), c( nmax, nmax ),
1881  $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
1882  $ w( 2*nmax )
1883  DOUBLE PRECISION g( nmax )
1884  INTEGER idim( nidim )
1885 * .. Local Scalars ..
1886  COMPLEX*16 alpha, als, beta, bets
1887  DOUBLE PRECISION err, errmax, rbeta, rbets
1888  INTEGER i, ia, ib, ict, icu, ik, in, j, jc, jj, jjab,
1889  $ k, ks, laa, lbb, lcc, lda, ldas, ldb, ldbs,
1890  $ ldc, ldcs, lj, ma, n, na, nargs, nc, ns
1891  LOGICAL conj, null, reset, same, tran, upper
1892  CHARACTER*1 trans, transs, transt, uplo, uplos
1893  CHARACTER*2 icht, ichu
1894 * .. Local Arrays ..
1895  LOGICAL isame( 13 )
1896 * .. External Functions ..
1897  LOGICAL lze, lzeres
1898  EXTERNAL lze, lzeres
1899 * .. External Subroutines ..
1900  EXTERNAL czher2k, zmake, zmmch, czsyr2k
1901 * .. Intrinsic Functions ..
1902  INTRINSIC dcmplx, dconjg, max, dble
1903 * .. Scalars in Common ..
1904  INTEGER infot, noutc
1905  LOGICAL lerr, ok
1906 * .. Common blocks ..
1907  COMMON /infoc/infot, noutc, ok, lerr
1908 * .. Data statements ..
1909  DATA icht/'NC'/, ichu/'UL'/
1910 * .. Executable Statements ..
1911  conj = sname( 8: 9 ).EQ.'he'
1912 *
1913  nargs = 12
1914  nc = 0
1915  reset = .true.
1916  errmax = rzero
1917 *
1918  DO 130 in = 1, nidim
1919  n = idim( in )
1920 * Set LDC to 1 more than minimum value if room.
1921  ldc = n
1922  IF( ldc.LT.nmax )
1923  $ ldc = ldc + 1
1924 * Skip tests if not enough room.
1925  IF( ldc.GT.nmax )
1926  $ GO TO 130
1927  lcc = ldc*n
1928 *
1929  DO 120 ik = 1, nidim
1930  k = idim( ik )
1931 *
1932  DO 110 ict = 1, 2
1933  trans = icht( ict: ict )
1934  tran = trans.EQ.'C'
1935  IF( tran.AND..NOT.conj )
1936  $ trans = 'T'
1937  IF( tran )THEN
1938  ma = k
1939  na = n
1940  ELSE
1941  ma = n
1942  na = k
1943  END IF
1944 * Set LDA to 1 more than minimum value if room.
1945  lda = ma
1946  IF( lda.LT.nmax )
1947  $ lda = lda + 1
1948 * Skip tests if not enough room.
1949  IF( lda.GT.nmax )
1950  $ GO TO 110
1951  laa = lda*na
1952 *
1953 * Generate the matrix A.
1954 *
1955  IF( tran )THEN
1956  CALL zmake( 'ge', ' ', ' ', ma, na, ab, 2*nmax, aa,
1957  $ lda, reset, zero )
1958  ELSE
1959  CALL zmake( 'ge', ' ', ' ', ma, na, ab, nmax, aa, lda,
1960  $ reset, zero )
1961  END IF
1962 *
1963 * Generate the matrix B.
1964 *
1965  ldb = lda
1966  lbb = laa
1967  IF( tran )THEN
1968  CALL zmake( 'ge', ' ', ' ', ma, na, ab( k + 1 ),
1969  $ 2*nmax, bb, ldb, reset, zero )
1970  ELSE
1971  CALL zmake( 'ge', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1972  $ nmax, bb, ldb, reset, zero )
1973  END IF
1974 *
1975  DO 100 icu = 1, 2
1976  uplo = ichu( icu: icu )
1977  upper = uplo.EQ.'U'
1978 *
1979  DO 90 ia = 1, nalf
1980  alpha = alf( ia )
1981 *
1982  DO 80 ib = 1, nbet
1983  beta = bet( ib )
1984  IF( conj )THEN
1985  rbeta = dble( beta )
1986  beta = dcmplx( rbeta, rzero )
1987  END IF
1988  null = n.LE.0
1989  IF( conj )
1990  $ null = null.OR.( ( k.LE.0.OR.alpha.EQ.
1991  $ zero ).AND.rbeta.EQ.rone )
1992 *
1993 * Generate the matrix C.
1994 *
1995  CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, c,
1996  $ nmax, cc, ldc, reset, zero )
1997 *
1998  nc = nc + 1
1999 *
2000 * Save every datum before calling the subroutine.
2001 *
2002  uplos = uplo
2003  transs = trans
2004  ns = n
2005  ks = k
2006  als = alpha
2007  DO 10 i = 1, laa
2008  as( i ) = aa( i )
2009  10 CONTINUE
2010  ldas = lda
2011  DO 20 i = 1, lbb
2012  bs( i ) = bb( i )
2013  20 CONTINUE
2014  ldbs = ldb
2015  IF( conj )THEN
2016  rbets = rbeta
2017  ELSE
2018  bets = beta
2019  END IF
2020  DO 30 i = 1, lcc
2021  cs( i ) = cc( i )
2022  30 CONTINUE
2023  ldcs = ldc
2024 *
2025 * Call the subroutine.
2026 *
2027  IF( conj )THEN
2028  IF( trace )
2029  $ CALL zprcn7( ntra, nc, sname, iorder,
2030  $ uplo, trans, n, k, alpha, lda, ldb,
2031  $ rbeta, ldc)
2032  IF( rewi )
2033  $ rewind ntra
2034  CALL czher2k( iorder, uplo, trans, n, k,
2035  $ alpha, aa, lda, bb, ldb, rbeta,
2036  $ cc, ldc )
2037  ELSE
2038  IF( trace )
2039  $ CALL zprcn5( ntra, nc, sname, iorder,
2040  $ uplo, trans, n, k, alpha, lda, ldb,
2041  $ beta, ldc)
2042  IF( rewi )
2043  $ rewind ntra
2044  CALL czsyr2k( iorder, uplo, trans, n, k,
2045  $ alpha, aa, lda, bb, ldb, beta,
2046  $ cc, ldc )
2047  END IF
2048 *
2049 * Check if error-exit was taken incorrectly.
2050 *
2051  IF( .NOT.ok )THEN
2052  WRITE( nout, fmt = 9992 )
2053  fatal = .true.
2054  GO TO 150
2055  END IF
2056 *
2057 * See what data changed inside subroutines.
2058 *
2059  isame( 1 ) = uplos.EQ.uplo
2060  isame( 2 ) = transs.EQ.trans
2061  isame( 3 ) = ns.EQ.n
2062  isame( 4 ) = ks.EQ.k
2063  isame( 5 ) = als.EQ.alpha
2064  isame( 6 ) = lze( as, aa, laa )
2065  isame( 7 ) = ldas.EQ.lda
2066  isame( 8 ) = lze( bs, bb, lbb )
2067  isame( 9 ) = ldbs.EQ.ldb
2068  IF( conj )THEN
2069  isame( 10 ) = rbets.EQ.rbeta
2070  ELSE
2071  isame( 10 ) = bets.EQ.beta
2072  END IF
2073  IF( null )THEN
2074  isame( 11 ) = lze( cs, cc, lcc )
2075  ELSE
2076  isame( 11 ) = lzeres( 'he', uplo, n, n, cs,
2077  $ cc, ldc )
2078  END IF
2079  isame( 12 ) = ldcs.EQ.ldc
2080 *
2081 * If data was incorrectly changed, report and
2082 * return.
2083 *
2084  same = .true.
2085  DO 40 i = 1, nargs
2086  same = same.AND.isame( i )
2087  IF( .NOT.isame( i ) )
2088  $ WRITE( nout, fmt = 9998 )i
2089  40 CONTINUE
2090  IF( .NOT.same )THEN
2091  fatal = .true.
2092  GO TO 150
2093  END IF
2094 *
2095  IF( .NOT.null )THEN
2096 *
2097 * Check the result column by column.
2098 *
2099  IF( conj )THEN
2100  transt = 'C'
2101  ELSE
2102  transt = 'T'
2103  END IF
2104  jjab = 1
2105  jc = 1
2106  DO 70 j = 1, n
2107  IF( upper )THEN
2108  jj = 1
2109  lj = j
2110  ELSE
2111  jj = j
2112  lj = n - j + 1
2113  END IF
2114  IF( tran )THEN
2115  DO 50 i = 1, k
2116  w( i ) = alpha*ab( ( j - 1 )*2*
2117  $ nmax + k + i )
2118  IF( conj )THEN
2119  w( k + i ) = dconjg( alpha )*
2120  $ ab( ( j - 1 )*2*
2121  $ nmax + i )
2122  ELSE
2123  w( k + i ) = alpha*
2124  $ ab( ( j - 1 )*2*
2125  $ nmax + i )
2126  END IF
2127  50 CONTINUE
2128  CALL zmmch( transt, 'N', lj, 1, 2*k,
2129  $ one, ab( jjab ), 2*nmax, w,
2130  $ 2*nmax, beta, c( jj, j ),
2131  $ nmax, ct, g, cc( jc ), ldc,
2132  $ eps, err, fatal, nout,
2133  $ .true. )
2134  ELSE
2135  DO 60 i = 1, k
2136  IF( conj )THEN
2137  w( i ) = alpha*dconjg( ab( ( k +
2138  $ i - 1 )*nmax + j ) )
2139  w( k + i ) = dconjg( alpha*
2140  $ ab( ( i - 1 )*nmax +
2141  $ j ) )
2142  ELSE
2143  w( i ) = alpha*ab( ( k + i - 1 )*
2144  $ nmax + j )
2145  w( k + i ) = alpha*
2146  $ ab( ( i - 1 )*nmax +
2147  $ j )
2148  END IF
2149  60 CONTINUE
2150  CALL zmmch( 'N', 'N', lj, 1, 2*k, one,
2151  $ ab( jj ), nmax, w, 2*nmax,
2152  $ beta, c( jj, j ), nmax, ct,
2153  $ g, cc( jc ), ldc, eps, err,
2154  $ fatal, nout, .true. )
2155  END IF
2156  IF( upper )THEN
2157  jc = jc + ldc
2158  ELSE
2159  jc = jc + ldc + 1
2160  IF( tran )
2161  $ jjab = jjab + 2*nmax
2162  END IF
2163  errmax = max( errmax, err )
2164 * If got really bad answer, report and
2165 * return.
2166  IF( fatal )
2167  $ GO TO 140
2168  70 CONTINUE
2169  END IF
2170 *
2171  80 CONTINUE
2172 *
2173  90 CONTINUE
2174 *
2175  100 CONTINUE
2176 *
2177  110 CONTINUE
2178 *
2179  120 CONTINUE
2180 *
2181  130 CONTINUE
2182 *
2183 * Report result.
2184 *
2185  IF( errmax.LT.thresh )THEN
2186  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2187  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2188  ELSE
2189  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2190  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2191  END IF
2192  GO TO 160
2193 *
2194  140 CONTINUE
2195  IF( n.GT.1 )
2196  $ WRITE( nout, fmt = 9995 )j
2197 *
2198  150 CONTINUE
2199  WRITE( nout, fmt = 9996 )sname
2200  IF( conj )THEN
2201  CALL zprcn7( nout, nc, sname, iorder, uplo, trans, n, k,
2202  $ alpha, lda, ldb, rbeta, ldc)
2203  ELSE
2204  CALL zprcn5( nout, nc, sname, iorder, uplo, trans, n, k,
2205  $ alpha, lda, ldb, beta, ldc)
2206  END IF
2207 *
2208  160 CONTINUE
2209  RETURN
2210 *
2211 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2212  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2213  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2214 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2215  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2216  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2217 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2218  $ ' (', i6, ' CALL', 'S)' )
2219 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2220  $ ' (', i6, ' CALL', 'S)' )
2221  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2222  $ 'ANGED INCORRECTLY *******' )
2223  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
2224  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2225  9994 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2226  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',', f4.1,
2227  $ ', C,', i3, ') .' )
2228  9993 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2229  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
2230  $ ',', f4.1, '), C,', i3, ') .' )
2231  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2232  $ '******' )
2233 *
2234 * End of ZCHK5.
2235 *
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zmmch
subroutine zmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: zblat3.f:3064
zprcn5
subroutine zprcn5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:2240
zprcn7
subroutine zprcn7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:2274
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050

Here is the call graph for this function: