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

◆ dchk2()

subroutine dchk2 ( 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,
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 )

Definition at line 680 of file dblat3.f.

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