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

◆ zchk2()

subroutine zchk2 ( 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 698 of file zblat3.f.

701*
702* Tests ZHEMM and ZSYMM.
703*
704* Auxiliary routine for test program for Level 3 Blas.
705*
706* -- Written on 8-February-1989.
707* Jack Dongarra, Argonne National Laboratory.
708* Iain Duff, AERE Harwell.
709* Jeremy Du Croz, Numerical Algorithms Group Ltd.
710* Sven Hammarling, Numerical Algorithms Group Ltd.
711*
712* .. Parameters ..
713 COMPLEX*16 ZERO
714 parameter( zero = ( 0.0d0, 0.0d0 ) )
715 DOUBLE PRECISION RZERO
716 parameter( rzero = 0.0d0 )
717* .. Scalar Arguments ..
718 DOUBLE PRECISION EPS, THRESH
719 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
720 LOGICAL FATAL, REWI, TRACE
721 CHARACTER*7 SNAME
722* .. Array Arguments ..
723 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
724 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
725 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
726 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
727 $ CS( NMAX*NMAX ), CT( NMAX )
728 DOUBLE PRECISION G( NMAX )
729 INTEGER IDIM( NIDIM )
730* .. Local Scalars ..
731 COMPLEX*16 ALPHA, ALS, BETA, BLS
732 DOUBLE PRECISION ERR, ERRMAX
733 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
734 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
735 $ NARGS, NC, NS
736 LOGICAL CONJ, LEFT, NULL, RESET, SAME
737 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
738 CHARACTER*2 ICHS, ICHU
739* .. Local Arrays ..
740 LOGICAL ISAME( 13 )
741* .. External Functions ..
742 LOGICAL LZE, LZERES
743 EXTERNAL lze, lzeres
744* .. External Subroutines ..
745 EXTERNAL zhemm, zmake, zmmch, zsymm
746* .. Intrinsic Functions ..
747 INTRINSIC max
748* .. Scalars in Common ..
749 INTEGER INFOT, NOUTC
750 LOGICAL LERR, OK
751* .. Common blocks ..
752 COMMON /infoc/infot, noutc, ok, lerr
753* .. Data statements ..
754 DATA ichs/'LR'/, ichu/'UL'/
755* .. Executable Statements ..
756 conj = sname( 2: 3 ).EQ.'HE'
757*
758 nargs = 12
759 nc = 0
760 reset = .true.
761 errmax = rzero
762*
763 DO 100 im = 1, nidim
764 m = idim( im )
765*
766 DO 90 in = 1, nidim
767 n = idim( in )
768* Set LDC to 1 more than minimum value if room.
769 ldc = m
770 IF( ldc.LT.nmax )
771 $ ldc = ldc + 1
772* Skip tests if not enough room.
773 IF( ldc.GT.nmax )
774 $ GO TO 90
775 lcc = ldc*n
776 null = n.LE.0.OR.m.LE.0
777* Set LDB to 1 more than minimum value if room.
778 ldb = m
779 IF( ldb.LT.nmax )
780 $ ldb = ldb + 1
781* Skip tests if not enough room.
782 IF( ldb.GT.nmax )
783 $ GO TO 90
784 lbb = ldb*n
785*
786* Generate the matrix B.
787*
788 CALL zmake( 'GE', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
789 $ zero )
790*
791 DO 80 ics = 1, 2
792 side = ichs( ics: ics )
793 left = side.EQ.'L'
794*
795 IF( left )THEN
796 na = m
797 ELSE
798 na = n
799 END IF
800* Set LDA to 1 more than minimum value if room.
801 lda = na
802 IF( lda.LT.nmax )
803 $ lda = lda + 1
804* Skip tests if not enough room.
805 IF( lda.GT.nmax )
806 $ GO TO 80
807 laa = lda*na
808*
809 DO 70 icu = 1, 2
810 uplo = ichu( icu: icu )
811*
812* Generate the hermitian or symmetric matrix A.
813*
814 CALL zmake( sname( 2: 3 ), uplo, ' ', na, na, a, nmax,
815 $ aa, lda, reset, zero )
816*
817 DO 60 ia = 1, nalf
818 alpha = alf( ia )
819*
820 DO 50 ib = 1, nbet
821 beta = bet( ib )
822*
823* Generate the matrix C.
824*
825 CALL zmake( 'GE', ' ', ' ', m, n, c, nmax, cc,
826 $ ldc, reset, zero )
827*
828 nc = nc + 1
829*
830* Save every datum before calling the
831* subroutine.
832*
833 sides = side
834 uplos = uplo
835 ms = m
836 ns = n
837 als = alpha
838 DO 10 i = 1, laa
839 as( i ) = aa( i )
840 10 CONTINUE
841 ldas = lda
842 DO 20 i = 1, lbb
843 bs( i ) = bb( i )
844 20 CONTINUE
845 ldbs = ldb
846 bls = beta
847 DO 30 i = 1, lcc
848 cs( i ) = cc( i )
849 30 CONTINUE
850 ldcs = ldc
851*
852* Call the subroutine.
853*
854 IF( trace )
855 $ WRITE( ntra, fmt = 9995 )nc, sname, side,
856 $ uplo, m, n, alpha, lda, ldb, beta, ldc
857 IF( rewi )
858 $ rewind ntra
859 IF( conj )THEN
860 CALL zhemm( side, uplo, m, n, alpha, aa, lda,
861 $ bb, ldb, beta, cc, ldc )
862 ELSE
863 CALL zsymm( side, uplo, m, n, alpha, aa, lda,
864 $ bb, ldb, beta, cc, ldc )
865 END IF
866*
867* Check if error-exit was taken incorrectly.
868*
869 IF( .NOT.ok )THEN
870 WRITE( nout, fmt = 9994 )
871 fatal = .true.
872 GO TO 110
873 END IF
874*
875* See what data changed inside subroutines.
876*
877 isame( 1 ) = sides.EQ.side
878 isame( 2 ) = uplos.EQ.uplo
879 isame( 3 ) = ms.EQ.m
880 isame( 4 ) = ns.EQ.n
881 isame( 5 ) = als.EQ.alpha
882 isame( 6 ) = lze( as, aa, laa )
883 isame( 7 ) = ldas.EQ.lda
884 isame( 8 ) = lze( bs, bb, lbb )
885 isame( 9 ) = ldbs.EQ.ldb
886 isame( 10 ) = bls.EQ.beta
887 IF( null )THEN
888 isame( 11 ) = lze( cs, cc, lcc )
889 ELSE
890 isame( 11 ) = lzeres( 'GE', ' ', m, n, cs,
891 $ cc, ldc )
892 END IF
893 isame( 12 ) = ldcs.EQ.ldc
894*
895* If data was incorrectly changed, report and
896* return.
897*
898 same = .true.
899 DO 40 i = 1, nargs
900 same = same.AND.isame( i )
901 IF( .NOT.isame( i ) )
902 $ WRITE( nout, fmt = 9998 )i
903 40 CONTINUE
904 IF( .NOT.same )THEN
905 fatal = .true.
906 GO TO 110
907 END IF
908*
909 IF( .NOT.null )THEN
910*
911* Check the result.
912*
913 IF( left )THEN
914 CALL zmmch( 'N', 'N', m, n, m, alpha, a,
915 $ nmax, b, nmax, beta, c, nmax,
916 $ ct, g, cc, ldc, eps, err,
917 $ fatal, nout, .true. )
918 ELSE
919 CALL zmmch( 'N', 'N', m, n, n, alpha, b,
920 $ nmax, a, nmax, beta, c, nmax,
921 $ ct, g, cc, ldc, eps, err,
922 $ fatal, nout, .true. )
923 END IF
924 errmax = max( errmax, err )
925* If got really bad answer, report and
926* return.
927 IF( fatal )
928 $ GO TO 110
929 END IF
930*
931 50 CONTINUE
932*
933 60 CONTINUE
934*
935 70 CONTINUE
936*
937 80 CONTINUE
938*
939 90 CONTINUE
940*
941 100 CONTINUE
942*
943* Report result.
944*
945 IF( errmax.LT.thresh )THEN
946 WRITE( nout, fmt = 9999 )sname, nc
947 ELSE
948 WRITE( nout, fmt = 9997 )sname, nc, errmax
949 END IF
950 GO TO 120
951*
952 110 CONTINUE
953 WRITE( nout, fmt = 9996 )sname
954 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, m, n, alpha, lda,
955 $ ldb, beta, ldc
956*
957 120 CONTINUE
958 RETURN
959*
960 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
961 $ 'S)' )
962 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
963 $ 'ANGED INCORRECTLY *******' )
964 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
965 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
966 $ ' - SUSPECT *******' )
967 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
968 9995 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
969 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
970 $ ',', f4.1, '), C,', i3, ') .' )
971 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
972 $ '******' )
973*
974* End of ZCHK2
975*
zhemm
subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZHEMM
Definition zhemm.f:191
zsymm
subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZSYMM
Definition zsymm.f:189
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:3266
Here is the call graph for this function: