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

◆ zchk2()

subroutine zchk2 ( character*12  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,
integer  iorder 
)

Definition at line 756 of file c_zblat3.f.

760*
761* Tests ZHEMM and ZSYMM.
762*
763* Auxiliary routine for test program for Level 3 Blas.
764*
765* -- Written on 8-February-1989.
766* Jack Dongarra, Argonne National Laboratory.
767* Iain Duff, AERE Harwell.
768* Jeremy Du Croz, Numerical Algorithms Group Ltd.
769* Sven Hammarling, Numerical Algorithms Group Ltd.
770*
771* .. Parameters ..
772 COMPLEX*16 ZERO
773 parameter( zero = ( 0.0d0, 0.0d0 ) )
774 DOUBLE PRECISION RZERO
775 parameter( rzero = 0.0d0 )
776* .. Scalar Arguments ..
777 DOUBLE PRECISION EPS, THRESH
778 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
779 LOGICAL FATAL, REWI, TRACE
780 CHARACTER*12 SNAME
781* .. Array Arguments ..
782 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
783 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
784 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
785 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
786 $ CS( NMAX*NMAX ), CT( NMAX )
787 DOUBLE PRECISION G( NMAX )
788 INTEGER IDIM( NIDIM )
789* .. Local Scalars ..
790 COMPLEX*16 ALPHA, ALS, BETA, BLS
791 DOUBLE PRECISION ERR, ERRMAX
792 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
793 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
794 $ NARGS, NC, NS
795 LOGICAL CONJ, LEFT, NULL, RESET, SAME
796 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
797 CHARACTER*2 ICHS, ICHU
798* .. Local Arrays ..
799 LOGICAL ISAME( 13 )
800* .. External Functions ..
801 LOGICAL LZE, LZERES
802 EXTERNAL lze, lzeres
803* .. External Subroutines ..
804 EXTERNAL czhemm, zmake, zmmch, czsymm
805* .. Intrinsic Functions ..
806 INTRINSIC max
807* .. Scalars in Common ..
808 INTEGER INFOT, NOUTC
809 LOGICAL LERR, OK
810* .. Common blocks ..
811 COMMON /infoc/infot, noutc, ok, lerr
812* .. Data statements ..
813 DATA ichs/'LR'/, ichu/'UL'/
814* .. Executable Statements ..
815 conj = sname( 8: 9 ).EQ.'he'
816*
817 nargs = 12
818 nc = 0
819 reset = .true.
820 errmax = rzero
821*
822 DO 100 im = 1, nidim
823 m = idim( im )
824*
825 DO 90 in = 1, nidim
826 n = idim( in )
827* Set LDC to 1 more than minimum value if room.
828 ldc = m
829 IF( ldc.LT.nmax )
830 $ ldc = ldc + 1
831* Skip tests if not enough room.
832 IF( ldc.GT.nmax )
833 $ GO TO 90
834 lcc = ldc*n
835 null = n.LE.0.OR.m.LE.0
836* Set LDB to 1 more than minimum value if room.
837 ldb = m
838 IF( ldb.LT.nmax )
839 $ ldb = ldb + 1
840* Skip tests if not enough room.
841 IF( ldb.GT.nmax )
842 $ GO TO 90
843 lbb = ldb*n
844*
845* Generate the matrix B.
846*
847 CALL zmake( 'ge', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
848 $ zero )
849*
850 DO 80 ics = 1, 2
851 side = ichs( ics: ics )
852 left = side.EQ.'L'
853*
854 IF( left )THEN
855 na = m
856 ELSE
857 na = n
858 END IF
859* Set LDA to 1 more than minimum value if room.
860 lda = na
861 IF( lda.LT.nmax )
862 $ lda = lda + 1
863* Skip tests if not enough room.
864 IF( lda.GT.nmax )
865 $ GO TO 80
866 laa = lda*na
867*
868 DO 70 icu = 1, 2
869 uplo = ichu( icu: icu )
870*
871* Generate the hermitian or symmetric matrix A.
872*
873 CALL zmake(sname( 8: 9 ), uplo, ' ', na, na, a, nmax,
874 $ aa, lda, reset, zero )
875*
876 DO 60 ia = 1, nalf
877 alpha = alf( ia )
878*
879 DO 50 ib = 1, nbet
880 beta = bet( ib )
881*
882* Generate the matrix C.
883*
884 CALL zmake( 'ge', ' ', ' ', m, n, c, nmax, cc,
885 $ ldc, reset, zero )
886*
887 nc = nc + 1
888*
889* Save every datum before calling the
890* subroutine.
891*
892 sides = side
893 uplos = uplo
894 ms = m
895 ns = n
896 als = alpha
897 DO 10 i = 1, laa
898 as( i ) = aa( i )
899 10 CONTINUE
900 ldas = lda
901 DO 20 i = 1, lbb
902 bs( i ) = bb( i )
903 20 CONTINUE
904 ldbs = ldb
905 bls = beta
906 DO 30 i = 1, lcc
907 cs( i ) = cc( i )
908 30 CONTINUE
909 ldcs = ldc
910*
911* Call the subroutine.
912*
913 IF( trace )
914 $ CALL zprcn2(ntra, nc, sname, iorder,
915 $ side, uplo, m, n, alpha, lda, ldb,
916 $ beta, ldc)
917 IF( rewi )
918 $ rewind ntra
919 IF( conj )THEN
920 CALL czhemm( iorder, side, uplo, m, n,
921 $ alpha, aa, lda, bb, ldb, beta,
922 $ cc, ldc )
923 ELSE
924 CALL czsymm( iorder, side, uplo, m, n,
925 $ alpha, aa, lda, bb, ldb, beta,
926 $ cc, ldc )
927 END IF
928*
929* Check if error-exit was taken incorrectly.
930*
931 IF( .NOT.ok )THEN
932 WRITE( nout, fmt = 9994 )
933 fatal = .true.
934 GO TO 110
935 END IF
936*
937* See what data changed inside subroutines.
938*
939 isame( 1 ) = sides.EQ.side
940 isame( 2 ) = uplos.EQ.uplo
941 isame( 3 ) = ms.EQ.m
942 isame( 4 ) = ns.EQ.n
943 isame( 5 ) = als.EQ.alpha
944 isame( 6 ) = lze( as, aa, laa )
945 isame( 7 ) = ldas.EQ.lda
946 isame( 8 ) = lze( bs, bb, lbb )
947 isame( 9 ) = ldbs.EQ.ldb
948 isame( 10 ) = bls.EQ.beta
949 IF( null )THEN
950 isame( 11 ) = lze( cs, cc, lcc )
951 ELSE
952 isame( 11 ) = lzeres( 'ge', ' ', m, n, cs,
953 $ cc, ldc )
954 END IF
955 isame( 12 ) = ldcs.EQ.ldc
956*
957* If data was incorrectly changed, report and
958* return.
959*
960 same = .true.
961 DO 40 i = 1, nargs
962 same = same.AND.isame( i )
963 IF( .NOT.isame( i ) )
964 $ WRITE( nout, fmt = 9998 )i
965 40 CONTINUE
966 IF( .NOT.same )THEN
967 fatal = .true.
968 GO TO 110
969 END IF
970*
971 IF( .NOT.null )THEN
972*
973* Check the result.
974*
975 IF( left )THEN
976 CALL zmmch( 'N', 'N', m, n, m, alpha, a,
977 $ nmax, b, nmax, beta, c, nmax,
978 $ ct, g, cc, ldc, eps, err,
979 $ fatal, nout, .true. )
980 ELSE
981 CALL zmmch( 'N', 'N', m, n, n, alpha, b,
982 $ nmax, a, nmax, beta, c, nmax,
983 $ ct, g, cc, ldc, eps, err,
984 $ fatal, nout, .true. )
985 END IF
986 errmax = max( errmax, err )
987* If got really bad answer, report and
988* return.
989 IF( fatal )
990 $ GO TO 110
991 END IF
992*
993 50 CONTINUE
994*
995 60 CONTINUE
996*
997 70 CONTINUE
998*
999 80 CONTINUE
1000*
1001 90 CONTINUE
1002*
1003 100 CONTINUE
1004*
1005* Report result.
1006*
1007 IF( errmax.LT.thresh )THEN
1008 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1009 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1010 ELSE
1011 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1012 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1013 END IF
1014 GO TO 120
1015*
1016 110 CONTINUE
1017 WRITE( nout, fmt = 9996 )sname
1018 CALL zprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda,
1019 $ ldb, beta, ldc)
1020*
1021 120 CONTINUE
1022 RETURN
1023*
102410003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1025 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1026 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
102710002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1028 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1029 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
103010001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1031 $ ' (', i6, ' CALL', 'S)' )
103210000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1033 $ ' (', i6, ' CALL', 'S)' )
1034 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1035 $ 'ANGED INCORRECTLY *******' )
1036 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1037 9995 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1038 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
1039 $ ',', f4.1, '), C,', i3, ') .' )
1040 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1041 $ '******' )
1042*
1043* End of ZCHK2.
1044*
zprcn2
subroutine zprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
Definition c_zblat3.f:1049
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:3061
Here is the call graph for this function: