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

◆ cchk5()

subroutine cchk5 ( character*13 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 1867 of file c_cblat3.f.

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