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

◆ 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 1851 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*
221010003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2211 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2212 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221310002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2214 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2215 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221610001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2217 $ ' (', i6, ' CALL', 'S)' )
221810000 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*
cprcn7
subroutine cprcn7(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_cblat3.f:2273
cprcn5
subroutine cprcn5(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_cblat3.f:2239
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:3053
Here is the call graph for this function: