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

◆ cchk6()

subroutine cchk6 ( character*7 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( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
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 )

Definition at line 3693 of file cblat3.f.

3696*
3697* Tests CGEMMTR.
3698*
3699* Auxiliary routine for test program for Level 3 Blas.
3700*
3701* -- Written on 8-February-1989.
3702* Jack Dongarra, Argonne National Laboratory.
3703* Iain Duff, AERE Harwell.
3704* Jeremy Du Croz, Numerical Algorithms Group Ltd.
3705* Sven Hammarling, Numerical Algorithms Group Ltd.
3706*
3707* .. Parameters ..
3708 COMPLEX ZERO
3709 parameter( zero = ( 0.0, 0.0 ) )
3710 REAL RZERO
3711 parameter( rzero = 0.0 )
3712* .. Scalar Arguments ..
3713 REAL EPS, THRESH
3714 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
3715 LOGICAL FATAL, REWI, TRACE
3716 CHARACTER*7 SNAME
3717* .. Array Arguments ..
3718 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
3719 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
3720 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
3721 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
3722 $ CS( NMAX*NMAX ), CT( NMAX )
3723 REAL G( NMAX )
3724 INTEGER IDIM( NIDIM )
3725* .. Local Scalars ..
3726 COMPLEX ALPHA, ALS, BETA, BLS
3727 REAL ERR, ERRMAX
3728 INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
3729 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
3730 $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
3731 LOGICAL NULL, RESET, SAME, TRANA, TRANB
3732 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
3733 CHARACTER*3 ICH
3734 CHARACTER*2 ISHAPE
3735* .. Local Arrays ..
3736 LOGICAL ISAME( 13 )
3737* .. External Functions ..
3738 LOGICAL LCE, LCERES
3739 EXTERNAL lce, lceres
3740* .. External Subroutines ..
3741 EXTERNAL cgemm, cmake, cmmch
3742* .. Intrinsic Functions ..
3743 INTRINSIC max
3744* .. Scalars in Common ..
3745 INTEGER INFOT, NOUTC
3746 LOGICAL LERR, OK
3747* .. Common blocks ..
3748 COMMON /infoc/infot, noutc, ok, lerr
3749* .. Data statements ..
3750 DATA ich/'NTC'/
3751 DATA ishape/'UL'/
3752
3753* .. Executable Statements ..
3754*
3755 nargs = 13
3756 nc = 0
3757 reset = .true.
3758 errmax = rzero
3759*
3760 DO 100 in = 1, nidim
3761 n = idim( in )
3762* Set LDC to 1 more than minimum value if room.
3763 ldc = n
3764 IF( ldc.LT.nmax )
3765 $ ldc = ldc + 1
3766* Skip tests if not enough room.
3767 IF( ldc.GT.nmax )
3768 $ GO TO 100
3769 lcc = ldc*n
3770 null = n.LE.0
3771*
3772 DO 90 ik = 1, nidim
3773 k = idim( ik )
3774*
3775 DO 80 ica = 1, 3
3776 transa = ich( ica: ica )
3777 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3778*
3779 IF( trana )THEN
3780 ma = k
3781 na = n
3782 ELSE
3783 ma = n
3784 na = k
3785 END IF
3786* Set LDA to 1 more than minimum value if room.
3787 lda = ma
3788 IF( lda.LT.nmax )
3789 $ lda = lda + 1
3790* Skip tests if not enough room.
3791 IF( lda.GT.nmax )
3792 $ GO TO 80
3793 laa = lda*na
3794*
3795* Generate the matrix A.
3796*
3797 CALL cmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
3798 $ reset, zero )
3799*
3800 DO 70 icb = 1, 3
3801 transb = ich( icb: icb )
3802 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3803*
3804 IF( tranb )THEN
3805 mb = n
3806 nb = k
3807 ELSE
3808 mb = k
3809 nb = n
3810 END IF
3811* Set LDB to 1 more than minimum value if room.
3812 ldb = mb
3813 IF( ldb.LT.nmax )
3814 $ ldb = ldb + 1
3815* Skip tests if not enough room.
3816 IF( ldb.GT.nmax )
3817 $ GO TO 70
3818 lbb = ldb*nb
3819*
3820* Generate the matrix B.
3821*
3822 CALL cmake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
3823 $ ldb, reset, zero )
3824*
3825 DO 60 ia = 1, nalf
3826 alpha = alf( ia )
3827*
3828 DO 50 ib = 1, nbet
3829 beta = bet( ib )
3830 DO 45 is = 1, 2
3831 uplo = ishape( is: is )
3832
3833*
3834* Generate the matrix C.
3835*
3836 CALL cmake( 'GE', uplo, ' ', n, n, c, nmax,
3837 $ cc, ldc, reset, zero )
3838*
3839 nc = nc + 1
3840*
3841* Save every datum before calling the
3842* subroutine.
3843*
3844 uplos = uplo
3845 tranas = transa
3846 tranbs = transb
3847 ns = n
3848 ks = k
3849 als = alpha
3850 DO 10 i = 1, laa
3851 as( i ) = aa( i )
3852 10 CONTINUE
3853 ldas = lda
3854 DO 20 i = 1, lbb
3855 bs( i ) = bb( i )
3856 20 CONTINUE
3857 ldbs = ldb
3858 bls = beta
3859 DO 30 i = 1, lcc
3860 cs( i ) = cc( i )
3861 30 CONTINUE
3862 ldcs = ldc
3863*
3864* Call the subroutine.
3865*
3866 IF( trace )
3867 $ WRITE( ntra, fmt = 9995 )nc, sname, uplo,
3868 $ transa, transb, n, k, alpha, lda, ldb,
3869 $ beta, ldc
3870 IF( rewi )
3871 $ rewind ntra
3872 CALL cgemmtr( uplo, transa, transb, n, k,
3873 $ alpha, aa, lda, bb, ldb, beta,
3874 $ cc, ldc )
3875*
3876* Check if error-exit was taken incorrectly.
3877*
3878 IF( .NOT.ok )THEN
3879 WRITE( nout, fmt = 9994 )
3880 fatal = .true.
3881 GO TO 120
3882 END IF
3883*
3884* See what data changed inside subroutines.
3885*
3886 isame( 1 ) = uplos.EQ.uplo
3887 isame( 2 ) = transa.EQ.tranas
3888 isame( 3 ) = transb.EQ.tranbs
3889 isame( 4 ) = ns.EQ.n
3890 isame( 5 ) = ks.EQ.k
3891 isame( 6 ) = als.EQ.alpha
3892 isame( 7 ) = lce( as, aa, laa )
3893 isame( 8 ) = ldas.EQ.lda
3894 isame( 9 ) = lce( bs, bb, lbb )
3895 isame( 10 ) = ldbs.EQ.ldb
3896 isame( 11 ) = bls.EQ.beta
3897 IF( null )THEN
3898 isame( 12 ) = lce( cs, cc, lcc )
3899 ELSE
3900 isame( 12 ) = lceres( 'GE', ' ', n, n, cs,
3901 $ cc, ldc )
3902 END IF
3903 isame( 13 ) = ldcs.EQ.ldc
3904*
3905* If data was incorrectly changed, report
3906* and return.
3907*
3908 same = .true.
3909 DO 40 i = 1, nargs
3910 same = same.AND.isame( i )
3911 IF( .NOT.isame( i ) )
3912 $ WRITE( nout, fmt = 9998 )i
3913 40 CONTINUE
3914 IF( .NOT.same )THEN
3915 fatal = .true.
3916 GO TO 120
3917 END IF
3918*
3919 IF( .NOT.null )THEN
3920*
3921* Check the result.
3922*
3923 CALL cmmtch( uplo, transa, transb, n,
3924 $ k, alpha, a, nmax, b, nmax,
3925 $ beta, c, nmax, ct, g, cc, ldc,
3926 $ eps, err, fatal, nout, .true.)
3927 errmax = max( errmax, err )
3928* If got really bad answer, report and
3929* return.
3930 IF( fatal )
3931 $ GO TO 120
3932 END IF
3933 45 CONTINUE
3934*
3935 50 CONTINUE
3936*
3937 60 CONTINUE
3938*
3939 70 CONTINUE
3940*
3941 80 CONTINUE
3942*
3943 90 CONTINUE
3944*
3945 100 CONTINUE
3946*
3947*
3948* Report result.
3949*
3950 IF( errmax.LT.thresh )THEN
3951 WRITE( nout, fmt = 9999 )sname, nc
3952 ELSE
3953 WRITE( nout, fmt = 9997 )sname, nc, errmax
3954 END IF
3955 GO TO 130
3956*
3957 120 CONTINUE
3958 WRITE( nout, fmt = 9996 )sname
3959 WRITE( nout, fmt = 9995 )nc, sname, transa, transb, n, k,
3960 $ alpha, lda, ldb, beta, ldc
3961*
3962 130 CONTINUE
3963 RETURN
3964*
3965 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
3966 $ 'S)' )
3967 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
3968 $ 'ANGED INCORRECTLY *******' )
3969 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
3970 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
3971 $ ' - SUSPECT *******' )
3972 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
3973 9995 FORMAT( 1x, i6, ': ', a6, '(''',a1, ''',''',a1, ''',''', a1,''',',
3974 $ 2( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
3975 $ ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
3976 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
3977 $ '******' )
3978*
3979* End of CCHK6
3980*
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
cmmtch
subroutine cmmtch(uplo, transa, transb, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition cblat3.f:3986
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
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:188
cgemmtr
subroutine cgemmtr(uplo, transa, transb, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMMTR
Definition cgemmtr.f:191
Here is the call graph for this function: