1538 DOUBLE PRECISION ZERO
1539 parameter( zero = 0.0d0 )
1541 DOUBLE PRECISION EPS, THRESH
1542 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1543 LOGICAL FATAL, REWI, TRACE
1546 DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1547 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1548 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1549 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1550 $ G( NMAX ), W( 2*NMAX )
1551 INTEGER IDIM( NIDIM )
1553 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1554 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1555 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1556 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1557 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1558 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1571 INTEGER INFOT, NOUTC
1574 COMMON /infoc/infot, noutc, ok, lerr
1576 DATA icht/
'NTC'/, ichu/
'UL'/
1584 DO 130 in = 1, nidim
1596 DO 120 ik = 1, nidim
1600 trans = icht( ict: ict )
1601 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
1621 CALL dmake(
'GE',
' ',
' ', ma, na, ab, 2*nmax, aa,
1622 $ lda, reset, zero )
1624 CALL dmake(
'GE',
' ',
' ', ma, na, ab, nmax, aa, lda,
1633 CALL dmake(
'GE',
' ',
' ', ma, na, ab( k + 1 ),
1634 $ 2*nmax, bb, ldb, reset, zero )
1636 CALL dmake(
'GE',
' ',
' ', ma, na, ab( k*nmax + 1 ),
1637 $ nmax, bb, ldb, reset, zero )
1641 uplo = ichu( icu: icu )
1652 CALL dmake(
'SY', uplo,
' ', n, n, c, nmax, cc,
1653 $ ldc, reset, zero )
1681 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1682 $ trans, n, k, alpha, lda, ldb, beta, ldc
1685 CALL dsyr2k( uplo, trans, n, k, alpha, aa, lda,
1686 $ bb, ldb, beta, cc, ldc )
1691 WRITE( nout, fmt = 9993 )
1698 isame( 1 ) = uplos.EQ.uplo
1699 isame( 2 ) = transs.EQ.trans
1700 isame( 3 ) = ns.EQ.n
1701 isame( 4 ) = ks.EQ.k
1702 isame( 5 ) = als.EQ.alpha
1703 isame( 6 ) =
lde( as, aa, laa )
1704 isame( 7 ) = ldas.EQ.lda
1705 isame( 8 ) =
lde( bs, bb, lbb )
1706 isame( 9 ) = ldbs.EQ.ldb
1707 isame( 10 ) = bets.EQ.beta
1709 isame( 11 ) =
lde( cs, cc, lcc )
1711 isame( 11 ) =
lderes(
'SY', uplo, n, n, cs,
1714 isame( 12 ) = ldcs.EQ.ldc
1721 same = same.AND.isame( i )
1722 IF( .NOT.isame( i ) )
1723 $
WRITE( nout, fmt = 9998 )i
1746 w( i ) = ab( ( j - 1 )*2*nmax + k +
1748 w( k + i ) = ab( ( j - 1 )*2*nmax +
1751 CALL dmmch(
'T',
'N', lj, 1, 2*k,
1752 $ alpha, ab( jjab ), 2*nmax,
1754 $ c( jj, j ), nmax, ct, g,
1755 $ cc( jc ), ldc, eps, err,
1756 $ fatal, nout, .true. )
1759 w( i ) = ab( ( k + i - 1 )*nmax +
1761 w( k + i ) = ab( ( i - 1 )*nmax +
1764 CALL dmmch(
'N',
'N', lj, 1, 2*k,
1765 $ alpha, ab( jj ), nmax, w,
1766 $ 2*nmax, beta, c( jj, j ),
1767 $ nmax, ct, g, cc( jc ), ldc,
1768 $ eps, err, fatal, nout,
1776 $ jjab = jjab + 2*nmax
1778 errmax = max( errmax, err )
1800 IF( errmax.LT.thresh )
THEN
1801 WRITE( nout, fmt = 9999 )sname, nc
1803 WRITE( nout, fmt = 9997 )sname, nc, errmax
1809 $
WRITE( nout, fmt = 9995 )j
1812 WRITE( nout, fmt = 9996 )sname
1813 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1814 $ lda, ldb, beta, ldc
1819 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1821 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1822 $
'ANGED INCORRECTLY *******' )
1823 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1824 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1825 $
' - SUSPECT *******' )
1826 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1827 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1828 9994
FORMAT( 1x, i6,
': ', a6,
'(', 2(
'''', a1,
''',' ), 2( i3,
',' ),
1829 $ f4.1,
', A,', i3,
', B,', i3,
',', f4.1,
', C,', i3,
') ',
1831 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
logical function lde(RI, RJ, LR)
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
subroutine dmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYR2K