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

◆ dchk2()

subroutine dchk2 ( 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,
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 741 of file c_dblat3.f.

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