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

◆ dchk2()

subroutine dchk2 ( 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,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer nmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax, nmax ) b,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax, nmax ) c,
double precision, dimension( nmax*nmax ) cc,
double precision, dimension( nmax*nmax ) cs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 757 of file c_dblat3.f.

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