LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk5()

subroutine cchk5 ( character*12  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NMAX,
complex, dimension( 2*nmax*nmax )  AB,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax, nmax )  C,
complex, dimension( nmax*nmax )  CC,
complex, dimension( nmax*nmax )  CS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G,
complex, dimension( 2*nmax )  W,
integer  IORDER 
)

Definition at line 1855 of file c_cblat3.f.

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