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

◆ zchk2()

subroutine zchk2 ( character*6  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 689 of file zblat3.f.

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