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

◆ zchk5()

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 1852 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*
221110003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2212 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2213 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221410002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2215 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2216 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221710001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2218 $ ' (', i6, ' CALL', 'S)' )
221910000 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*
zprcn7
subroutine zprcn7(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_zblat3.f:2274
zprcn5
subroutine zprcn5(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_zblat3.f:2240
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
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:3061
Here is the call graph for this function: