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

◆ zchk2()

subroutine zchk2 ( character*13 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 771 of file c_zblat3.f.

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