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

◆ zchk6()

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

Definition at line 3707 of file zblat3.f.

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